diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 00000000000..ac692eec191 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,31 @@ +on: + pull_request: + push: + branches: [master] + +jobs: + build-dev-env: + name: Build dev env + strategy: + matrix: + os: + - ubuntu-latest + # This is too expensive + # - macos-latest + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v2 + with: + submodules: true + - uses: cachix/install-nix-action@v14.1 + - uses: cachix/cachix-action@v10 + with: + name: wire-server + signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' + authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' + - name: Build the wire-server-direnv + run: nix-build --no-out-link direnv.nix + - name: Install the wire-server-direnv + run: nix-env -f direnv.nix -i + - name: Ensure everything is formatted + run: make formatc diff --git a/.gitignore b/.gitignore index 8e9a7a3b4c7..d1c8a56e869 100644 --- a/.gitignore +++ b/.gitignore @@ -99,3 +99,7 @@ b.yaml telepresence.log /.ghci + +# local config +.envrc.local +cabal.project.local \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index 0497d809de2..5537dbb6319 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,50 @@ +# [2021-11-15] + +## Release notes + +* In case you use a multi-datacentre cassandra setup (most likely you do not), be aware that now [LOCAL_QUORUM](https://docs.datastax.com/en/cassandra-oss/3.0/cassandra/dml/dmlConfigConsistency.html) is in use as a default. (#1884) +* Deploy galley before brig. (#1857) +* Upgrade webapp version to 2021-11-01-production.0-v0.28.29-0-d919633 (#1856) + +## API changes + +* Remove locale from publicly facing user profiles (but not from the self profile) (#1888) + +## Features + +* End-points for configuring self-deleting messages. (#1857) + +## Bug fixes and other updates + +* Ensure that all endpoints have a correct handler in prometheus metrics (#1919) +* Push events when AppLock or SelfDeletingMessages config change. (#1901) + +## Documentation + +* Federation: Document how to deploy local builds (#1880) + +## Internal changes + +* Add a 'filterNodesByDatacentre' config option useful during cassandra DC migration (#1886) +* Add ormolu to the direnv, add a GH Action to ensure formatting (#1908) +* Turn placeholder access effects into actual Polysemy effects. (#1904) +* Fix a bug in the IdP.Mem interpreter, and added law tests for IdP (#1863) +* Introduce fine-grained error types and polysemy error effects in Galley. (#1907) +* Add polysemy store effects and split off Cassandra specific functionality from the Galley.Data module hierarchy (#1890, #1906). (#1890) +* Make golden-tests in wire-api package a separate test suite (for faster feedback loop during development). (#1926) +* Separate IdPRawMetadataStore effect from IdP effect (#1924) +* Test sending message to multiple remote domains (#1899) +* Use cabal to build wire-server (opt-in) (#1853) + +## Federation changes + +* Close GRPC client after making a request to a federator. (#1865) +* Do not fail user deletion when a remote notification fails (#1912) +* Add a one-to-one conversation test in getting conversations in the federation API (#1899) +* Notify remote participants when a user leaves a conversation because they were deleted (#1891) + # [2021-10-29] ## Release notes diff --git a/Makefile b/Makefile index 980fffa3204..bcedd573e34 100644 --- a/Makefile +++ b/Makefile @@ -39,12 +39,37 @@ init: # Build all Haskell services and executables, run unit tests .PHONY: install install: init +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + cabal build all + ./hack/bin/cabal-run-all-tests.sh + ./hack/bin/cabal-install-all-artefacts.sh +else stack install --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist +endif # Build all Haskell services and executables with -O0, run unit tests .PHONY: fast fast: init +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + make install +else stack install --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist --fast $(WIRE_STACK_OPTIONS) +endif + +# Usage: make c package=brig test=1 +.PHONY: c +c: + cabal build $(WIRE_CABAL_BUILD_OPTIONS) $(package) +ifeq ($(test), 1) + ./hack/bin/cabal-run-tests.sh $(package) +endif + ./hack/bin/cabal-install-artefacts.sh $(package) + +# ci here doesn't refer to continuous integration, but to cabal-integration +# Usage: make ci package=brig test=1 +.PHONY: ci +ci: c + make -C services/$(package) i-$(pattern) # Build everything (Haskell services and nginz) .PHONY: services @@ -54,12 +79,12 @@ services: init install # Build haddocks .PHONY: haddock haddock: - WIRE_STACK_OPTIONS="--haddock --haddock-internal" make fast + WIRE_STACK_OPTIONS="$(WIRE_STACK_OPTIONS) --haddock --haddock-internal" make fast # Build haddocks only for wire-server .PHONY: haddock-shallow haddock-shallow: - WIRE_STACK_OPTIONS="--haddock --haddock-internal --no-haddock-deps" make fast + WIRE_STACK_OPTIONS="$(WIRE_STACK_OPTIONS) --haddock --haddock-internal --no-haddock-deps" make fast # formats all Haskell files (which don't contain CPP) .PHONY: format @@ -232,14 +257,15 @@ libzauth: # # Run this again after changes to libraries or dependencies. .PHONY: hie.yaml -hie.yaml: stack-dev.yaml - stack build implicit-hie - stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml - -.PHONY: stack-dev.yaml -stack-dev.yaml: +hie.yaml: +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + echo -e 'cradle:\n cabal: {}' > hie.yaml +else cp stack.yaml stack-dev.yaml echo -e '\n\nghc-options:\n "$$locals": -O0 -Wall -Werror' >> stack-dev.yaml + stack build implicit-hie + stack exec gen-hie | yq "{cradle: {stack: {stackYaml: \"./stack-dev.yaml\", components: .cradle.stack}}}" > hie.yaml +endif ##################################### # Today we pretend to be CI and run integration tests on kubernetes @@ -277,6 +303,10 @@ kube-integration-test: kube-integration-teardown: export NAMESPACE=$(NAMESPACE); ./hack/bin/integration-teardown-federation.sh +.PHONY: kube-integration-e2e-telepresence +kube-integration-e2e-telepresence: + ./services/brig/federation-tests.sh $(NAMESPACE) + .PHONY: kube-integration-setup-sans-federation kube-integration-setup-sans-federation: guard-tag charts-integration # by default "test- is used as namespace diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000000..ef0d913ebad --- /dev/null +++ b/cabal.project @@ -0,0 +1,280 @@ +-- Generated by stackage-to-hackage + +with-compiler: ghc-8.8.4 + +packages: + libs/api-bot/ + , libs/api-client/ + , libs/bilge/ + , libs/brig-types/ + , libs/cargohold-types/ + , libs/cassandra-util/ + , libs/extended/ + , libs/dns-util/ + , libs/deriving-swagger2/ + , libs/galley-types/ + , libs/gundeck-types/ + , libs/hscim/ + , libs/imports/ + , libs/metrics-core/ + , libs/metrics-wai/ + , libs/polysemy-wire-zoo/ + , libs/ropes/ + , libs/schema-profunctor/ + , libs/sodium-crypto-sign/ + , libs/ssl-util/ + , libs/tasty-cannon/ + , libs/types-common/ + , libs/types-common-aws/ + , libs/types-common-journal/ + , libs/wai-utilities/ + , libs/wire-api/ + , libs/wire-api-federation/ + , libs/wire-message-proto-lens/ + , libs/zauth/ + , services/brig/ + , services/cannon/ + , services/cargohold/ + , services/federator/ + , services/galley/ + , services/gundeck/ + , services/proxy/ + , services/spar/ + , tools/api-simulations/ + , tools/bonanza/ + , tools/db/auto-whitelist/ + , tools/db/migrate-sso-feature-flag/ + , tools/db/service-backfill/ + , tools/db/billing-team-member-backfill/ + , tools/db/find-undead/ + , tools/db/move-team/ + , tools/db/repair-handles/ + , tools/makedeb/ + , tools/rex/ + , tools/stern/ + +source-repository-package + type: git + location: https://github.com/dpwright/HaskellNet-SSL + tag: ca84ef29a93eaef7673fa58056cdd8dae1568d2d + +source-repository-package + type: git + location: https://github.com/fimad/prometheus-haskell + 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/kim/hs-collectd + tag: 885da222be2375f78c7be36127620ed772b677c9 + +source-repository-package + type: git + location: https://github.com/kim/snappy-framing + tag: d99f702c0086729efd6848dea8a01e5266c3a61c + +source-repository-package + type: git + location: https://github.com/lucasdicioccio/http2-client + tag: 73f5975e18eda9d071aa5548fcea6b5a51e61769 + +source-repository-package + type: git + location: https://github.com/vincenthz/hs-certificate + tag: a899bda3d7666d25143be7be8f3105fc076703d9 + subdir: x509-store + +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 + +source-repository-package + type: git + location: https://github.com/wireapp/bloodhound + tag: 92de9aa632d590f288a353d03591c38ba72b3cb3 + +source-repository-package + type: git + location: https://github.com/wireapp/cryptobox-haskell + tag: 7546a1a25635ef65183e3d44c1052285e8401608 + +source-repository-package + type: git + location: https://github.com/wireapp/haskell-multihash.git + tag: 300a6f46384bfca33e545c8bab52ef3717452d12 + +source-repository-package + type: git + location: https://github.com/wireapp/hsaml2 + tag: b652ec6e69d1647e827cbee0fa290605ac09dc63 + +source-repository-package + type: git + location: https://github.com/wireapp/hspec-wai + tag: 0a5142cd3ba48116ff059c041348b817fb7bdb25 + +source-repository-package + type: git + location: https://github.com/wireapp/http-client + tag: 9100baeddbd15d93dc58a826ae812dafff29d5fd + subdir: http-client + http-client-openssl + http-client-tls + http-conduit + +source-repository-package + type: git + location: https://github.com/wireapp/http2 + tag: 7c465be1201e0945b106f7cc6176ac1b1193be13 + +source-repository-package + type: git + location: https://github.com/wireapp/http2-grpc-haskell + tag: eea98418672626eafbace3181ca34bf44bee91c0 + subdir: http2-client-grpc + +source-repository-package + type: git + location: https://github.com/wireapp/saml2-web-sso + tag: 60398f375987b74d6b855b5d225e45dc3a96ac06 + +source-repository-package + type: git + location: https://github.com/wireapp/servant.git + tag: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + subdir: servant + servant-client + servant-client-core + servant-server + +source-repository-package + type: git + location: https://github.com/wireapp/snappy + tag: b0e5c08af48911caecffa4fa6a3e74872018b258 + +source-repository-package + type: git + location: https://gitlab.com/twittner/wai-routing + tag: 7e996a93fec5901767f845a50316b3c18e51a61d + +allow-older: * +allow-newer: * + +-- Changes by ./tools/convert-to-cabal/generate.sh + +tests: True + + +package api-bot + ghc-options: -Werror +package api-client + ghc-options: -Werror +package api-simulations + ghc-options: -Werror +package auto-whitelist + ghc-options: -Werror +package bilge + ghc-options: -Werror +package billing-team-member-backfill + ghc-options: -Werror +package bonanza + ghc-options: -Werror +package brig + ghc-options: -Werror +package brig-types + ghc-options: -Werror +package cannon + ghc-options: -Werror +package cargohold + ghc-options: -Werror +package cargohold-types + ghc-options: -Werror +package cassandra-util + ghc-options: -Werror +package deriving-swagger2 + ghc-options: -Werror +package dns-util + ghc-options: -Werror +package extended + ghc-options: -Werror +package federator + ghc-options: -Werror +package find-undead + ghc-options: -Werror +package galley + ghc-options: -Werror +package galley-types + ghc-options: -Werror +package gundeck + ghc-options: -Werror +package gundeck-types + ghc-options: -Werror +package hscim + ghc-options: -Werror +package imports + ghc-options: -Werror +package makedeb + ghc-options: -Werror +package metrics-core + ghc-options: -Werror +package metrics-wai + ghc-options: -Werror +package migrate-sso-feature-flag + ghc-options: -Werror +package move-team + ghc-options: -Werror +package polysemy-wire-zoo + ghc-options: -Werror +package proxy + ghc-options: -Werror +package repair-handles + ghc-options: -Werror +package rex + ghc-options: -Werror +package ropes + ghc-options: -Werror +package schema-profunctor + ghc-options: -Werror +package service-backfill + ghc-options: -Werror +package sodium-crypto-sign + ghc-options: -Werror +package spar + ghc-options: -Werror +package ssl-util + ghc-options: -Werror +package stern + ghc-options: -Werror +package tasty-cannon + ghc-options: -Werror +package types-common + ghc-options: -Werror +package types-common-aws + ghc-options: -Werror +package types-common-journal + ghc-options: -Werror +package wai-utilities + ghc-options: -Werror +package wire-api + ghc-options: -Werror +package wire-api-federation + ghc-options: -Werror +package wire-message-proto-lens + ghc-options: -Werror +package zauth + ghc-options: -Werror diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 00000000000..71ff635e0b6 --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,2528 @@ +constraints: any.AC-Angle ==1.0, + any.ALUT ==2.4.0.3, + any.ANum ==0.2.0.2, + any.Allure ==0.9.5.0, + any.Boolean ==0.2.4, + any.BoundedChan ==1.0.3.0, + any.ChannelT ==0.0.0.7, + any.Chart ==1.9.3, + any.Chart-diagrams ==1.9.3, + any.ChasingBottoms ==1.3.1.9, + any.Clipboard ==2.3.2.0, + any.ClustalParser ==1.3.0, + any.Color ==0.1.4, + any.ConfigFile ==1.1.4, + any.DAV ==1.3.4, + any.DBFunctor ==0.1.1.1, + any.Decimal ==0.5.1, + any.Diff ==0.4.0, + any.ENIG ==0.0.1.0, + any.Earley ==0.13.0.1, + any.Ebnf2ps ==1.0.15, + any.FenwickTree ==0.1.2.1, + any.FindBin ==0.0.5, + any.FloatingHex ==0.4, + any.FontyFruity ==0.5.3.5, + any.ForestStructures ==0.0.1.0, + any.GLFW-b ==3.3.0.0, + any.GLURaw ==2.0.0.4, + any.GLUT ==2.7.0.15, + any.GenericPretty ==1.2.2, + any.Glob ==0.10.1, + any.HCodecs ==0.5.2, + any.HDBC ==2.4.0.3, + any.HDBC-session ==0.1.2.0, + any.HSlippyMap ==3.0.1, + any.HStringTemplate ==0.8.7, + any.HSvm ==0.1.1.3.22, + any.HTF ==0.14.0.3, + any.HTTP ==4000.3.15, + any.HUnit ==1.6.0.0, + any.HUnit-approx ==1.1.1.1, + any.HaTeX ==3.22.2.0, + any.HaXml ==1.25.5, + any.HandsomeSoup ==0.4.2, + any.HasBigDecimal ==0.1.1, + any.HaskellNet ==0.5.2, + HsOpenSSL -fast-bignum, + any.HsOpenSSL ==0.11.4.19, + any.HsOpenSSL-x509-system ==0.1.0.3, + any.HsYAML ==0.2.1.0, + any.HsYAML-aeson ==0.2.0.0, + any.IPv6Addr ==1.1.5, + any.Imlib ==0.1.2, + any.IntervalMap ==0.6.1.2, + any.JuicyPixels ==3.3.5, + any.JuicyPixels-blurhash ==0.1.0.3, + any.JuicyPixels-extra ==0.4.1, + any.JuicyPixels-scale-dct ==0.1.2, + any.LambdaHack ==0.9.5.0, + any.LibZip ==1.0.1, + any.List ==0.6.2, + any.ListLike ==4.7.2, + any.ListTree ==0.2.3, + any.MemoTrie ==0.6.10, + any.MissingH ==1.4.3.0, + any.MonadPrompt ==1.0.0.5, + any.MonadRandom ==0.5.2, + any.MusicBrainz ==0.4.1, + NineP -bytestring-in-base, + any.NineP ==0.0.2.1, + any.NumInstances ==1.4, + any.ObjectName ==1.1.0.1, + any.OneTuple ==0.2.2.1, + any.Only ==0.1, + any.OpenAL ==1.7.0.5, + any.OpenGL ==3.0.3.0, + any.OpenGLRaw ==3.3.4.0, + any.ParsecTools ==0.0.2.0, + any.PyF ==0.9.0.2, + any.QuasiText ==0.1.2.6, + any.QuickCheck ==2.14, + any.RSA ==2.4.1, + any.Ranged-sets ==0.4.0, + any.Rasterific ==0.7.5.2, + any.RefSerialize ==0.4.0, + any.SHA ==1.6.4.4, + any.SVGFonts ==1.7.0.1, + any.SafeSemaphore ==0.10.1, + any.ShellCheck ==0.7.1, + any.Spintax ==0.3.5, + any.StateVar ==1.2, + any.TCache ==0.12.1, + any.Taxonomy ==2.1.0, + any.TypeCompose ==0.9.14, + any.ViennaRNAParser ==1.3.3, + any.Win32 ==2.6.1.0, + any.Win32-notify ==0.3.0.3, + any.X11 ==1.9.2, + any.X11-xft ==0.3.1, + any.Xauth ==0.1, + any.abstract-deque ==0.3, + any.abstract-par ==0.3.3, + any.accuerr ==0.2.0.2, + any.ace ==0.6, + any.action-permutations ==0.0.0.1, + any.active ==0.2.0.14, + any.ad ==4.4, + any.adjunctions ==4.4, + any.adler32 ==0.1.2.0, + any.advent-of-code-api ==0.2.7.0, + any.aeson ==1.4.7.1, + any.aeson-attoparsec ==0.0.0, + any.aeson-better-errors ==0.9.1.0, + any.aeson-casing ==0.2.0.0, + any.aeson-combinators ==0.0.2.1, + any.aeson-compat ==0.3.9, + any.aeson-default ==0.9.1.0, + any.aeson-diff ==1.1.0.9, + any.aeson-generic-compat ==0.0.1.3, + any.aeson-lens ==0.5.0.0, + any.aeson-optics ==1.1.0.1, + any.aeson-picker ==0.1.0.5, + any.aeson-pretty ==0.8.8, + any.aeson-qq ==0.8.3, + any.aeson-schemas ==1.2.0, + any.aeson-utils ==0.3.0.2, + any.aeson-yak ==0.1.1.3, + any.aeson-yaml ==1.0.6.0, + any.al ==0.1.4.2, + any.alarmclock ==0.7.0.5, + any.alerts ==0.1.2.0, + any.alex ==3.2.5, + any.alg ==0.2.13.1, + any.algebraic-graphs ==0.5, + any.almost-fix ==0.0.2, + any.alsa-core ==0.5.0.1, + any.alsa-mixer ==0.3.0, + any.alsa-pcm ==0.6.1.1, + any.alsa-seq ==0.6.0.7, + any.alternative-vector ==0.0.0, + any.amazonka-apigateway ==1.6.1, + any.amazonka-application-autoscaling ==1.6.1, + any.amazonka-appstream ==1.6.1, + any.amazonka-athena ==1.6.1, + any.amazonka-autoscaling ==1.6.1, + any.amazonka-budgets ==1.6.1, + any.amazonka-certificatemanager ==1.6.1, + any.amazonka-cloudformation ==1.6.1, + any.amazonka-cloudhsm ==1.6.1, + any.amazonka-cloudsearch ==1.6.1, + any.amazonka-cloudsearch-domains ==1.6.1, + any.amazonka-cloudtrail ==1.6.1, + any.amazonka-cloudwatch ==1.6.1, + any.amazonka-cloudwatch-events ==1.6.1, + any.amazonka-cloudwatch-logs ==1.6.1, + any.amazonka-codebuild ==1.6.1, + any.amazonka-codecommit ==1.6.1, + any.amazonka-codedeploy ==1.6.1, + any.amazonka-codepipeline ==1.6.1, + any.amazonka-cognito-identity ==1.6.1, + any.amazonka-cognito-idp ==1.6.1, + any.amazonka-cognito-sync ==1.6.1, + any.amazonka-config ==1.6.1, + any.amazonka-datapipeline ==1.6.1, + any.amazonka-devicefarm ==1.6.1, + any.amazonka-directconnect ==1.6.1, + any.amazonka-discovery ==1.6.1, + any.amazonka-dms ==1.6.1, + any.amazonka-ds ==1.6.1, + any.amazonka-dynamodb-streams ==1.6.1, + any.amazonka-ecr ==1.6.1, + any.amazonka-ecs ==1.6.1, + any.amazonka-efs ==1.6.1, + any.amazonka-elasticache ==1.6.1, + any.amazonka-elasticbeanstalk ==1.6.1, + any.amazonka-elasticsearch ==1.6.1, + any.amazonka-elastictranscoder ==1.6.1, + any.amazonka-elb ==1.6.1, + any.amazonka-elbv2 ==1.6.1, + any.amazonka-emr ==1.6.1, + any.amazonka-gamelift ==1.6.1, + any.amazonka-glacier ==1.6.1, + any.amazonka-glue ==1.6.1, + any.amazonka-health ==1.6.1, + any.amazonka-iam ==1.6.1, + any.amazonka-importexport ==1.6.1, + any.amazonka-inspector ==1.6.1, + any.amazonka-iot ==1.6.1, + any.amazonka-iot-dataplane ==1.6.1, + any.amazonka-kinesis ==1.6.1, + any.amazonka-kinesis-analytics ==1.6.1, + any.amazonka-kinesis-firehose ==1.6.1, + any.amazonka-kms ==1.6.1, + any.amazonka-lambda ==1.6.1, + any.amazonka-lightsail ==1.6.1, + any.amazonka-marketplace-analytics ==1.6.1, + any.amazonka-marketplace-metering ==1.6.1, + any.amazonka-ml ==1.6.1, + any.amazonka-opsworks ==1.6.1, + any.amazonka-opsworks-cm ==1.6.1, + any.amazonka-pinpoint ==1.6.1, + any.amazonka-polly ==1.6.1, + any.amazonka-rds ==1.6.1, + any.amazonka-redshift ==1.6.1, + any.amazonka-rekognition ==1.6.1, + any.amazonka-route53 ==1.6.1, + any.amazonka-route53-domains ==1.6.1, + any.amazonka-sdb ==1.6.1, + any.amazonka-servicecatalog ==1.6.1, + any.amazonka-shield ==1.6.1, + any.amazonka-sms ==1.6.1, + any.amazonka-snowball ==1.6.1, + 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, + any.amazonka-waf ==1.6.1, + any.amazonka-workspaces ==1.6.1, + any.amazonka-xray ==1.6.1, + any.amqp ==0.20.0, + any.amqp-utils ==0.4.4.1, + any.annotated-wl-pprint ==0.7.0, + any.ansi-terminal ==0.10.3, + any.ansi-wl-pprint ==0.6.9, + any.antiope-core ==7.5.1, + any.antiope-dynamodb ==7.5.1, + any.antiope-messages ==7.5.1, + any.antiope-s3 ==7.5.1, + any.antiope-sns ==7.5.1, + any.antiope-sqs ==7.5.1, + any.apecs ==0.9.2, + any.apecs-gloss ==0.2.4, + any.apecs-physics ==0.4.4, + any.api-field-json-th ==0.1.0.2, + any.app-settings ==0.2.0.12, + any.appar ==0.1.8, + any.appendmap ==0.1.5, + any.apportionment ==0.0.0.3, + any.approximate ==0.3.2, + any.arbor-lru-cache ==0.1.1.1, + any.arithmoi ==0.10.0.0, + any.array-memoize ==0.6.0, + any.arrow-extras ==0.1.0.1, + any.ascii ==1.0.0.2, + any.ascii-case ==1.0.0.2, + any.ascii-char ==1.0.0.2, + any.ascii-group ==1.0.0.2, + any.ascii-predicates ==1.0.0.2, + any.ascii-progress ==0.3.3.0, + any.ascii-superset ==1.0.0.2, + any.ascii-th ==1.0.0.2, + any.asciidiagram ==1.3.3.3, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assert-failure ==0.1.2.5, + any.assoc ==1.0.2, + any.astro ==0.4.2.1, + any.async ==2.2.2, + any.async-extra ==0.2.0.0, + any.async-refresh ==0.3.0.0, + any.async-refresh-tokens ==0.4.0.0, + any.async-timer ==0.2.0.0, + any.atom-basic ==0.2.5, + any.atomic-primops ==0.8.3, + any.atomic-write ==0.2.0.7, + any.attoparsec ==0.13.2.4, + any.attoparsec-base64 ==0.0.0, + any.attoparsec-binary ==0.2, + any.attoparsec-expr ==0.1.1.2, + any.attoparsec-iso8601 ==1.0.1.0, + any.attoparsec-path ==0.0.0.1, + any.audacity ==0.0.2, + any.aur ==7.0.4, + any.aura ==3.1.9, + any.authenticate ==1.3.5, + any.authenticate-oauth ==1.6.0.1, + any.auto ==0.4.3.1, + any.auto-update ==0.1.6, + any.autoexporter ==1.1.18, + any.avers ==0.0.17.1, + any.avro ==0.5.2.0, + any.aws-cloudfront-signed-cookies ==0.2.0.6, + any.bank-holidays-england ==0.2.0.5, + any.base-compat ==0.11.1, + any.base-compat-batteries ==0.11.1, + any.base-noprelude ==4.13.0.0, + any.base-orphans ==0.8.2, + any.base-prelude ==1.3, + any.base-unicode-symbols ==0.2.4.2, + any.base16 ==0.2.1.0, + any.base16-bytestring ==0.1.1.7, + any.base16-lens ==0.1.2.0, + any.base32 ==0.1.1.2, + any.base32-lens ==0.1.0.0, + any.base32string ==0.9.1, + any.base58-bytestring ==0.1.0, + any.base58string ==0.10.0, + any.base64 ==0.4.2.2, + any.base64-bytestring ==1.0.0.3, + any.base64-bytestring-type ==1.0.1, + any.base64-lens ==0.3.0, + any.base64-string ==0.2, + any.basement ==0.0.11, + any.basic-prelude ==0.7.0, + any.bazel-runfiles ==0.12, + any.bbdb ==0.8, + any.bcrypt ==0.0.11, + any.bech32 ==1.0.2, + any.bech32-th ==1.0.2, + any.bench ==1.0.12, + any.benchpress ==0.2.2.14, + any.between ==0.11.0.0, + any.bibtex ==0.1.0.6, + any.bifunctors ==5.5.7, + any.bimap ==0.4.0, + any.bimap-server ==0.1.0.1, + any.bimaps ==0.1.0.2, + any.bin ==0.1, + any.binary-conduit ==1.3.1, + any.binary-ext ==2.0.4, + any.binary-ieee754 ==0.1.0.0, + any.binary-list ==1.1.1.2, + any.binary-orphans ==1.0.1, + any.binary-parser ==0.5.6, + any.binary-parsers ==0.2.4.0, + any.binary-search ==1.0.0.3, + any.binary-shared ==0.8.3, + any.binary-tagged ==0.3, + any.bindings-DSL ==1.0.25, + any.bindings-GLFW ==3.3.2.0, + any.bindings-libzip ==1.0.1, + any.bindings-uname ==0.1, + any.bins ==0.1.2.0, + any.bitarray ==0.0.1.1, + any.bits ==0.5.2, + any.bits-extra ==0.0.2.0, + any.bitset-word8 ==0.1.1.2, + any.bitvec ==1.0.3.0, + any.blake2 ==0.3.0, + any.blanks ==0.3.0, + any.blas-carray ==0.1.0.1, + any.blas-comfort-array ==0.0.0.2, + any.blas-ffi ==0.1, + any.blaze-bootstrap ==0.1.0.1, + any.blaze-builder ==0.4.1.0, + any.blaze-html ==0.9.1.2, + any.blaze-markup ==0.8.2.7, + any.blaze-svg ==0.3.6.1, + any.blaze-textual ==0.2.1.0, + any.bmp ==1.2.6.3, + any.boltzmann-samplers ==0.1.1.0, + any.boolean-like ==0.1.1.0, + any.boolean-normal-forms ==0.0.1.1, + any.boolsimplifier ==0.1.8, + any.boots ==0.2.0.1, + any.bordacount ==0.1.0.0, + any.boring ==0.1.3, + any.both ==0.1.1.1, + any.bound ==2.0.1, + any.bounded-queue ==1.0.0, + any.boundingboxes ==0.2.3, + any.bower-json ==1.0.0.1, + any.boxes ==0.1.5, + brick +demos, + any.brick ==0.52.1, + any.brittany ==0.12.1.1, + any.broadcast-chan ==0.2.1.1, + any.bsb-http-chunked ==0.0.0.4, + bson -_old-network, + any.bson ==0.4.0.1, + any.btrfs ==0.2.0.0, + any.buffer-builder ==0.2.4.7, + any.buffer-pipe ==0.0, + any.bugsnag-hs ==0.1.0.3, + any.butcher ==1.3.3.2, + any.bv ==0.5, + any.bv-little ==1.1.1, + any.byte-count-reader ==0.10.1.1, + any.byte-order ==0.1.2.0, + any.byteable ==0.1.1, + any.bytedump ==1.0, + any.byteorder ==1.0.4, + any.bytes ==0.17, + any.byteset ==0.1.1.0, + any.bytestring-builder ==0.10.8.2.0, + any.bytestring-conversion ==0.3.1, + any.bytestring-lexing ==0.5.0.2, + any.bytestring-mmap ==0.2.2, + any.bytestring-strict-builder ==0.4.5.3, + any.bytestring-to-vector ==0.3.0.1, + any.bytestring-tree-builder ==0.2.7.3, + any.bz2 ==1.0.0.1, + any.bzlib-conduit ==0.3.0.2, + any.c2hs ==0.28.6, + any.ca-province-codes ==1.0.0.0, + any.cabal-appimage ==0.3.0.0, + any.cabal-debian ==5.0.3, + any.cabal-doctest ==1.0.8, + cabal-rpm -old-locale, + any.cabal-rpm ==2.0.6, + any.cabal2nix ==2.15.1, + any.cabal2spec ==2.5, + any.cache ==0.1.3.0, + any.cacophony ==0.10.1, + any.calendar-recycling ==0.0.0.1, + any.call-stack ==0.2.0, + any.can-i-haz ==0.3.1.0, + any.cardano-coin-selection ==1.0.1, + any.carray ==0.1.6.8, + any.casa-client ==0.0.1, + any.casa-types ==0.0.1, + any.case-insensitive ==1.2.1.0, + any.cased ==0.1.0.0, + any.cases ==0.1.4, + any.casing ==0.1.4.1, + cassava -bytestring--lt-0_10_4, + any.cassava ==0.5.2.0, + any.cassava-conduit ==0.5.1, + any.cassava-megaparsec ==2.0.2, + any.cast ==0.1.0.2, + any.category ==0.2.5.0, + any.cayley-client ==0.4.13, + any.cborg ==0.2.4.0, + any.cborg-json ==0.2.2.0, + any.cereal ==0.5.8.1, + any.cereal-conduit ==0.8.0, + any.cereal-text ==0.1.0.2, + any.cereal-vector ==0.2.0.1, + any.cfenv ==0.1.0.0, + any.chan ==0.0.4.1, + any.character-cases ==0.1.0.4, + any.charset ==0.3.7.1, + any.charsetdetect-ae ==1.1.0.4, + any.chaselev-deque ==0.5.0.5, + any.cheapskate ==0.1.1.2, + any.cheapskate-highlight ==0.1.0.0, + any.cheapskate-lucid ==0.1.0.0, + any.checkers ==0.5.6, + any.checksum ==0.0, + any.chimera ==0.3.1.0, + any.chiphunk ==0.1.2.1, + any.choice ==0.2.2, + any.chronologique ==0.3.1.3, + any.chronos ==1.1.1, + any.chronos-bench ==0.2.0.2, + any.chunked-data ==0.3.1, + any.cipher-aes ==0.2.11, + any.cipher-camellia ==0.0.2, + any.cipher-des ==0.0.6, + any.cipher-rc4 ==0.1.4, + any.circle-packing ==0.1.0.6, + any.clash-ghc ==1.2.4, + any.clash-lib ==1.2.4, + any.clash-prelude ==1.2.4, + any.classy-prelude ==1.5.0, + any.classy-prelude-conduit ==1.5.0, + any.classy-prelude-yesod ==1.5.0, + any.clay ==0.13.3, + any.clientsession ==0.9.1.2, + any.climb ==0.3.3, + any.clock ==0.8, + any.clock-extras ==0.1.0.2, + any.clumpiness ==0.17.0.2, + any.cmark ==0.6, + any.cmark-gfm ==0.2.1, + any.cmark-lucid ==0.1.0.0, + any.cmdargs ==0.10.20, + any.co-log ==0.4.0.1, + any.co-log-concurrent ==0.5.0.0, + any.co-log-core ==0.2.1.1, + any.co-log-polysemy ==0.0.1.2, + any.code-page ==0.2, + any.codec-beam ==0.2.0, + any.codec-rpm ==0.2.2, + any.coercible-utils ==0.1.0, + any.colorful-monoids ==0.2.1.3, + any.colorize-haskell ==1.0.1, + any.colour ==2.3.5, + any.colourista ==0.1.0.0, + any.combinatorial ==0.1.0.1, + any.comfort-array ==0.4, + any.comfort-graph ==0.0.3.1, + any.commutative ==0.0.2, + any.comonad ==5.0.6, + any.compactmap ==0.1.4.2.1, + any.compendium-client ==0.2.1.1, + any.compensated ==0.8.1, + any.compiler-warnings ==0.1.0, + any.composable-associations ==0.1.0.0, + any.composable-associations-aeson ==0.1.0.0, + any.composition ==1.0.2.1, + any.composition-extra ==2.0.0, + any.concise ==0.1.0.1, + any.concurrency ==1.11.0.0, + any.concurrent-extra ==0.7.0.12, + any.concurrent-output ==1.10.12, + any.concurrent-split ==0.0.1.1, + any.concurrent-supply ==0.1.8, + any.cond ==0.4.1.1, + any.conduit ==1.3.2.1, + any.conduit-algorithms ==0.0.11.0, + any.conduit-combinators ==1.3.0, + any.conduit-concurrent-map ==0.1.1, + any.conduit-extra ==1.3.5, + any.conduit-parse ==0.2.1.0, + any.conduit-zstd ==0.0.2.0, + any.conferer ==0.4.1.1, + any.conferer-hspec ==0.4.0.1, + any.conferer-source-json ==0.4.0.1, + any.conferer-warp ==0.4.0.1, + any.config-ini ==0.2.4.0, + any.configurator ==0.3.0.0, + any.configurator-export ==0.1.0.1, + any.configurator-pg ==0.2.4, + any.connection ==0.3.1, + any.connection-pool ==0.2.2, + any.console-style ==0.0.2.1, + any.constraint ==0.1.4.0, + any.constraint-tuples ==0.1.2, + any.constraints ==0.12, + any.contravariant ==1.5.2, + any.contravariant-extras ==0.3.5.2, + any.control-bool ==0.2.1, + any.control-monad-free ==0.6.2, + any.control-monad-omega ==0.3.2, + any.convertible ==1.1.1.0, + any.cookie ==0.4.5, + any.core-data ==0.2.1.8, + any.core-program ==0.2.4.5, + any.core-text ==0.2.3.6, + any.countable ==1.0, + any.cpio-conduit ==0.7.0, + any.cpphs ==1.20.9.1, + any.cprng-aes ==0.6.1, + any.cpu ==0.1.2, + any.cpuinfo ==0.1.0.1, + any.cql ==4.0.2, + any.cql-io ==1.1.1, + any.cql-io-tinylog ==0.1.0, + any.crackNum ==2.3, + any.crc32c ==0.0.0, + any.credential-store ==0.1.2, + any.criterion ==1.5.6.2, + any.criterion-measurement ==0.1.2.0, + any.cron ==0.7.0, + any.crypt-sha512 ==0, + any.crypto-api ==0.13.3, + any.crypto-cipher-types ==0.0.9, + any.crypto-enigma ==0.1.1.6, + any.crypto-numbers ==0.2.7, + any.crypto-pubkey ==0.2.8, + any.crypto-pubkey-types ==0.4.3, + any.crypto-random ==0.0.9, + any.crypto-random-api ==0.2.0, + any.cryptocompare ==0.1.1, + any.cryptohash ==0.11.9, + any.cryptohash-cryptoapi ==0.1.4, + any.cryptohash-md5 ==0.11.100.1, + any.cryptohash-sha1 ==0.11.100.1, + any.cryptohash-sha256 ==0.11.101.0, + any.cryptohash-sha512 ==0.11.100.1, + any.cryptonite ==0.28, + any.cryptonite-conduit ==0.2.2, + any.cryptonite-openssl ==0.7, + any.csp ==1.4.0, + any.css-syntax ==0.1.0.0, + any.css-text ==0.1.3.0, + any.csv ==0.1.2, + any.csv-conduit ==0.7.1.0, + any.ctrie ==0.2, + any.cubicbezier ==0.6.0.6, + any.cubicspline ==0.1.2, + any.cuckoo-filter ==0.2.0.2, + any.cue-sheet ==2.0.1, + curl +new-base, + any.curl ==1.3.8, + any.currencies ==0.2.0.0, + any.currency ==0.2.0.0, + any.currency-codes ==3.0.0.1, + any.cursor ==0.3.0.0, + any.cursor-brick ==0.1.0.0, + any.cursor-fuzzy-time ==0.0.0.0, + any.cursor-gen ==0.3.0.0, + any.cutter ==0.0, + any.cyclotomic ==1.1.1, + any.czipwith ==1.0.1.3, + any.d10 ==0.2.1.6, + any.data-accessor ==0.2.3, + any.data-accessor-mtl ==0.2.0.4, + any.data-accessor-transformers ==0.2.1.7, + any.data-ascii ==1.0.0.2, + any.data-binary-ieee754 ==0.4.4, + any.data-bword ==0.1.0.1, + any.data-checked ==0.3, + any.data-clist ==0.1.2.3, + any.data-compat ==0.1.0.2, + any.data-default ==0.7.1.1, + any.data-default-class ==0.1.2.0, + any.data-default-instances-containers ==0.0.1, + any.data-default-instances-dlist ==0.0.1, + any.data-default-instances-old-locale ==0.0.1, + any.data-diverse ==4.7.0.0, + any.data-dword ==0.3.2, + any.data-endian ==0.1.1, + any.data-fix ==0.2.1, + any.data-forest ==0.1.0.8, + any.data-has ==0.3.0.0, + any.data-interval ==2.0.1, + any.data-inttrie ==0.1.4, + any.data-lens-light ==0.1.2.2, + any.data-memocombinators ==0.5.1, + any.data-msgpack ==0.0.13, + any.data-msgpack-types ==0.0.3, + any.data-or ==1.0.0.5, + any.data-ordlist ==0.4.7.0, + any.data-ref ==0.0.2, + any.data-reify ==0.6.1, + any.data-serializer ==0.3.4.1, + any.data-textual ==0.3.0.3, + any.data-timeout ==0.3.1, + any.data-tree-print ==0.1.0.2, + any.datadog ==0.2.5.0, + any.dataurl ==0.1.0.0, + any.dbus ==1.2.16, + any.dbus-hslogger ==0.1.0.1, + any.debian ==4.0.2, + any.debian-build ==0.10.2.0, + any.debug-trace-var ==0.2.0, + any.dec ==0.0.3, + any.declarative ==0.5.3, + any.deepseq-generics ==0.2.0.0, + any.deepseq-instances ==0.1.0.1, + any.deferred-folds ==0.9.10.1, + any.dejafu ==2.3.0.1, + any.dense-linear-algebra ==0.1.0.0, + any.depq ==0.4.1.0, + any.deque ==0.4.3, + any.deriveJsonNoPrefix ==0.1.0.1, + any.deriving-aeson ==0.2.5, + any.deriving-compat ==0.5.9, + any.derulo ==1.0.9, + any.detour-via-sci ==1.0.0, + any.dhall ==1.32.0, + any.dhall-bash ==1.0.30, + any.dhall-json ==1.6.4, + any.dhall-lsp-server ==1.0.8, + any.dhall-yaml ==1.1.0, + any.di-core ==1.0.4, + any.di-monad ==1.3.1, + any.diagrams ==1.4, + any.diagrams-contrib ==1.4.4, + any.diagrams-core ==1.4.2, + any.diagrams-lib ==1.4.3, + any.diagrams-postscript ==1.5, + any.diagrams-rasterific ==1.4.2, + any.diagrams-solve ==0.1.2, + any.diagrams-svg ==1.4.3, + any.dialogflow-fulfillment ==0.1.1.3, + any.dictionary-sharing ==0.1.0.0, + any.digest ==0.0.1.2, + any.digits ==0.3.1, + any.dimensional ==1.3, + any.directory-tree ==0.12.1, + any.discount ==0.1.1, + any.disk-free-space ==0.1.0.1, + any.distributed-closure ==0.4.2.0, + any.distribution-nixpkgs ==1.3.1, + any.distribution-opensuse ==1.1.1, + any.distributive ==0.6.2, + any.dl-fedora ==0.7.5, + any.dlist ==0.8.0.8, + any.dlist-instances ==0.1.1.1, + any.dlist-nonempty ==0.1.1, + any.dns ==4.0.1, + any.do-list ==1.0.1, + any.do-notation ==0.1.0.2, + any.dockerfile ==0.2.0, + any.doclayout ==0.3, + any.doctemplates ==0.8.2, + any.doctest ==0.16.3, + any.doctest-discover ==0.2.0.0, + any.doctest-driver-gen ==0.3.0.2, + any.doldol ==0.4.1.2, + any.dotenv ==0.8.0.7, + any.dotgen ==0.4.3, + any.dotnet-timespan ==0.0.1.0, + any.double-conversion ==2.0.2.0, + any.download ==0.3.2.7, + any.drinkery ==0.4, + any.dsp ==0.2.5.1, + any.dual ==0.1.1.1, + any.dual-tree ==0.2.2.1, + any.dublincore-xml-conduit ==0.1.0.2, + any.dunai ==0.7.0, + any.duration ==0.1.0.0, + any.dvorak ==0.1.0.0, + any.dynamic-state ==0.3.1, + any.dyre ==0.8.12, + any.eap ==0.9.0.2, + any.earcut ==0.1.0.4, + any.easy-file ==0.2.2, + any.echo ==0.1.3, + any.ecstasy ==0.2.1.0, + any.ed25519 ==0.0.5.0, + any.edit-distance ==0.2.2.1, + any.edit-distance-vector ==1.0.0.4, + any.editor-open ==0.6.0.0, + any.egison ==4.0.3, + any.egison-pattern-src ==0.2.1.0, + any.egison-pattern-src-th-mode ==0.2.1.1, + any.either ==5.0.1.1, + any.either-both ==0.1.1.1, + any.either-unwrap ==1.1, + any.ekg ==0.4.0.15, + any.ekg-core ==0.1.1.7, + any.ekg-json ==0.1.0.6, + any.ekg-statsd ==0.2.5.0, + any.elerea ==2.9.0, + any.elf ==0.30, + any.eliminators ==0.6, + any.elm-bridge ==0.6.1, + any.elm-core-sources ==1.0.0, + any.elm-export ==0.6.0.1, + any.elm2nix ==0.2, + any.emacs-module ==0.1.1, + any.email-validate ==2.3.2.13, + any.emojis ==0.1, + any.enclosed-exceptions ==1.0.3, + any.entropy ==0.4.1.6, + any.enum-subset-generate ==0.1.0.0, + any.enummapset ==0.6.0.3, + any.enumset ==0.0.5, + any.envelope ==0.2.2.0, + any.envy ==2.1.0.0, + any.epub-metadata ==4.5, + any.eq ==4.2, + any.equal-files ==0.0.5.3, + any.equational-reasoning ==0.6.0.3, + any.erf ==2.0.0.0, + any.errors ==2.3.0, + any.errors-ext ==0.4.2, + any.ersatz ==0.4.8, + any.esqueleto ==3.3.3.3, + any.essence-of-live-coding ==0.1.0.3, + any.essence-of-live-coding-gloss ==0.1.0.3, + any.essence-of-live-coding-pulse ==0.1.0.3, + any.essence-of-live-coding-quickcheck ==0.1.0.3, + any.etc ==0.4.1.0, + any.event-list ==0.1.2, + any.eventful-core ==0.2.0, + any.eventful-test-helpers ==0.2.0, + any.eventstore ==1.4.1, + any.every ==0.0.1, + any.exact-combinatorics ==0.2.0.9, + any.exact-pi ==0.5.0.1, + any.exception-hierarchy ==0.1.0.3, + any.exception-mtl ==0.4.0.1, + any.exception-transformers ==0.4.0.9, + any.exceptions ==0.10.4, + any.executable-path ==0.0.3.1, + any.exit-codes ==1.0.0, + any.exomizer ==1.0.0, + any.exp-pairs ==0.2.0.0, + any.expiring-cache-map ==0.0.6.1, + any.explicit-exception ==0.1.10, + any.express ==0.1.3, + any.extended-reals ==0.2.4.0, + any.extensible-effects ==5.0.0.1, + any.extensible-exceptions ==0.1.1.4, + any.extra ==1.7.8, + any.extractable-singleton ==0.0.1, + any.extrapolate ==0.4.2, + any.fail ==4.9.0.0, + any.failable ==1.2.4.0, + any.fakedata ==0.6.1, + any.farmhash ==0.1.0.5, + any.fast-digits ==0.3.0.0, + any.fast-logger ==3.0.1, + any.fast-math ==1.0.2, + any.fb ==2.1.1, + any.feature-flags ==0.1.0.1, + any.fedora-dists ==1.1.2, + any.fedora-haskell-tools ==0.9, + any.feed ==1.3.0.1, + any.fft ==0.1.8.6, + any.fgl ==5.7.0.3, + any.file-embed ==0.0.11.2, + any.file-embed-lzma ==0, + any.file-modules ==0.1.2.4, + any.file-path-th ==0.1.0.0, + any.filecache ==0.4.1, + any.filelock ==0.1.1.5, + any.filemanip ==0.3.6.3, + any.filepattern ==0.1.2, + any.fileplow ==0.1.0.0, + any.filtrable ==0.1.4.0, + any.fin ==0.1.1, + any.fingertree ==0.1.4.2, + any.finite-typelits ==0.1.4.2, + any.first-class-families ==0.8.0.0, + any.first-class-patterns ==0.3.2.5, + any.fitspec ==0.4.8, + any.fixed ==0.3, + any.fixed-length ==0.2.2, + any.fixed-vector ==1.2.0.0, + any.fixed-vector-hetero ==0.6.0.0, + any.flac ==0.2.0, + any.flac-picture ==0.1.2, + any.flags-applicative ==0.1.0.2, + any.flat ==0.4.4, + any.flat-mcmc ==1.5.1, + any.floatshow ==0.2.4, + any.flow ==1.0.21, + any.flush-queue ==1.0.0, + any.fmlist ==0.9.4, + any.fmt ==0.6.1.2, + any.fn ==0.3.0.2, + any.focus ==1.0.1.3, + any.focuslist ==0.1.0.2, + any.fold-debounce ==0.2.0.9, + any.fold-debounce-conduit ==0.2.0.5, + any.foldable1 ==0.1.0.0, + any.foldl ==1.4.6, + any.folds ==0.7.5, + any.follow-file ==0.0.3, + any.force-layout ==0.4.0.6, + any.foreign-store ==0.2, + any.forkable-monad ==0.2.0.3, + any.forma ==1.1.3, + any.format-numbers ==0.1.0.1, + any.formatting ==6.3.7, + any.foundation ==0.0.25, + any.free ==5.1.3, + any.free-categories ==0.2.0.0, + any.free-vl ==0.1.4, + any.freenect ==1.2.1, + any.freer-simple ==1.2.1.1, + any.freetype2 ==0.2.0, + any.friendly-time ==0.4.1, + any.from-sum ==0.2.3.0, + any.frontmatter ==0.1.0.2, + any.fsnotify ==0.3.0.1, + any.fsnotify-conduit ==0.1.1.1, + any.ftp-client ==0.5.1.4, + any.ftp-client-conduit ==0.5.0.5, + any.funcmp ==1.9, + any.function-builder ==0.3.0.1, + functor-classes-compat +containers, + any.functor-classes-compat ==1, + any.fused-effects ==1.0.2.2, + any.fusion-plugin ==0.2.1, + any.fusion-plugin-types ==0.1.0, + any.fuzzcheck ==0.1.1, + any.fuzzy ==0.1.0.0, + any.fuzzy-dates ==0.1.1.2, + any.fuzzy-time ==0.1.0.0, + any.fuzzyset ==0.2.0, + any.gauge ==0.2.5, + any.gd ==3000.7.3, + any.gdp ==0.0.3.0, + any.general-games ==1.1.1, + any.generic-arbitrary ==0.1.0, + any.generic-constraints ==1.1.1.1, + any.generic-data ==0.8.3.0, + any.generic-deriving ==1.13.1, + any.generic-lens ==2.0.0.0, + any.generic-lens-core ==2.0.0.0, + any.generic-monoid ==0.1.0.1, + any.generic-optics ==2.0.0.0, + any.generic-random ==1.3.0.1, + any.generics-sop ==0.5.1.0, + any.generics-sop-lens ==0.2.0.1, + any.genvalidity ==0.11.0.0, + any.genvalidity-aeson ==0.3.0.0, + any.genvalidity-bytestring ==0.6.0.0, + any.genvalidity-containers ==0.8.0.2, + any.genvalidity-criterion ==0.2.0.0, + any.genvalidity-hspec ==0.7.0.4, + any.genvalidity-hspec-aeson ==0.3.1.1, + any.genvalidity-hspec-binary ==0.2.0.4, + any.genvalidity-hspec-cereal ==0.2.0.4, + any.genvalidity-hspec-hashable ==0.2.0.5, + any.genvalidity-hspec-optics ==0.1.1.2, + any.genvalidity-hspec-persistent ==0.0.0.1, + any.genvalidity-mergeful ==0.2.0.0, + any.genvalidity-mergeless ==0.2.0.0, + any.genvalidity-path ==0.3.0.4, + any.genvalidity-property ==0.5.0.1, + any.genvalidity-scientific ==0.2.1.1, + any.genvalidity-text ==0.7.0.2, + any.genvalidity-time ==0.3.0.0, + any.genvalidity-typed-uuid ==0.0.0.2, + any.genvalidity-unordered-containers ==0.3.0.1, + any.genvalidity-uuid ==0.1.0.4, + any.genvalidity-vector ==0.3.0.1, + any.geoip2 ==0.4.0.1, + any.geojson ==4.0.2, + any.getopt-generics ==0.13.0.4, + any.ghc-byteorder ==4.11.0.0.10, + any.ghc-check ==0.5.0.1, + any.ghc-compact ==0.1.0.0, + any.ghc-core ==0.5.6, + any.ghc-events ==0.13.0, + any.ghc-exactprint ==0.6.2, + any.ghc-lib ==8.10.2.20200808, + any.ghc-lib-parser ==8.10.1.20200412, + any.ghc-lib-parser-ex ==8.10.0.16, + any.ghc-parser ==0.2.2.0, + any.ghc-paths ==0.1.0.12, + any.ghc-prof ==1.4.1.7, + any.ghc-source-gen ==0.4.0.0, + any.ghc-syntax-highlighter ==0.0.6.0, + any.ghc-tcplugins-extra ==0.4, + any.ghc-typelits-extra ==0.4, + any.ghc-typelits-knownnat ==0.7.3, + any.ghc-typelits-natnormalise ==0.7.2, + any.ghc-typelits-presburger ==0.3.0.1, + any.ghci-hexcalc ==0.1.1.0, + any.ghcid ==0.8.7, + any.ghcjs-codemirror ==0.0.0.2, + any.ghost-buster ==0.1.1.0, + any.gi-atk ==2.0.21, + any.gi-cairo ==1.0.23, + any.gi-cairo-connector ==0.0.1, + any.gi-cairo-render ==0.0.1, + any.gi-dbusmenu ==0.4.7, + any.gi-dbusmenugtk3 ==0.4.8, + any.gi-gdk ==3.0.22, + any.gi-gdkpixbuf ==2.0.23, + any.gi-gdkx11 ==3.0.9, + any.gi-gio ==2.0.26, + any.gi-glib ==2.0.23, + any.gi-gobject ==2.0.22, + any.gi-graphene ==1.0.1, + any.gi-gtk ==3.0.33, + any.gi-gtk-hs ==0.3.8.1, + any.gi-pango ==1.0.22, + any.gi-xlib ==2.0.8, + any.ginger ==0.10.1.0, + any.gingersnap ==0.3.1.0, + any.giphy-api ==0.7.0.0, + any.githash ==0.1.4.0, + any.github-rest ==1.0.3, + any.github-types ==0.2.1, + any.gitlab-haskell ==0.1.8, + any.gitrev ==1.3.1, + any.gl ==0.9, + any.glabrous ==2.0.2, + any.gloss ==1.13.1.2, + any.gloss-rendering ==1.13.1.1, + any.gluturtle ==0.0.58.1, + any.gnuplot ==0.5.6.1, + any.google-isbn ==1.0.3, + any.gothic ==0.1.5, + any.gpolyline ==0.1.0.1, + any.graph-core ==0.3.0.0, + any.graph-wrapper ==0.2.6.0, + any.graphite ==0.10.0.1, + any.graphs ==0.7.1, + any.graphviz ==2999.20.1.0, + any.gravatar ==0.8.0, + greskell -hint-test, + any.greskell ==1.1.0.3, + any.greskell-core ==0.1.3.5, + any.greskell-websocket ==0.1.2.4, + any.groom ==0.1.2.1, + any.group-by-date ==0.1.0.3, + any.groups ==0.4.1.0, + any.gtk-sni-tray ==0.1.6.0, + any.gtk-strut ==0.1.3.0, + any.guarded-allocation ==0.0.1, + any.hOpenPGP ==2.9.4, + any.hackage-db ==2.1.0, + any.hackage-security ==0.6.0.1, + any.haddock-library ==1.8.0, + any.hadolint ==1.18.0, + any.hadoop-streaming ==0.2.0.3, + any.hakyll ==4.13.4.0, + any.half ==0.3, + any.hall-symbols ==0.1.0.6, + any.hamtsolo ==1.0.3, + any.hapistrano ==0.4.1.2, + any.happstack-server ==7.6.1, + any.happy ==1.19.12, + any.hasbolt ==0.1.4.3, + any.hashable ==1.3.0.0, + any.hashable-time ==0.2.0.2, + any.hashids ==1.0.2.4, + any.hashmap ==1.3.3, + any.hashtables ==1.2.4.1, + any.haskeline ==0.7.5.0, + any.haskell-gi ==0.23.1, + any.haskell-gi-base ==0.23.0, + any.haskell-gi-overloading ==1.0, + any.haskell-igraph ==0.8.0, + any.haskell-import-graph ==1.0.4, + any.haskell-lexer ==1.1, + any.haskell-lsp ==0.22.0.0, + any.haskell-lsp-types ==0.22.0.0, + any.haskell-names ==0.9.9, + any.haskell-src ==1.0.3.1, + any.haskell-src-exts ==1.23.1, + any.haskell-src-exts-util ==0.2.5, + any.haskell-src-meta ==0.8.5, + any.haskey-btree ==0.3.0.1, + any.haskoin-core ==0.13.4, + any.haskoin-node ==0.13.0, + any.hasql ==1.4.3, + any.hasql-optparse-applicative ==0.3.0.6, + any.hasql-pool ==0.5.2, + any.hasql-transaction ==1.0.0.1, + any.hasty-hamiltonian ==1.3.3, + any.haxr ==3000.11.4.1, + any.hdaemonize ==0.5.6, + any.headroom ==0.2.1.0, + any.heap ==1.0.4, + any.heaps ==0.3.6.1, + any.hebrew-time ==0.1.2, + any.hedgehog ==1.0.3, + any.hedgehog-corpus ==0.2.0, + any.hedgehog-fakedata ==0.0.1.3, + any.hedgehog-fn ==1.0, + any.hedgehog-quickcheck ==0.1.1, + any.hedis ==0.12.14, + any.here ==1.2.13, + any.heredoc ==0.2.0.0, + any.heterocephalus ==1.0.5.3, + any.hex ==0.2.0, + any.hexml ==0.3.4, + any.hexml-lens ==0.2.1, + any.hexpat ==0.20.13, + any.hexstring ==0.11.1, + any.hformat ==0.3.3.1, + any.hfsevents ==0.1.6, + any.hi-file-parser ==0.1.0.0, + any.hidapi ==0.1.5, + any.hie-bios ==0.5.1, + any.higher-leveldb ==0.5.0.2, + any.highlighting-kate ==0.6.4, + any.hinfo ==0.0.3.0, + any.hinotify ==0.4, + any.hint ==0.9.0.3, + any.hjsmin ==0.2.0.4, + any.hkd-default ==1.1.0.0, + any.hkgr ==0.2.6.1, + any.hledger ==1.18.1, + any.hledger-iadd ==1.3.12, + any.hledger-lib ==1.18.1, + any.hledger-stockquotes ==0.1.0.0, + any.hledger-ui ==1.18.1, + any.hledger-web ==1.18.1, + any.hlibcpuid ==0.2.0, + any.hlibgit2 ==0.18.0.16, + any.hlint ==3.1.6, + any.hmatrix ==0.20.0.0, + any.hmatrix-gsl ==0.19.0.1, + any.hmatrix-gsl-stats ==0.4.1.8, + any.hmatrix-morpheus ==0.1.1.2, + any.hmatrix-vector-sized ==0.1.3.0, + any.hmpfr ==0.4.4, + any.hnock ==0.4.0, + any.hoauth2 ==1.14.0, + any.hopenpgp-tools ==0.23.1, + any.hopenssl ==2.2.4, + any.hopfli ==0.2.2.1, + any.hosc ==0.17, + any.hostname ==1.0, + any.hostname-validate ==1.0.0, + any.hourglass ==0.2.12, + any.hourglass-orphans ==0.1.0.0, + any.hp2pretty ==0.9, + any.hpack ==0.34.2, + any.hpack-dhall ==0.5.2, + any.hpc-codecov ==0.2.0.0, + any.hpc-lcov ==1.0.1, + any.hreader ==1.1.0, + any.hreader-lens ==0.1.3.0, + any.hruby ==0.3.8, + any.hs-GeoIP ==0.3, + any.hs-bibutils ==6.10.0.0, + any.hs-functors ==0.1.7.1, + any.hs-php-session ==0.0.9.3, + any.hsc2hs ==0.68.7, + any.hscolour ==1.24.4, + any.hsdns ==1.8, + any.hsebaysdk ==0.4.1.0, + any.hsemail ==2.2.0, + any.hset ==2.2.0, + any.hsini ==0.5.1.2, + any.hsinstall ==2.6, + any.hslogger ==1.3.1.0, + any.hslua ==1.0.3.2, + any.hslua-aeson ==1.0.3, + any.hslua-module-doclayout ==0.1.0, + any.hslua-module-system ==0.2.2, + any.hslua-module-text ==0.2.1, + any.hsp ==0.10.0, + any.hspec ==2.7.4, + any.hspec-attoparsec ==0.1.0.2, + any.hspec-checkers ==0.1.0.2, + any.hspec-contrib ==0.5.1, + any.hspec-core ==2.7.4, + any.hspec-discover ==2.7.4, + any.hspec-expectations ==0.8.2, + any.hspec-expectations-lifted ==0.10.0, + any.hspec-expectations-pretty-diff ==0.7.2.5, + any.hspec-golden ==0.1.0.3, + any.hspec-golden-aeson ==0.7.0.0, + any.hspec-hedgehog ==0.0.1.2, + any.hspec-leancheck ==0.0.4, + any.hspec-megaparsec ==2.1.0, + any.hspec-meta ==2.6.0, + any.hspec-need-env ==0.1.0.5, + any.hspec-parsec ==0, + any.hspec-smallcheck ==0.5.2, + any.hspec-tables ==0.0.1, + any.hspec-wai-json ==0.10.1, + any.hsshellscript ==3.4.5, + any.hsyslog ==5.0.2, + any.htaglib ==1.2.0, + any.html ==1.0.1.2, + any.html-conduit ==1.3.2.1, + any.html-entities ==1.1.4.3, + any.html-entity-map ==0.1.0.0, + any.htoml ==1.0.0.3, + any.http-api-data ==0.4.1.1, + any.http-client-overrides ==0.1.1.0, + any.http-common ==0.8.2.1, + any.http-date ==0.0.8, + any.http-directory ==0.1.8, + any.http-download ==0.2.0.0, + any.http-link-header ==1.0.3.1, + any.http-media ==0.8.0.0, + any.http-reverse-proxy ==0.6.0, + any.http-streams ==0.8.7.2, + any.http-types ==0.12.3, + any.http2-grpc-proto3-wire ==0.1.0.0, + any.http2-grpc-types ==0.5.0.0, + any.httpd-shed ==0.4.1.1, + any.human-readable-duration ==0.2.1.4, + any.hunit-dejafu ==2.0.0.4, + any.hvect ==0.4.0.0, + any.hvega ==0.9.1.0, + any.hw-balancedparens ==0.4.1.0, + any.hw-bits ==0.7.2.1, + any.hw-conduit ==0.2.1.0, + any.hw-conduit-merges ==0.2.1.0, + any.hw-diagnostics ==0.0.1.0, + any.hw-excess ==0.2.3.0, + any.hw-fingertree ==0.1.2.0, + any.hw-fingertree-strict ==0.1.2.0, + any.hw-hedgehog ==0.1.1.0, + any.hw-hspec-hedgehog ==0.1.1.0, + any.hw-int ==0.0.2.0, + any.hw-json-simd ==0.1.1.0, + any.hw-mquery ==0.2.1.0, + any.hw-parser ==0.1.1.0, + any.hw-prim ==0.6.3.0, + any.hw-rankselect-base ==0.3.4.1, + any.hw-streams ==0.0.1.0, + any.hw-string-parse ==0.0.0.4, + any.hweblib ==0.6.3, + hxt +network-uri, + any.hxt ==9.3.1.18, + any.hxt-charproperties ==9.4.0.0, + any.hxt-css ==0.1.0.3, + any.hxt-curl ==9.1.1.1, + any.hxt-expat ==9.1.1, + hxt-http +network-uri, + any.hxt-http ==9.1.5.2, + any.hxt-regex-xmlschema ==9.2.0.3, + any.hxt-tagsoup ==9.1.4, + any.hxt-unicode ==9.0.2.4, + any.hybrid-vectors ==0.2.2, + any.hyperloglog ==0.4.3, + any.hyphenation ==0.8, + any.hyraxAbif ==0.2.3.21, + any.iconv ==0.4.1.3, + any.identicon ==0.2.2, + any.ieee754 ==0.8.0, + any.if ==0.1.0.0, + any.iff ==0.0.6, + any.ihaskell ==0.10.1.2, + any.ihs ==0.1.0.3, + any.ilist ==0.4.0.1, + any.imagesize-conduit ==1.1, + any.immortal ==0.3, + any.immortal-queue ==0.1.0.1, + any.implicit-hie ==0.1.2.5, + any.include-file ==0.1.0.4, + any.incremental-parser ==0.4.0.2, + any.indents ==0.5.0.1, + any.indexed ==0.1.3, + any.indexed-containers ==0.1.0.2, + any.indexed-list-literals ==0.2.1.3, + any.indexed-profunctors ==0.1, + any.infer-license ==0.2.0, + any.inflections ==0.4.0.6, + any.influxdb ==1.7.1.6, + any.ini ==0.4.1, + any.inj ==1.0, + any.inline-c ==0.9.1.0, + any.inline-c-cpp ==0.4.0.2, + any.inliterate ==0.1.0, + any.insert-ordered-containers ==0.2.3.1, + any.inspection-testing ==0.4.2.4, + any.instance-control ==0.1.2.0, + any.int-cast ==0.2.0.0, + any.integer-logarithms ==1.0.3, + any.integer-roots ==1.0, + any.integration ==0.2.1, + any.intern ==0.9.2, + any.interpolate ==0.2.1, + any.interpolatedstring-perl6 ==1.0.2, + any.interpolation ==0.1.1.1, + any.interpolator ==1.0.0, + any.intervals ==0.9.1, + any.intro ==0.7.0.0, + any.intset-imperative ==0.1.0.0, + any.invariant ==0.5.3, + any.invertible ==0.2.0.7, + any.invertible-grammar ==0.1.3, + any.invertible-hxt ==0.1, + any.io-machine ==0.2.0.0, + any.io-manager ==0.1.0.3, + any.io-memoize ==1.1.1.0, + any.io-region ==0.1.1, + any.io-storage ==0.3, + any.io-streams ==1.5.2.0, + any.io-streams-haproxy ==1.0.1.0, + any.ip6addr ==1.0.1, + any.iproute ==1.7.9, + any.ipynb ==0.1.0.1, + any.ipython-kernel ==0.10.2.1, + any.irc ==0.6.1.0, + any.irc-client ==1.1.1.1, + any.irc-conduit ==0.3.0.4, + any.irc-ctcp ==0.1.3.0, + any.isbn ==1.0.0.0, + any.islink ==0.1.0.0, + any.iso3166-country-codes ==0.20140203.8, + any.iso639 ==0.1.0.3, + any.iso8601-time ==0.1.5, + any.it-has ==0.2.0.0, + any.iterable ==3.0, + any.ix-shapable ==0.1.0, + any.ixset-typed ==0.5, + any.jack ==0.7.1.4, + any.jailbreak-cabal ==1.3.5, + any.jira-wiki-markup ==1.1.4, + any.jose ==0.8.3.1, + any.jose-jwt ==0.8.0, + any.js-dgtable ==0.5.2, + any.js-flot ==0.8.3, + any.js-jquery ==3.3.1, + any.json-alt ==1.0.0, + any.json-feed ==1.0.11, + any.json-rpc ==1.0.3, + any.json-rpc-generic ==0.2.1.5, + any.jsonpath ==0.2.0.0, + any.junit-xml ==0.1.0.1, + any.justified-containers ==0.3.0.0, + any.jwt ==0.10.0, + any.kan-extensions ==5.2, + any.kanji ==3.4.1, + any.katip ==0.8.5.0, + any.kawhi ==0.3.0, + any.kazura-queue ==0.1.0.4, + any.kdt ==0.2.4, + any.keycode ==0.2.2, + any.keys ==3.12.3, + any.kind-apply ==0.3.2.0, + any.kind-generics ==0.4.1.0, + any.kind-generics-th ==0.2.2.0, + any.kmeans ==0.1.3, + any.koofr-client ==1.0.0.3, + any.krank ==0.2.2, + any.kubernetes-webhook-haskell ==0.2.0.3, + any.l10n ==0.1.0.1, + any.labels ==0.3.3, + any.lackey ==1.0.13, + any.lame ==0.2.0, + any.language-avro ==0.1.3.1, + any.language-bash ==0.9.2, + any.language-c ==0.8.3, + any.language-c-quote ==0.12.2.1, + any.language-docker ==9.1.1, + any.language-haskell-extract ==0.2.4, + any.language-java ==0.2.9, + any.language-javascript ==0.7.1.0, + any.language-nix ==2.2.0, + any.language-protobuf ==1.0.1, + any.language-puppet ==1.4.6.5, + any.lapack-carray ==0.0.3, + any.lapack-comfort-array ==0.0.0.1, + any.lapack-ffi ==0.0.2, + any.lapack-ffi-tools ==0.1.2.1, + any.largeword ==1.2.5, + any.latex ==0.1.0.4, + any.lattices ==2.0.2, + any.lawful ==0.1.0.0, + any.lazy-csv ==0.5.1, + any.lazyio ==0.1.0.4, + any.lca ==0.3.1, + any.leancheck ==0.9.3, + any.leancheck-instances ==0.0.4, + any.leapseconds-announced ==2017.1.0.1, + any.learn-physics ==0.6.5, + any.lens ==4.18.1, + any.lens-action ==0.2.4, + any.lens-aeson ==1.1, + any.lens-datetime ==0.3, + any.lens-family ==2.0.0, + any.lens-family-core ==2.0.0, + any.lens-family-th ==0.5.1.0, + any.lens-misc ==0.0.2.0, + any.lens-properties ==4.11.1, + any.lens-regex ==0.1.1, + any.lenz ==0.4.2.0, + any.leveldb-haskell ==0.6.5, + any.libffi ==0.1, + any.libgit ==0.3.1, + any.libgraph ==1.14, + any.libmpd ==0.9.1.0, + any.libyaml ==0.1.2, + any.life-sync ==1.1.1.0, + any.lift-generics ==0.1.3, + any.lifted-async ==0.10.1.2, + any.lifted-base ==0.2.3.12, + any.line ==4.0.1, + any.linear ==1.21.1, + any.linenoise ==0.3.2, + any.linux-file-extents ==0.2.0.0, + any.linux-namespaces ==0.1.3.0, + any.list-predicate ==0.1.0.1, + any.list-singleton ==1.0.0.4, + any.list-t ==1.0.4, + any.listsafe ==0.1.0.1, + any.little-logger ==0.1.0, + any.little-rio ==0.1.1, + any.llvm-hs ==9.0.1, + any.llvm-hs-pure ==9.0.0, + any.lmdb ==0.2.5, + any.load-env ==0.2.1.0, + any.loc ==0.1.3.8, + any.loch-th ==0.2.2, + any.lockfree-queue ==0.2.3.1, + any.log-base ==0.8.0.1, + any.log-domain ==0.13, + any.logfloat ==0.13.3.3, + any.logging ==3.0.5, + any.logging-facade ==0.3.0, + any.logging-facade-syslog ==1, + any.logict ==0.7.0.3, + any.loop ==0.3.0, + any.loopbreaker ==0.1.1.1, + any.lrucache ==1.2.0.1, + any.lrucaching ==0.3.3, + any.lsp-test ==0.10.3.0, + any.lucid ==2.9.12, + any.lucid-extras ==0.2.2, + any.lukko ==0.1.1.2, + any.lzma ==0.0.0.3, + any.lzma-conduit ==1.2.1, + any.machines ==0.7, + any.magic ==1.1, + any.main-tester ==0.2.0.1, + any.mainland-pretty ==0.7.0.1, + any.makefile ==1.1.0.0, + any.managed ==1.0.8, + any.markdown ==0.1.17.4, + any.markdown-unlit ==0.5.0, + any.markov-chain ==0.0.3.4, + any.markov-chain-usage-model ==0.0.0, + any.massiv ==0.5.4.0, + any.massiv-io ==0.2.1.0, + any.massiv-test ==0.1.4, + any.math-extras ==0.1.1.0, + any.math-functions ==0.3.4.1, + any.mathexpr ==0.3.0.0, + any.matplotlib ==0.7.5, + any.matrices ==0.5.0, + any.matrix ==0.3.6.1, + any.matrix-as-xyz ==0.1.2.2, + any.matrix-market-attoparsec ==0.1.1.3, + any.matrix-static ==0.3, + any.maximal-cliques ==0.1.1, + any.mbox ==0.3.4, + any.mbox-utility ==0.0.3.1, + any.mcmc-types ==1.0.3, + any.medea ==1.1.2, + any.median-stream ==0.7.0.0, + any.megaparsec ==8.0.0, + any.megaparsec-tests ==8.0.0, + any.membrain ==0.0.0.2, + any.memory ==0.15.0, + any.mercury-api ==0.1.0.2, + any.mergeful ==0.2.0.0, + any.mergeless ==0.3.0.0, + mersenne-random-pure64 -small_base, + any.mersenne-random-pure64 ==0.2.2.0, + any.messagepack ==0.5.4, + any.metrics ==0.4.1.1, + any.mfsolve ==0.3.2.0, + any.microlens ==0.4.11.2, + any.microlens-aeson ==2.3.1, + any.microlens-contra ==0.1.0.2, + any.microlens-ghc ==0.4.12, + any.microlens-mtl ==0.2.0.1, + any.microlens-platform ==0.4.1, + any.microlens-process ==0.2.0.2, + any.microlens-th ==0.4.3.5, + any.microspec ==0.2.1.3, + any.microstache ==1.0.1.1, + any.midair ==0.2.0.1, + any.midi ==0.2.2.2, + any.mighty-metropolis ==2.0.0, + any.mime ==0.4.0.2, + any.mime-mail ==0.5.0, + any.mime-mail-ses ==0.4.3, + any.mime-types ==0.1.0.9, + any.min-max-pqueue ==0.1.0.2, + any.mini-egison ==1.0.0, + any.minimal-configuration ==0.1.4, + any.minimorph ==0.2.2.0, + any.minio-hs ==1.5.2, + any.miniutter ==0.5.1.0, + mintty +win32-2-5-3, + any.mintty ==0.1.2, + any.miso ==1.6.0.0, + any.missing-foreign ==0.1.1, + any.mixed-types-num ==0.4.0.2, + any.mixpanel-client ==0.2.1, + any.mltool ==0.2.0.1, + any.mmap ==0.5.9, + any.mmark ==0.0.7.2, + any.mmark-cli ==0.0.5.0, + any.mmark-ext ==0.2.1.2, + any.mmorph ==1.1.3, + any.mnist-idx ==0.1.2.8, + any.mockery ==0.3.5, + any.mod ==0.1.2.0, + any.model ==0.5, + any.modern-uri ==0.3.2.0, + any.modular ==0.1.0.8, + any.monad-bayes ==0.1.1.0, + any.monad-control ==1.0.2.3, + any.monad-control-aligned ==0.0.1.1, + any.monad-coroutine ==0.9.0.4, + any.monad-extras ==0.6.0, + any.monad-journal ==0.8.1, + any.monad-logger ==0.3.35, + any.monad-logger-json ==0.1.0.0, + any.monad-logger-prefix ==0.1.11, + any.monad-loops ==0.4.3, + any.monad-memo ==0.5.1, + any.monad-metrics ==0.2.1.4, + any.monad-par ==0.3.5, + any.monad-par-extras ==0.3.3, + any.monad-parallel ==0.7.2.3, + any.monad-peel ==0.2.1.2, + any.monad-products ==4.0.1, + any.monad-resumption ==0.1.4.0, + any.monad-skeleton ==0.1.5, + any.monad-st ==0.2.4.1, + any.monad-time ==0.3.1.0, + any.monad-unlift ==0.2.0, + any.monad-unlift-ref ==0.2.1, + any.monadic-arrays ==0.2.2, + any.monads-tf ==0.1.0.3, + mongoDB -_old-network, + any.mongoDB ==2.7.0.0, + any.mono-traversable ==1.0.15.1, + any.mono-traversable-instances ==0.1.1.0, + any.mono-traversable-keys ==0.1.0, + any.monoid-extras ==0.5.1, + any.monoid-subclasses ==1.0.1, + any.monoid-transformer ==0.0.4, + any.more-containers ==0.2.2.0, + any.morpheus-graphql ==0.12.0, + any.morpheus-graphql-core ==0.12.0, + any.mountpoints ==1.0.2, + any.mpi-hs ==0.7.2.0, + any.mpi-hs-binary ==0.1.1.0, + any.mpi-hs-cereal ==0.1.0.0, + any.mtl-compat ==0.2.2, + any.mtl-prelude ==2.0.3.1, + any.mu-avro ==0.4.0.4, + any.mu-grpc-client ==0.4.0.1, + any.mu-grpc-common ==0.4.0.0, + any.mu-grpc-server ==0.4.0.0, + any.mu-optics ==0.3.0.1, + any.mu-protobuf ==0.4.2.0, + any.mu-rpc ==0.4.0.1, + any.mu-schema ==0.3.1.2, + any.multi-containers ==0.1.1, + any.multiarg ==0.30.0.10, + any.multimap ==1.2.1, + any.multiset ==0.3.4.3, + any.multistate ==0.8.0.3, + any.murmur-hash ==0.1.0.9, + any.murmur3 ==1.0.4, + any.mustache ==2.3.1, + any.mutable-containers ==0.3.4, + any.mwc-probability ==2.3.1, + any.mwc-random ==0.14.0.0, + any.mx-state-codes ==1.0.0.0, + any.mysql ==0.1.7, + any.mysql-simple ==0.4.5, + any.n2o ==0.11.1, + any.nagios-check ==0.3.2, + any.names-th ==0.3.0.1, + any.nano-erl ==0.1.0.1, + any.nanospec ==0.2.2, + any.nats ==1.1.2, + any.natural-induction ==0.2.0.0, + any.natural-sort ==0.1.2, + any.natural-transformation ==0.4, + any.ndjson-conduit ==0.1.0.5, + any.neat-interpolation ==0.3.2.6, + any.netlib-carray ==0.1, + any.netlib-comfort-array ==0.0.0.1, + any.netlib-ffi ==0.1.1, + any.netpbm ==1.0.3, + any.netrc ==0.2.0.0, + any.nettle ==0.3.0, + any.netwire ==5.0.3, + any.netwire-input ==0.0.7, + any.netwire-input-glfw ==0.0.11, + any.network ==3.1.1.1, + any.network-bsd ==2.8.1.0, + any.network-byte-order ==0.1.5, + any.network-conduit-tls ==1.3.2, + any.network-info ==0.2.0.10, + any.network-ip ==0.3.0.3, + any.network-messagepack-rpc ==0.1.2.0, + any.network-messagepack-rpc-websocket ==0.1.1.1, + any.network-simple ==0.4.5, + any.network-simple-tls ==0.4, + any.network-transport ==0.5.4, + any.network-transport-composed ==0.2.1, + any.network-uri ==2.6.3.0, + any.newtype ==0.2.2.0, + any.newtype-generics ==0.5.4, + any.nicify-lib ==1.0.1, + nix-paths +allow-relative-paths, + any.nix-paths ==1.0.1, + any.no-value ==1.0.0.0, + any.non-empty ==0.3.2, + any.non-empty-sequence ==0.2.0.4, + any.non-negative ==0.1.2, + any.nonce ==1.0.7, + any.nondeterminism ==1.4, + any.nonempty-containers ==0.3.4.1, + any.nonempty-vector ==0.2.0.2, + any.nonemptymap ==0.0.6.0, + any.not-gloss ==0.7.7.0, + any.nowdoc ==0.1.1.0, + any.nqe ==0.6.3, + any.nsis ==0.3.3, + any.numbers ==3000.2.0.2, + any.numeric-extras ==0.1, + any.numeric-prelude ==0.4.3.2, + any.numhask ==0.4.0, + any.numtype-dk ==0.5.0.2, + any.nuxeo ==0.3.2, + any.o-clock ==1.1.0, + any.oauthenticated ==0.2.1.0, + any.odbc ==0.2.2, + any.oeis2 ==1.0.4, + any.ofx ==0.4.4.0, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.3, + any.once ==0.4, + any.one-liner ==1.0, + any.one-liner-instances ==0.1.2.1, + any.oo-prototypes ==0.1.0.0, + any.opaleye ==0.6.7006.1, + any.open-browser ==0.2.1.0, + any.openexr-write ==0.1.0.2, + any.openpgp-asciiarmor ==0.1.2, + any.opensource ==0.1.1.0, + any.openssl-streams ==1.2.3.0, + any.opentelemetry ==0.4.2, + any.opentelemetry-extra ==0.4.2, + any.opentelemetry-lightstep ==0.4.2, + any.opentelemetry-wai ==0.4.2, + any.operational ==0.2.3.5, + any.operational-class ==0.3.0.0, + any.optics ==0.2, + any.optics-core ==0.2, + any.optics-extra ==0.2, + any.optics-th ==0.2, + any.optics-vl ==0.2, + any.optional-args ==1.0.2, + any.options ==1.2.1.1, + any.optparse-applicative ==0.15.1.0, + any.optparse-generic ==1.3.1, + any.optparse-simple ==0.1.1.3, + any.optparse-text ==0.1.1.0, + any.ordered-containers ==0.2.2, + any.ormolu ==0.1.4.1, + any.overhang ==1.0.0, + any.packcheck ==0.5.1, + any.pager ==0.1.1.0, + any.pagination ==0.2.1, + any.pagure-cli ==0.2, + any.pandoc ==2.9.2.1, + any.pandoc-citeproc ==0.17.0.1, + any.pandoc-csv2table ==1.0.8, + any.pandoc-plot ==0.6.1.0, + any.pandoc-pyplot ==2.3.0.1, + any.pandoc-types ==1.20, + any.pantry ==0.4.0.2, + any.papillon ==0.1.1.1, + any.parallel ==3.2.2.0, + any.parallel-io ==0.3.3, + any.parameterized ==0.5.0.0, + any.paripari ==0.6.0.1, + any.parseargs ==0.2.0.9, + any.parsec-class ==1.0.0.0, + any.parsec-numbers ==0.1.0, + any.parsec-numeric ==0.1.0.0, + any.parser-combinators ==1.2.1, + any.parser-combinators-tests ==1.2.1, + any.parsers ==0.12.10, + any.partial-handler ==1.0.3, + any.partial-isomorphisms ==0.2.2.1, + any.partial-semigroup ==0.5.1.8, + any.password ==2.0.1.1, + any.password-instances ==2.0.0.1, + any.path ==0.7.0, + any.path-extra ==0.2.0, + any.path-io ==1.6.0, + any.path-pieces ==0.2.1, + any.path-text-utf8 ==0.0.1.6, + pathtype -old-time, + any.pathtype ==0.8.1.1, + any.pathwalk ==0.3.1.2, + any.pattern-arrows ==0.0.2, + any.pattern-trie ==0.1.0, + any.pcg-random ==0.1.3.6, + any.pcre-heavy ==1.0.0.2, + any.pcre-light ==0.4.1.0, + any.pcre-utils ==0.1.8.1.1, + any.pdfinfo ==1.5.4, + any.peano ==0.1.0.1, + any.pem ==0.2.4, + any.percent-format ==0.0.1, + any.perfect-hash-generator ==0.2.0.6, + any.perfect-vector-shuffle ==0.1.1.1, + any.persist ==0.1.1.5, + any.persistable-record ==0.6.0.5, + any.persistable-types-HDBC-pg ==0.0.3.5, + any.persistent ==2.10.5.2, + any.persistent-mysql ==2.10.2.3, + any.persistent-pagination ==0.1.1.1, + any.persistent-postgresql ==2.10.1.2, + any.persistent-qq ==2.9.1.1, + any.persistent-sqlite ==2.10.6.2, + any.persistent-template ==2.8.2.3, + any.persistent-test ==2.0.3.1, + any.persistent-typed-db ==0.1.0.1, + any.pg-harness-client ==0.6.0, + any.pg-transact ==0.3.1.1, + any.pgp-wordlist ==0.1.0.3, + any.phantom-state ==0.2.1.2, + any.pid1 ==0.1.2.0, + any.pipes ==4.3.14, + any.pipes-aeson ==0.4.1.8, + any.pipes-attoparsec ==0.5.1.5, + any.pipes-binary ==0.4.2, + any.pipes-bytestring ==2.1.6, + any.pipes-concurrency ==2.0.12, + any.pipes-csv ==1.4.3, + any.pipes-extras ==1.0.15, + any.pipes-fastx ==0.3.0.0, + any.pipes-group ==1.0.12, + any.pipes-http ==1.0.6, + any.pipes-network ==0.6.5, + any.pipes-network-tls ==0.4, + any.pipes-ordered-zip ==1.1.0, + any.pipes-parse ==3.0.8, + any.pipes-random ==1.0.0.5, + any.pipes-safe ==2.3.2, + any.pipes-wai ==3.2.0, + any.pkcs10 ==0.2.0.0, + any.placeholders ==0.1, + any.plaid ==0.1.0.4, + any.planb-token-introspection ==0.1.4.0, + any.plotlyhs ==0.2.1, + any.pointed ==5.0.1, + any.pointedlist ==0.6.1, + any.pointless-fun ==1.1.0.6, + any.poll ==0.0.0.1, + any.poly ==0.4.0.0, + any.poly-arity ==0.1.0, + any.polynomials-bernstein ==1.1.2, + any.polyparse ==1.13, + any.polysemy ==1.6.0.0, + any.polysemy-mocks ==0.1.0.0, + any.polysemy-plugin ==0.2.5.2, + any.pooled-io ==0.0.2.2, + any.port-utils ==0.2.1.0, + any.posix-paths ==0.2.1.6, + any.possibly ==1.0.0.0, + any.post-mess-age ==0.2.1.0, + any.postgres-options ==0.2.0.0, + any.postgresql-binary ==0.12.2, + any.postgresql-libpq ==0.9.4.2, + any.postgresql-orm ==0.5.1, + any.postgresql-simple ==0.6.2, + any.postgrest ==7.0.0, + any.pptable ==0.3.0.0, + any.pqueue ==1.4.1.3, + any.prefix-units ==0.2.0, + any.prelude-compat ==0.0.0.2, + any.prelude-safeenum ==0.1.1.2, + any.pretty-class ==1.0.1.1, + any.pretty-hex ==1.1, + any.pretty-relative-time ==0.2.0.0, + any.pretty-show ==1.10, + any.pretty-simple ==3.2.3.0, + any.pretty-sop ==0.2.0.3, + any.pretty-terminal ==0.1.0.0, + any.pretty-types ==0.3.0.1, + any.prettyclass ==1.0.0.0, + any.prettyprinter ==1.6.2, + any.prettyprinter-ansi-terminal ==1.1.2, + any.prettyprinter-compat-annotated-wl-pprint ==1, + any.prettyprinter-compat-ansi-wl-pprint ==1.0.1, + any.prettyprinter-compat-wl-pprint ==1.0.0.1, + any.prettyprinter-convert-ansi-wl-pprint ==1.1.1, + any.primes ==0.2.1.0, + any.primitive ==0.7.0.1, + any.primitive-addr ==0.1.0.2, + any.primitive-extras ==0.8, + any.primitive-unaligned ==0.1.1.1, + any.primitive-unlifted ==0.1.2.0, + any.print-console-colors ==0.1.0.0, + any.process-extras ==0.7.4, + any.product-isomorphic ==0.0.3.3, + any.product-profunctors ==0.10.0.1, + any.profiterole ==0.1, + any.profunctors ==5.5.2, + any.project-template ==0.2.1.0, + any.projectroot ==0.2.0.1, + any.prometheus ==2.2.2, + any.prometheus-client ==1.0.1, + any.promises ==0.3, + any.prompt ==0.1.1.2, + any.prospect ==0.1.0.0, + any.proto-lens ==0.7.0.0, + any.proto-lens-arbitrary ==0.1.2.9, + any.proto-lens-optparse ==0.1.1.7, + any.proto-lens-protobuf-types ==0.7.0.0, + any.proto-lens-protoc ==0.7.0.0, + any.proto-lens-runtime ==0.7.0.0, + any.proto-lens-setup ==0.4.0.4, + any.proto3-wire ==1.2.0, + any.protobuf ==0.2.1.3, + any.protobuf-simple ==0.1.1.0, + any.protocol-radius ==0.0.1.1, + any.protocol-radius-test ==0.1.0.1, + any.protolude ==0.2.4, + any.proxied ==0.3.1, + any.psqueues ==0.2.7.2, + any.publicsuffix ==0.20200526, + any.pulse-simple ==0.1.14, + any.pureMD5 ==2.1.3, + any.purescript-bridge ==0.14.0.0, + any.pushbullet-types ==0.4.1.0, + any.pusher-http-haskell ==1.5.1.14, + any.pvar ==0.2.0.0, + any.qchas ==1.1.0.1, + any.qm-interpolated-string ==0.3.0.0, + any.qrcode-core ==0.9.4, + any.qrcode-juicypixels ==0.8.2, + any.quadratic-irrational ==0.1.1, + any.quickcheck-arbitrary-adt ==0.3.1.0, + any.quickcheck-assertions ==0.3.0, + any.quickcheck-classes ==0.6.4.0, + any.quickcheck-classes-base ==0.6.1.0, + any.quickcheck-instances ==0.3.23, + any.quickcheck-io ==0.2.0, + any.quickcheck-simple ==0.1.1.1, + any.quickcheck-special ==0.1.0.6, + any.quickcheck-state-machine ==0.6.0, + any.quickcheck-text ==0.1.2.1, + any.quickcheck-transformer ==0.3.1.1, + any.quickcheck-unicode ==1.0.1.0, + any.quiet ==0.2, + any.radius ==0.6.1.0, + any.rainbow ==0.34.2.2, + any.rainbox ==0.26.0.0, + any.ral ==0.1, + any.ramus ==0.1.2, + any.rando ==0.0.0.4, + any.random ==1.1, + any.random-bytestring ==0.1.3.2, + any.random-shuffle ==0.0.4, + any.random-tree ==0.6.0.5, + any.range ==0.3.0.2, + any.range-set-list ==0.1.3.1, + any.rank1dynamic ==0.4.0, + any.rank2classes ==1.3.2.1, + any.rasterific-svg ==0.3.3.2, + any.rate-limit ==1.4.2, + any.ratel ==1.0.12, + any.ratel-wai ==1.1.3, + any.raw-strings-qq ==1.1, + any.rawfilepath ==0.2.4, + any.rawstring-qm ==0.2.3.0, + any.rcu ==0.2.4, + any.rdf ==0.1.0.4, + any.rdtsc ==1.3.0.1, + any.re2 ==0.3, + any.read-editor ==0.1.0.2, + any.read-env-var ==1.0.0.0, + any.readable ==0.3.1, + any.reanimate ==0.3.3.0, + any.reanimate-svg ==0.9.8.0, + any.rebase ==1.6.1, + any.record-dot-preprocessor ==0.2.6, + any.record-hasfield ==1.0, + any.records-sop ==0.1.0.3, + any.recursion-schemes ==5.1.3, + any.redis-io ==1.1.0, + any.redis-resp ==1.0.0, + any.reducers ==3.12.3, + any.ref-fd ==0.4.0.2, + any.refact ==0.3.0.2, + any.reflection ==2.1.6, + any.reform ==0.2.7.4, + any.reform-blaze ==0.2.4.3, + any.reform-hamlet ==0.0.5.3, + any.reform-happstack ==0.2.5.3, + any.regex ==1.1.0.0, + any.regex-applicative ==0.3.3.1, + any.regex-applicative-text ==0.1.0.1, + any.regex-base ==0.94.0.0, + any.regex-compat ==0.95.2.0, + any.regex-compat-tdfa ==0.95.1.4, + any.regex-pcre ==0.95.0.0, + any.regex-pcre-builtin ==0.95.1.2.8.43, + any.regex-posix ==0.96.0.0, + any.regex-tdfa ==1.3.1.0, + any.regex-with-pcre ==1.1.0.0, + any.registry ==0.1.9.3, + any.reinterpret-cast ==0.1.0, + any.relapse ==1.0.0.0, + any.relational-query ==0.12.2.3, + any.relational-query-HDBC ==0.7.2.0, + any.relational-record ==0.2.2.0, + any.relational-schemas ==0.1.8.0, + any.relude ==0.7.0.0, + any.renderable ==0.2.0.1, + any.replace-attoparsec ==1.4.1.0, + any.replace-megaparsec ==1.4.2.0, + any.repline ==0.2.2.0, + any.req ==3.2.0, + any.req-conduit ==1.0.0, + any.rerebase ==1.6.1, + any.resolv ==0.1.2.0, + any.resource-pool ==0.2.3.2, + any.resourcet ==1.2.4.2, + any.result ==0.2.6.0, + any.rethinkdb-client-driver ==0.0.25, + any.retry ==0.8.1.2, + any.rev-state ==0.1.2, + any.rfc1751 ==0.1.3, + any.rfc5051 ==0.1.0.4, + any.rhine ==0.6.0, + any.rhine-gloss ==0.6.0.1, + any.rigel-viz ==0.2.0.0, + any.rio ==0.1.18.0, + any.rio-orphans ==0.1.1.0, + any.rio-prettyprint ==0.1.1.0, + any.roc-id ==0.1.0.0, + any.rocksdb-haskell ==1.0.1, + any.rocksdb-query ==0.3.2, + any.roles ==0.2.0.0, + any.rope-utf16-splay ==0.3.1.0, + any.rosezipper ==0.2, + any.rot13 ==0.2.0.1, + any.rpmbuild-order ==0.3.1, + any.runmemo ==1.0.0.1, + any.safe ==0.3.19, + any.safe-decimal ==0.2.0.0, + any.safe-exceptions ==0.1.7.1, + any.safe-exceptions-checked ==0.1.0, + any.safe-foldable ==0.1.0.0, + any.safe-json ==1.1.1, + any.safe-money ==0.9, + any.safecopy ==0.10.3, + any.safeio ==0.0.5.0, + any.salak ==0.3.6, + any.salak-yaml ==0.3.5.3, + any.saltine ==0.1.1.0, + any.salve ==1.0.10, + any.sample-frame ==0.0.3, + any.sample-frame-np ==0.0.4.1, + any.sampling ==0.3.5, + any.say ==0.1.0.1, + any.sbp ==2.6.3, + any.scalpel ==0.6.2, + any.scalpel-core ==0.6.2, + any.scanf ==0.1.0.0, + any.scanner ==0.3.1, + any.scheduler ==1.4.2.3, + any.scientific ==0.3.6.2, + any.scotty ==0.11.6, + any.scrypt ==0.5.0, + any.sdl2 ==2.5.2.0, + any.sdl2-gfx ==0.2, + any.sdl2-image ==2.0.0, + any.sdl2-mixer ==1.1.0, + any.sdl2-ttf ==2.1.1, + any.search-algorithms ==0.3.1, + any.secp256k1-haskell ==0.2.5, + any.securemem ==0.1.10, + any.selda ==0.5.1.0, + any.selda-json ==0.1.1.0, + any.selective ==0.4.1.1, + any.semialign ==1.1.0.1, + any.semialign-indexed ==1.1, + any.semialign-optics ==1.1, + any.semigroupoid-extras ==5, + any.semigroupoids ==5.3.4, + any.semigroups ==0.19.1, + any.semiring-simple ==1.0.0.1, + any.semirings ==0.5.4, + any.semver ==0.3.4, + any.sendfile ==0.7.11.1, + any.seqalign ==0.2.0.4, + any.sequence-formats ==1.4.1, + any.sequenceTools ==1.4.0.5, + any.serf ==0.1.1.0, + any.serialise ==0.2.3.0, + any.servant-JuicyPixels ==0.3.0.5, + any.servant-auth ==0.3.2.0, + any.servant-auth-docs ==0.2.10.0, + any.servant-auth-server ==0.4.5.1, + any.servant-auth-swagger ==0.2.10.0, + any.servant-blaze ==0.9, + any.servant-cassava ==0.10, + any.servant-checked-exceptions ==2.2.0.0, + any.servant-checked-exceptions-core ==2.2.0.0, + any.servant-conduit ==0.15.1, + any.servant-docs ==0.11.4, + any.servant-docs-simple ==0.2.0.1, + any.servant-elm ==0.7.2, + any.servant-errors ==0.1.6.0, + any.servant-foreign ==0.15, + any.servant-js ==0.9.4.2, + any.servant-lucid ==0.9, + any.servant-machines ==0.15.1, + any.servant-mock ==0.8.7, + any.servant-multipart ==0.11.5, + any.servant-pipes ==0.15.2, + any.servant-purescript ==0.10.0.0, + any.servant-rawm ==0.3.2.0, + any.servant-static-th ==0.2.4.0, + any.servant-subscriber ==0.7.0.0, + any.servant-swagger-ui ==0.3.4.3.36.1, + any.servant-swagger-ui-core ==0.3.3, + any.servant-swagger-ui-redoc ==0.3.3.1.22.3, + any.servant-websockets ==2.0.0, + any.servant-yaml ==0.1.0.1, + any.serverless-haskell ==0.11.3, + any.serversession ==1.0.1, + any.serversession-frontend-wai ==1.0, + any.ses-html ==0.4.0.0, + any.set-cover ==0.1.1, + any.setenv ==0.1.1.3, + any.setlocale ==1.0.0.9, + any.sexp-grammar ==2.1.0, + any.shake ==0.19.1, + any.shake-plus ==0.1.10.0, + any.shakespeare ==2.0.25, + any.shared-memory ==0.2.0.0, + any.shell-conduit ==4.7.0, + any.shell-escape ==0.2.0, + any.shell-utility ==0.1, + any.shellmet ==0.0.3.1, + any.shelltestrunner ==1.9, + any.shelly ==1.9.0, + any.should-not-typecheck ==2.1.0, + any.show-combinators ==0.2.0.0, + any.siggy-chardust ==1.0.0, + any.signal ==0.1.0.4, + any.silently ==1.2.5.1, + any.simple-affine-space ==0.1.1, + any.simple-cabal ==0.1.2, + any.simple-cmd ==0.2.2, + any.simple-cmd-args ==0.1.6, + any.simple-log ==0.9.12, + any.simple-reflect ==0.3.3, + any.simple-sendfile ==0.2.30, + any.simple-templates ==1.0.0, + any.simple-vec3 ==0.6.0.1, + any.simplest-sqlite ==0.1.0.2, + any.simplistic-generics ==2.0.0, + any.since ==0.0.0, + any.singleton-bool ==0.1.5, + any.singleton-nats ==0.4.5, + any.singletons ==2.6, + any.singletons-presburger ==0.3.0.1, + any.siphash ==1.0.3, + any.sitemap-gen ==0.1.0.0, + any.size-based ==0.1.2.0, + any.sized ==0.4.0.0, + any.skein ==1.0.9.4, + any.skews ==0.1.0.3, + any.skip-var ==0.1.1.0, + any.skylighting ==0.8.5, + any.skylighting-core ==0.8.5, + any.slack-api ==0.12, + any.slist ==0.1.1.0, + any.smallcheck ==1.1.7, + any.smash ==0.1.1.0, + any.smash-aeson ==0.1.0.0, + any.smash-lens ==0.1.0.0, + any.smash-microlens ==0.1.0.0, + any.smoothie ==0.4.2.11, + any.smtp-mail ==0.2.0.0, + any.snap-blaze ==0.2.1.5, + any.snap-core ==1.0.4.2, + any.snap-server ==1.1.1.2, + any.snowflake ==0.1.1.1, + any.soap ==0.2.3.6, + any.soap-tls ==0.1.1.4, + any.socks ==0.6.1, + any.some ==1.0.1, + any.sop-core ==0.5.0.1, + any.sort ==1.0.0.0, + any.sorted-list ==0.2.1.0, + any.sourcemap ==0.1.6, + any.sox ==0.2.3.1, + any.soxlib ==0.0.3.1, + any.sparse-linear-algebra ==0.3.1, + any.sparse-tensor ==0.2.1.4, + any.spatial-math ==0.5.0.1, + any.special-values ==0.1.0.0, + any.speculate ==0.4.2, + any.speedy-slice ==0.3.1, + any.splice ==0.6.1.1, + any.split ==0.2.3.4, + any.splitmix ==0.0.4, + any.spoon ==0.3.1, + any.spreadsheet ==0.1.3.8, + any.sql-words ==0.1.6.4, + any.sqlcli ==0.2.2.0, + any.sqlcli-odbc ==0.2.0.1, + any.squeather ==0.4.0.0, + any.srcloc ==0.5.1.2, + any.stache ==2.1.1, + any.stack ==2.3.3, + any.stack-templatizer ==0.1.0.2, + any.stackcollapse-ghc ==0.0.1.2, + any.starter ==0.3.0, + any.stateref ==0.3, + any.statestack ==0.3, + any.static-text ==0.2.0.6, + any.statistics ==0.15.2.0, + any.status-notifier-item ==0.3.0.5, + any.stb-image-redux ==0.2.1.3, + any.step-function ==0.2, + any.stm-chans ==3.0.0.4, + any.stm-conduit ==4.0.1, + any.stm-containers ==1.1.0.4, + any.stm-delay ==0.1.1.1, + any.stm-extras ==0.1.0.3, + any.stm-hamt ==1.2.0.4, + any.stm-split ==0.0.2.1, + any.stomp-queue ==0.3.1, + any.stompl ==0.5.0, + any.stopwatch ==0.1.0.6, + any.storable-complex ==0.2.3.0, + any.storable-record ==0.0.5, + any.storable-tuple ==0.0.3.3, + any.storablevector ==0.2.13.1, + any.stratosphere ==0.53.0, + any.streaming ==0.2.3.0, + any.streaming-bytestring ==0.1.6, + any.streaming-commons ==0.2.2.1, + any.streamly ==0.7.2, + any.streamly-bytestring ==0.1.2, + any.streams ==3.3, + any.strict ==0.3.2, + any.strict-base-types ==0.6.1, + any.strict-concurrency ==0.2.4.3, + any.strict-list ==0.1.5, + any.strict-tuple ==0.1.3, + any.strict-tuple-lens ==0.1.0.1, + any.string-class ==0.1.7.0, + any.string-combinators ==0.6.0.5, + any.string-conv ==0.1.2, + any.string-conversions ==0.4.0.1, + any.string-interpolate ==0.2.1.0, + any.string-qq ==0.0.4, + any.string-transform ==1.1.1, + any.stringbuilder ==0.5.1, + any.stringsearch ==0.3.6.6, + any.stripe-concepts ==1.0.2.4, + any.stripe-signature ==1.0.0.6, + any.strive ==5.0.12, + any.structs ==0.1.3, + any.structured ==0.1, + any.structured-cli ==2.5.2.0, + any.stylish-haskell ==0.11.0.3, + any.sum-type-boilerplate ==0.1.1, + any.summoner ==2.0.1.1, + any.summoner-tui ==2.0.1.1, + any.sundown ==0.6, + any.superbuffer ==0.3.1.1, + any.svg-builder ==0.1.1, + any.svg-tree ==0.6.2.4, + any.swagger ==0.3.0, + any.swagger2 ==2.5, + any.swish ==0.10.0.4, + any.syb ==0.7.1, + any.symbol ==0.2.4, + any.symengine ==0.1.2.0, + any.symmetry-operations-symbols ==0.0.2.1, + any.sysinfo ==0.1.1, + any.system-argv0 ==0.1.1, + any.system-fileio ==0.3.16.4, + any.system-filepath ==0.4.14, + any.system-info ==0.5.1, + any.systemd ==2.3.0, + any.tabular ==0.2.2.8, + any.taffybar ==3.2.2, + any.tagchup ==0.4.1.1, + any.tagged ==0.8.6, + any.tagged-binary ==0.2.0.1, + any.tagged-identity ==0.1.3, + any.tagged-transformer ==0.8.1, + any.tagshare ==0.0, + any.tagsoup ==0.14.8, + any.tao ==1.0.0, + any.tao-example ==1.0.0, + tar -old-time, + any.tar ==0.5.1.1, + any.tar-conduit ==0.3.2, + any.tardis ==0.4.1.0, + any.tasty ==1.2.3, + any.tasty-ant-xml ==1.1.6, + any.tasty-dejafu ==2.0.0.6, + any.tasty-discover ==4.2.1, + any.tasty-expected-failure ==0.11.1.2, + any.tasty-golden ==2.3.3.2, + any.tasty-hedgehog ==1.0.0.2, + any.tasty-hspec ==1.1.5.1, + any.tasty-hunit ==0.10.0.2, + any.tasty-kat ==0.0.3, + any.tasty-leancheck ==0.0.1, + any.tasty-lua ==0.2.3, + any.tasty-program ==1.0.5, + any.tasty-quickcheck ==0.10.1.1, + any.tasty-rerun ==1.1.17, + any.tasty-silver ==3.1.15, + any.tasty-smallcheck ==0.8.1, + any.tasty-th ==0.1.7, + any.tasty-wai ==0.1.1.0, + any.tce-conf ==1.3, + any.tdigest ==0.2.1, + any.template ==0.2.0.10, + any.template-haskell-compat-v0208 ==0.1.5, + any.temporary ==1.3, + any.temporary-rc ==1.2.0.3, + any.temporary-resourcet ==0.1.0.1, + any.tensorflow-test ==0.1.0.0, + any.tensors ==0.1.4, + any.terminal-progress-bar ==0.4.1, + any.terminal-size ==0.3.2.1, + any.test-framework ==0.8.2.0, + any.test-framework-hunit ==0.3.0.2, + any.test-framework-leancheck ==0.0.1, + any.test-framework-quickcheck2 ==0.3.0.5, + any.test-framework-smallcheck ==0.2, + any.test-framework-th ==0.2.4, + any.testing-feat ==1.1.0.0, + any.testing-type-modifiers ==0.1.0.1, + any.texmath ==0.12.0.2, + any.text-binary ==0.2.1.1, + any.text-builder ==0.6.6.1, + any.text-conversions ==0.3.0, + any.text-format ==0.3.2, + any.text-icu ==0.7.0.1, + any.text-icu-translit ==0.1.0.7, + any.text-latin1 ==0.3.1, + any.text-ldap ==0.1.1.13, + any.text-manipulate ==0.2.0.1, + any.text-metrics ==0.3.0, + any.text-postgresql ==0.0.3.1, + any.text-printer ==0.5.0.1, + any.text-region ==0.3.1.0, + any.text-short ==0.1.3, + any.text-show ==3.8.5, + any.text-show-instances ==3.8.3, + any.text-zipper ==0.10.1, + any.textlocal ==0.1.0.5, + any.tf-random ==0.5, + any.tfp ==1.0.1.1, + any.th-abstraction ==0.3.2.0, + any.th-bang-compat ==0.0.1.0, + any.th-constraint-compat ==0.0.1.0, + any.th-data-compat ==0.1.0.0, + any.th-desugar ==1.10, + any.th-env ==0.1.0.2, + any.th-expand-syns ==0.4.6.0, + any.th-extras ==0.0.0.4, + any.th-lift ==0.8.1, + any.th-lift-instances ==0.1.17, + any.th-nowq ==0.1.0.5, + any.th-orphans ==0.13.10, + any.th-printf ==0.7, + any.th-reify-compat ==0.0.1.5, + any.th-reify-many ==0.1.9, + any.th-strict-compat ==0.1.0.1, + any.th-test-utils ==1.0.2, + any.these ==1.1.1.1, + any.these-lens ==1.0.0.1, + any.these-optics ==1, + any.thread-hierarchy ==0.3.0.2, + any.thread-local-storage ==0.2, + any.thread-supervisor ==0.1.0.1, + any.threads ==0.5.1.6, + any.threepenny-gui ==0.9.0.0, + any.throttle-io-stream ==0.2.0.1, + any.through-text ==0.1.0.0, + any.throwable-exceptions ==0.1.0.9, + any.thyme ==0.3.5.5, + any.tidal ==1.5.2, + any.tile ==0.3.0.0, + any.time-compat ==1.9.3, + any.time-lens ==0.4.0.2, + time-locale-compat -old-locale, + any.time-locale-compat ==0.1.1.5, + any.time-locale-vietnamese ==1.0.0.0, + any.time-manager ==0.0.0, + any.time-parsers ==0.1.2.1, + any.time-units ==1.0.0, + any.timeit ==2.0, + any.timelens ==0.2.0.2, + any.timerep ==2.0.0.2, + any.timezone-olson ==0.2.0, + any.timezone-series ==0.1.9, + any.tinylog ==0.15.0, + any.titlecase ==1.0.1, + any.tldr ==0.6.4, + any.tls ==1.5.5, + any.tls-debug ==0.4.8, + any.tls-session-manager ==0.0.4, + any.tmapchan ==0.0.3, + any.tmapmvar ==0.0.4, + any.tmp-postgres ==1.34.1.0, + any.tomland ==1.3.0.0, + any.tonalude ==0.1.1.0, + any.topograph ==1.0.0.1, + any.torsor ==0.1, + any.tostring ==0.2.1.1, + any.tracing ==0.0.5.1, + any.transaction ==0.1.1.3, + any.transformers-base ==0.4.5.2, + any.transformers-bifunctors ==0.1, + transformers-compat +five-three, + any.transformers-compat ==0.6.5, + any.transformers-fix ==1.0, + any.traverse-with-class ==1.0.1.0, + any.tree-diff ==0.1, + any.tree-fun ==0.8.1.0, + any.trifecta ==2.1, + any.triplesec ==0.2.2.1, + any.trivial-constraint ==0.6.0.0, + any.tsv2csv ==0.1.0.2, + any.ttc ==0.2.2.0, + any.ttl-hashtables ==1.4.1.0, + any.ttrie ==0.1.2.1, + any.tuple ==0.3.0.2, + any.tuple-sop ==0.3.1.0, + any.tuple-th ==0.2.5, + any.tuples-homogenous-h98 ==0.1.1.0, + any.turtle ==1.5.20, + any.type-equality ==1, + any.type-errors ==0.2.0.0, + any.type-errors-pretty ==0.0.1.1, + any.type-fun ==0.1.1, + any.type-hint ==0.1, + any.type-level-integers ==0.0.1, + any.type-level-kv-list ==1.1.0, + any.type-level-numbers ==0.1.1.1, + any.type-map ==0.1.6.0, + any.type-natural ==0.8.3.1, + any.type-of-html ==1.5.1.0, + any.type-of-html-static ==0.1.0.2, + any.type-operators ==0.2.0.0, + any.type-spec ==0.4.0.0, + any.typed-process ==0.2.6.0, + any.typed-uuid ==0.0.0.2, + any.typenums ==0.1.2.1, + any.typerep-map ==0.3.3.0, + any.tzdata ==0.1.20190911.0, + any.ua-parser ==0.7.5.1, + any.uglymemo ==0.1.0.1, + any.ulid ==0.3.0.0, + any.unagi-chan ==0.4.1.3, + any.unbounded-delays ==0.1.1.0, + any.unboxed-ref ==0.4.0.0, + any.unboxing-vector ==0.1.1.0, + any.uncertain ==0.3.1.0, + any.unconstrained ==0.1.0.2, + any.unexceptionalio ==0.5.1, + any.unexceptionalio-trans ==0.5.1, + any.unicode ==0.0.1.1, + any.unicode-show ==0.1.0.4, + any.unicode-transforms ==0.3.7, + any.unification-fd ==0.10.0.1, + any.union-find ==0.2, + any.uniplate ==1.6.12, + any.uniprot-kb ==0.1.2.0, + any.uniq-deep ==1.2.0, + any.unique ==0, + any.unique-logic ==0.4, + any.unique-logic-tf ==0.5.1, + any.unit-constraint ==0.0.0, + any.universe ==1.2, + any.universe-base ==1.1.1, + any.universe-instances-base ==1.1, + any.universe-instances-extended ==1.1.1, + any.universe-instances-trans ==1.1, + any.universe-reverse-instances ==1.1, + any.universe-some ==1.2, + any.universum ==1.6.1, + any.unix-bytestring ==0.3.7.3, + any.unix-compat ==0.5.2, + any.unix-time ==0.4.7, + any.unliftio ==0.2.13, + any.unliftio-core ==0.1.2.0, + any.unliftio-pool ==0.2.1.1, + any.unlit ==0.4.0.0, + any.unordered-containers ==0.2.10.0, + any.unordered-intmap ==0.1.1, + any.unsafe ==0.0, + any.urbit-hob ==0.3.3, + any.uri-bytestring ==0.3.2.2, + any.uri-bytestring-aeson ==0.1.0.8, + any.uri-encode ==1.5.0.6, + any.url ==2.1.3, + any.users ==0.5.0.0, + any.utf8-conversions ==0.1.0.4, + any.utf8-light ==0.4.2, + any.utf8-string ==1.0.1.1, + any.util ==0.1.17.1, + any.utility-ht ==0.0.15, + any.uuid ==1.3.13, + any.uuid-types ==1.0.3, + any.validation ==1.1, + any.validation-selective ==0.1.0.0, + any.validity ==0.11.0.0, + any.validity-aeson ==0.2.0.4, + any.validity-bytestring ==0.4.1.1, + any.validity-containers ==0.5.0.4, + any.validity-path ==0.4.0.1, + any.validity-primitive ==0.0.0.1, + any.validity-scientific ==0.2.0.3, + any.validity-text ==0.3.1.1, + any.validity-time ==0.3.0.0, + any.validity-unordered-containers ==0.2.0.3, + any.validity-uuid ==0.1.0.3, + any.validity-vector ==0.2.0.3, + any.valor ==0.1.0.0, + any.vault ==0.3.1.4, + any.vec ==0.3, + any.vector ==0.12.1.2, + any.vector-algorithms ==0.8.0.3, + any.vector-binary-instances ==0.2.5.1, + any.vector-buffer ==0.4.1, + any.vector-builder ==0.3.8, + any.vector-bytes-instances ==0.1.1, + any.vector-instances ==3.4, + any.vector-mmap ==0.0.3, + any.vector-rotcev ==0.1.0.0, + any.vector-sized ==1.4.2, + any.vector-space ==0.16, + any.vector-split ==1.0.0.2, + any.vector-th-unbox ==0.2.1.7, + any.verbosity ==0.4.0.0, + any.versions ==3.5.4, + any.vformat ==0.14.1.0, + any.vformat-aeson ==0.1.0.1, + any.vformat-time ==0.1.0.0, + any.void ==0.7.3, + any.vty ==5.28.2, + any.wai ==3.2.2.1, + any.wai-app-static ==3.1.7.2, + any.wai-conduit ==3.0.0.4, + any.wai-cors ==0.2.7, + any.wai-enforce-https ==0.0.2.1, + any.wai-eventsource ==3.0.0, + any.wai-extra ==3.0.29.2, + any.wai-handler-launch ==3.0.3.1, + any.wai-logger ==2.3.6, + any.wai-middleware-caching ==0.1.0.2, + any.wai-middleware-clacks ==0.1.0.1, + any.wai-middleware-gunzip ==0.0.2, + any.wai-middleware-static ==0.8.3, + any.wai-predicates ==1.0.0, + any.wai-route ==0.4.0, + any.wai-session ==0.3.3, + any.wai-slack-middleware ==0.2.0, + any.wai-websockets ==3.0.1.2, + any.warp ==3.3.13, + any.warp-grpc ==0.4.0.1, + any.warp-tls ==3.2.12, + any.warp-tls-uid ==0.2.0.6, + any.wave ==0.2.0, + any.wcwidth ==0.0.2, + any.webdriver ==0.9.0.1, + any.webex-teams-api ==0.2.0.1, + any.webex-teams-conduit ==0.2.0.1, + any.webex-teams-pipes ==0.2.0.1, + any.webrtc-vad ==0.1.0.3, + any.websockets ==0.12.7.1, + any.websockets-snap ==0.10.3.1, + any.weigh ==0.0.16, + any.wide-word ==0.1.1.1, + any.wikicfp-scraper ==0.1.0.11, + any.wild-bind ==0.1.2.6, + any.wild-bind-x11 ==0.2.0.10, + windns +allow-non-windows, + any.windns ==0.1.0.1, + any.with-location ==0.1.0, + any.with-utf8 ==1.0.2.1, + any.witherable-class ==0, + any.within ==0.1.1.0, + any.witness ==0.4, + any.wizards ==1.0.3, + any.wl-pprint-annotated ==0.1.0.1, + any.wl-pprint-console ==0.1.0.2, + any.wl-pprint-text ==1.2.0.1, + any.word-trie ==0.3.0, + any.word-wrap ==0.4.1, + any.word24 ==2.0.1, + any.word8 ==0.1.3, + any.world-peace ==1.0.2.0, + any.wrap ==0.0.0, + any.wreq ==0.5.3.2, + any.writer-cps-exceptions ==0.1.0.1, + any.writer-cps-mtl ==0.1.1.6, + any.writer-cps-transformers ==0.5.6.1, + any.wss-client ==0.3.0.0, + any.wuss ==1.1.17, + any.x11-xim ==0.0.9.0, + any.x509 ==1.7.5, + any.x509-system ==1.6.6, + any.x509-validation ==1.6.11, + any.xdg-basedir ==0.2.2, + any.xdg-desktop-entry ==0.1.1.1, + any.xdg-userdirs ==0.1.0.2, + any.xeno ==0.4.2, + any.xls ==0.1.3, + any.xlsx ==0.8.1, + any.xlsx-tabular ==0.2.2.1, + any.xml ==1.3.14, + any.xml-basic ==0.1.3.1, + any.xml-conduit ==1.9.0.0, + any.xml-conduit-writer ==0.1.1.2, + any.xml-hamlet ==0.5.0.1, + any.xml-helpers ==1.0.0, + any.xml-html-qq ==0.1.0.1, + any.xml-indexed-cursor ==0.1.1.0, + any.xml-lens ==0.2, + any.xml-picklers ==0.3.6, + any.xml-to-json ==2.0.1, + any.xml-to-json-fast ==2.0.0, + any.xml-types ==0.3.8, + any.xmlgen ==0.6.2.2, + any.xmonad ==0.15, + any.xmonad-contrib ==0.16, + any.xmonad-extras ==0.15.2, + any.xss-sanitize ==0.3.6, + any.xturtle ==0.2.0.0, + any.xxhash-ffi ==0.2.0.0, + any.yaml ==0.11.5.0, + any.yamlparse-applicative ==0.1.0.1, + any.yes-precure5-command ==5.5.3, + any.yesod ==1.6.1.0, + any.yesod-auth ==1.6.10, + any.yesod-auth-fb ==1.10.1, + any.yesod-auth-hashdb ==1.7.1.2, + any.yesod-bin ==1.6.0.6, + any.yesod-core ==1.6.18, + any.yesod-fb ==0.6.1, + any.yesod-form ==1.6.7, + any.yesod-form-bootstrap4 ==3.0.0, + any.yesod-gitrev ==0.2.1, + any.yesod-newsfeed ==1.7.0.0, + any.yesod-persistent ==1.6.0.4, + any.yesod-recaptcha2 ==1.0.1, + any.yesod-sitemap ==1.6.0, + any.yesod-static ==1.6.1.0, + any.yesod-test ==1.6.10, + any.yesod-websockets ==0.3.0.2, + any.yi-rope ==0.11, + any.yjsvg ==0.2.0.1, + any.yjtools ==0.9.18, + any.yoga ==0.0.0.5, + any.youtube ==0.2.1.1, + any.zasni-gerna ==0.0.7.1, + any.zero ==0.1.5, + any.zeromq4-haskell ==0.8.0, + any.zeromq4-patterns ==0.3.1.0, + any.zim-parser ==0.2.1.0, + any.zip ==1.5.0, + any.zip-archive ==0.4.1, + any.zip-stream ==0.2.0.1, + any.zippers ==0.3, + any.zlib ==0.6.2.2, + any.zlib-bindings ==0.1.1.5, + any.zlib-lens ==0.1.2.1, + any.zot ==0.0.3, + any.zstd ==0.1.2.0 diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index 80def916765..169a860900a 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2021-10-28-federation-M1" + tag: "2021-11-01-production.0-v0.28.29-0-d919633" service: https: externalPort: 443 diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index 543dc2d8c3c..62e6ce5685f 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -243,6 +243,11 @@ http { proxy_pass http://brig; } + location /list-connections { + include common_response_with_zauth.conf; + proxy_pass http://brig; + } + location ~* ^/teams/([^/]+)/search$ { include common_response_with_zauth.conf; proxy_pass http://brig; diff --git a/direnv.nix b/direnv.nix index c29ac40da57..65fb8cada9d 100644 --- a/direnv.nix +++ b/direnv.nix @@ -6,14 +6,17 @@ let src = if pkgs.stdenv.isDarwin - then pkgs.fetchurl { - url = darwinAmd64Url; - sha256 = darwinAmd64Sha256; - } - else pkgs.fetchurl { - url = linuxAmd64Url; - sha256 = linuxAmd64Sha256; - }; + then + pkgs.fetchurl + { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else + pkgs.fetchurl { + url = linuxAmd64Url; + sha256 = linuxAmd64Sha256; + }; installPhase = '' mkdir -p $out/bin @@ -21,28 +24,31 @@ let ''; }; - staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: - pkgs.stdenv.mkDerivation { - inherit pname version; - - src = - if pkgs.stdenv.isDarwin - then pkgs.fetchurl { - url = darwinAmd64Url; - sha256 = darwinAmd64Sha256; - } - else pkgs.fetchurl { + staticBinary = { pname, version, linuxAmd64Url, linuxAmd64Sha256, darwinAmd64Url, darwinAmd64Sha256, binPath ? pname }: + pkgs.stdenv.mkDerivation { + inherit pname version; + + src = + if pkgs.stdenv.isDarwin + then + pkgs.fetchurl + { + url = darwinAmd64Url; + sha256 = darwinAmd64Sha256; + } + else + pkgs.fetchurl { url = linuxAmd64Url; sha256 = linuxAmd64Sha256; }; - phases = ["installPhase" "patchPhase"]; + phases = [ "installPhase" "patchPhase" ]; - installPhase = '' - mkdir -p $out/bin - cp $src $out/bin/${binPath} - chmod +x $out/bin/${binPath} - ''; - }; + installPhase = '' + mkdir -p $out/bin + cp $src $out/bin/${binPath} + chmod +x $out/bin/${binPath} + ''; + }; pinned = { stack = staticBinaryInTarball { @@ -102,18 +108,70 @@ let linuxAmd64Sha256 = "949f81b3c30ca03a3d4effdecda04f100fa3edc07a28b19400f72ede7c5f0491"; }; }; + + compile-deps = pkgs.buildEnv { + name = "wire-server-compile-deps"; + paths = [ + pkgs.bash + pkgs.coreutils + pkgs.gnused + pkgs.gnugrep + pkgs.pkgconfig + pkgs.gawk + pkgs.git + + pkgs.haskell.compiler.ghc884 + pkgs.protobuf + + pkgs.cryptobox + pkgs.geoip + pkgs.icu.dev + pkgs.icu.out + pkgs.libsodium.dev + pkgs.libsodium.out + pkgs.libxml2.dev + pkgs.libxml2.out + pkgs.ncurses.dev + pkgs.ncurses.out + pkgs.openssl.dev + pkgs.openssl.out + pkgs.pcre.dev + pkgs.pcre.out + pkgs.snappy.dev + pkgs.snappy.out + pkgs.zlib.dev + pkgs.zlib.out + pkgs.lzma.dev + pkgs.lzma.out + ]; + }; + + # This performs roughly the same setup as direnv's load_prefix function, but + # only when invoking cabal. This means that we can set LD_LIBRARY_PATH just + # for cabal, as setting it in direnv can interfere with programs in the host + # system, especially for non-NixOS users. + cabal-wrapper = pkgs.writeShellScriptBin "cabal" '' + export CPATH="${compile-deps}/include" + export LD_LIBRARY_PATH="${compile-deps}/lib" + export LIBRARY_PATH="${compile-deps}/lib" + export PKG_CONFIG_PATH="${compile-deps}/lib/pkgconfig" + export PATH="${compile-deps}/bin" + exec "${pkgs.cabal-install}/bin/cabal" "$@" + ''; in pkgs.buildEnv { name = "wire-server-direnv"; paths = [ + pkgs.cfssl pkgs.docker-compose pkgs.gnumake + pkgs.grpcurl pkgs.haskell-language-server - pkgs.telepresence pkgs.jq - pkgs.grpcurl + pkgs.ormolu + pkgs.telepresence pkgs.wget - pkgs.cfssl pkgs.yq + pkgs.rsync # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah @@ -123,6 +181,12 @@ in pkgs.buildEnv { pinned.helmfile pinned.kubectl pinned.kind + + # For cabal-migration + pkgs.haskellPackages.cabal-plan + + # We don't use pkgs.cabal-install here, as we invoke it with a wrapper + # which sets LD_LIBRARY_PATH and others correctly. + cabal-wrapper ]; } - diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index 3cd670834ed..878132cebfc 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -11,6 +11,32 @@ In addition to the information below, you can also consult the Dockerfiles for A ## General package dependencies (needed to compile Haskell services) +*Note: all the below sections for getting compile-time dependencies necessary to compile all of wire-server may potentially go out of date; if you spot a mistake please open an issue or PR* + +### Nix + Direnv + +Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system +dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. + +If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. +You can then run all the builds, and the native dependencies will be automatically present. + +1. Install [Nix](https://nixos.org/download.html) + * MacOS users with a recent Mac might need to follow [these + instructions](https://nixos.org/nix/manual/#sect-macos-installation) + * Debian users can use their distro's `nix` package, and should remember + + to add their user to the `nix-users` group in /etc/group, and re-start + their login session. +2. Install [Direnv](https://direnv.net/). + * On debian, you can install the `direnv` package. On MacOS use `brew install direnv`. + * On NixOS with home-manager, you can set `programs.direnv.enable = true;`. + * Make sure direnv is hooked into your shell via it's appripriate `rc` file. + Add `eval "$(direnv hook bash|zsh|fish)"` to your ~/.(bash|zsh|fish)rc . + * When successfully installed and hooked, direnv should ask you to `direnv allow` + the current `.envrc` when you cd to this repository. + See the [Installation documentation](https://direnv.net/docs/installation.html) for further details. + ### Fedora: ```bash @@ -22,7 +48,7 @@ sudo dnf install -y pkgconfig haskell-platform libstdc++-devel libstdc++-static _Note_: Debian is not recommended due to this issue when running local integration tests: [#327](https://github.com/wireapp/wire-server/issues/327). This issue does not occur with Ubuntu. ```bash -sudo apt install pkg-config libsodium-dev openssl-dev libtool automake build-essential libicu-dev libsnappy-dev libgeoip-dev protobuf-compiler libxml2-dev zlib1g-dev libtinfo-dev liblzma-dev -y +sudo apt install pkg-config libsodium-dev openssl-dev libtool automake build-essential libicu-dev libsnappy-dev libgeoip-dev protobuf-compiler libxml2-dev zlib1g-dev libtinfo-dev liblzma-dev libpcre3 libpcre3-dev -y ``` If `openssl-dev` does not work for you, try `libssl-dev`. @@ -63,7 +89,13 @@ sudo installer -pkg /Library/Developer/CommandLineTools/Packages/macOS_SDK_heade Please refer to [Stack's installation instructions](https://docs.haskellstack.org/en/stable/README/#how-to-install). -When you're done, ensure `stack --version` is recent, ideally the same as `STACK_ALPINE_VERSION` in [`build/alpine/Dockerfile.prebuilder`](../../build/alpine/Dockerfile.prebuilder). +When you're done, ensure `stack --version` is the same as `STACK_ALPINE_VERSION` in [`build/alpine/Dockerfile.prebuilder`](../../build/alpine/Dockerfile.prebuilder). + +If you have to, you can downgrade stack with this command: + +```bash +stack upgrade --binary-version +``` ### Ubuntu / Debian _Note_: The packaged versions of `haskell-stack` are too old. It is recommended to follow the generic instructions or to use stack to update stack (`stack upgrade`). @@ -174,14 +206,6 @@ docker login --username= * [Install docker](https://docker.com) * [Install docker-compose](https://docs.docker.com/compose/install/) -## Nix + Direnv - -Using Stack's [Nix integration](https://docs.haskellstack.org/en/stable/nix_integration/), Stack will take care of installing any system -dependencies automatically - including `cryptobox-c`. If new system dependencies are needed, add them to the `stack-deps.nix` file in the project root. - -If you have `direnv` and `nix`, you will automatically have `make`, `docker-compose` and `stack` in `PATH` once you `cd` into the project root and `direnv allow`. -You can then run all the builds, and the native dependencies will be automatically present. - ## Telepresence You can instead use [telepresence](https://www.telepresence.io) to allow you to talk to services installed in a given kubernetes namespace on a local or remote kubernetes cluster using easy DNS names like: `curl http://elasticsearch:9200`. diff --git a/docs/developer/how-to.md b/docs/developer/how-to.md index 5cac999e3e8..aa2a42b7f89 100644 --- a/docs/developer/how-to.md +++ b/docs/developer/how-to.md @@ -2,22 +2,6 @@ The following assume you have a working developer environment with all the dependencies listed in [./dependencies.md](./dependencies.md) available to you. - - -* [How to look at the swagger docs / UI locally](#how-to-look-at-the-swagger-docs--ui-locally) -* [How to run federation tests across two backends](#how-to-run-federation-tests-across-two-backends) - * [(1) Inspect/change the multi-backend test code](#1-inspectchange-the-multi-backend-test-code) - * [(2) Decide on code version](#2-decide-on-code-version) - * [(A) Use the latest compiled code from `develop`](#a-use-the-latest-compiled-code-from-develop) - * [Troubleshooting](#troubleshooting) - * [(B) Use code from your pull request](#b-use-code-from-your-pull-request) - * [(C) Use your local code](#c-use-your-local-code) - * [(3) Run multi-backend tests](#3-run-multi-backend-tests) - * [Run all integration tests on kubernetes](#run-all-integration-tests-on-kubernetes) - * [Run only the multi-backend tests](#run-only-the-multi-backend-tests) - - - ## How to look at the swagger docs / UI locally Terminal 1: @@ -25,6 +9,7 @@ Terminal 1: Terminal 2: * Compile all services: `make services` + * Note that you have to [import the public signing keys for nginx](../../services/nginz/README.md#common-problems-while-compiling) to be able to build nginz * Run services including nginz: `export INTEGRATION_USE_NGINZ=1; ./services/start-services-only.sh` Open your browser at: @@ -44,24 +29,25 @@ Requirements: The process consists of: 1. Inspect/change the multi-backend tests -2. Decide on code to use by means of using docker images made available by CI, or making docker images available yourself. +2. Deploy two backends to kubernetes cluster 3. Run multi-backend test half-locally half-on-kubernetes or fully on kubernetes +4. Teardown -### (1) Inspect/change the multi-backend test code +### 1. Inspect/change the multi-backend test code Refer to `services/brig/test/integration/API/Federation/End2End.hs` for the current multi-backend tests. *Note that they only run if `INTEGRATION_FEDERATION_TESTS` is set to `1`. This is currently configured to be OFF when running regular brig integration tests (e.g. via `make -C services/brig integration`) but is by default ON when running tests on kubernetes or on CI, or when using the `services/brig/federation-tests.sh` script.* -### (2) Decide on code version +### 2. Deploy two backends to kubernetes cluster -Decide which code you would like to use for these tests by setting the `DOCKER_TAG` environment variable. The following options are detailed in the subsections below. +Decide which code you would like to deploy. The following options are detailed in the subsections below. -* (A) latest develop -* (B) latest commit on a given PR branch -* (C) local code +* 2.1 Deploy the the latest compiled code from `develop` +* 2.2 Deploy code from your pull request +* 2.3 Deploy your local code to a kind cluster -#### (A) Use the latest compiled code from `develop` +#### 2.1 Deploy the the latest compiled code from `develop` First, find the latest CI-compiled code made available as docker images: @@ -84,30 +70,37 @@ Let's assume the tags are the same(*) for both, then export an environment varia ``` export DOCKER_TAG=2.104.11 +export NAMESPACE="myname" +make kube-integration-setup ``` +This will create two full installations of wire-server on the kubernetes cluster you've configured to connect to, and should take ~10 minutes. The namespaces will be `$NAMESPACE` and `$NAMESPACE-fed2`. + + ##### Troubleshooting `make latest-tag` gives different tags for brig and nginz: * maybe CI hasn't finished, or failed. Look at concourse (`kubernetes-dev` pipeline) -#### (B) Use code from your pull request +#### 2.2 Deploy code from your pull request *Note: CI already runs multi-backend federation integration tests on your PR, so this section may not be often useful in practice. This is still documented for completeness and to help understand the relation between source code and compiled docker images on CI.* Check CI for the latest tag that has been created on your PR (expect this to take at least 30-60 minutes from the last time you pushed to your branch). Example: -Look at a successful job in the `wire-server-pr` pipeline from a job build matching your desired PR and commit hash. Then, find the actual docker tag used. +Look at a successful job in the `wire-server-pr` pipeline from a job bruild matching your desired PR and commit hash. Then, find the actual docker tag used. ![concourse-pr-version-circled](https://user-images.githubusercontent.com/2112744/114410146-69b34000-9bab-11eb-863c-106fb661ca82.png) ``` # PR 1438 commit 7a183b2dbcf019df1af3d3b97604edac72eca762 translates to export DOCKER_TAG=0.0.1-pr.3684 +export NAMESPACE="myname" +make kube-integration-setup ``` -#### (C) Use your local code and kind +#### 2.3 Deploy your local code to a kind cluster This can be useful to get quicker feedback while working on multi-backend code or configuration (e.g. helm charts) than to wait an hour for CI. This allows you to test code without uploading it to github and waiting an hour for CI. @@ -130,17 +123,36 @@ FUTUREWORK: this process is in development (update this section after it's confi NOTE: debug this process further as some images (e.g. nginz) are missing from the default buildah steps. * Implement re-tagging development tags as your user tag? -### (3) Run multi-backend tests +#### 2.4 Deploy your local code to a kubernetes cluster -Once you have chosen the code to test and set `DOCKER_TAG` accordingly, run the following, which will create two full installations of wire-server on the kubernetes cluster you've configured to connect to, and should take ~10 minutes. +This sections describes how partially update a release with a local build of a service, in this example `brig`. + +Start by deploying a published release (see 2.1 or 2.2). ``` +export NAMESPACE=$USER +export DOCKER_TAG=2.116.32 make kube-integration-setup ``` -Next, you can choose to either run all integration tests, which also includes running the multi-backend integration tests by default. Or you can instead choose to *only* run the multi-backend tests. +Then build and push the `brig` image by running + +``` +export DOCKER_TAG_LOCAL_BUILD=$USER +hack/bin/buildah-compile.sh +DOCKER_TAG=$DOCKER_TAG_LOCAL_BUILD EXECUTABLES=brig BUILDAH_PUSH=1 ./hack/bin/buildah-make-images.sh +``` + +To update the release with brig's local image run +``` +./hack/bin/set-chart-image-version.sh "$DOCKER_TAG_LOCAL_BUILD" brig +./hack/bin/integration-setup-federation.sh +``` + -#### Run all integration tests on kubernetes +## 3 Run multi-backend tests + +### Run all integration tests on kubernetes * takes ~10 minutes to run * test output is delayed until all tests have run. You will have to scroll the output to find the relevant multi-backend test output. @@ -151,7 +163,7 @@ Next, you can choose to either run all integration tests, which also includes ru make kube-integration-test ``` -#### Run only the multi-backend tests +### Run only the multi-backend tests * runs faster (~ half a minute) * test output is shown dynamically as tests run @@ -162,7 +174,7 @@ make kube-integration-test 3. Run the actual tests, (takes half a minute): ``` -./services/brig/federation-tests.sh test-$USER +./services/brig/federation-tests.sh "$NAMESPACE" ``` Note that this runs your *locally* compiled `brig-integration`, so this allows to easily change test code locally with the following process: @@ -170,3 +182,13 @@ Note that this runs your *locally* compiled `brig-integration`, so this allows t 1. change code under `services/brig/test/integration/Federation/` 2. recompile: `make -C services/brig fast` 3. run `./services/brig/federation-tests.sh test-$USER` again. + +## 4 Teardown + +To destroy all the resources on the kubernetes cluster that have been created run + +``` +./hack/bin/integration-teardown-federation.sh +``` + +Note: Simply deleting the namespaces is insufficient, because it leaves some resources (of kind ClusterRole, ClusterRoleBinding) that cause problems when redeploying to the same namespace via helm. diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 5df3899b420..7b70e2f4642 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -422,6 +422,8 @@ CREATE TABLE galley_test.team_features ( file_sharing int, legalhold_status int, search_visibility_status int, + self_deleting_messages_status int, + self_deleting_messages_ttl int, sso_status int, validate_saml_emails int ) WITH bloom_filter_fp_chance = 0.1 diff --git a/hack/bin/cabal-install-all-artefacts.sh b/hack/bin/cabal-install-all-artefacts.sh new file mode 100755 index 00000000000..2087b655b32 --- /dev/null +++ b/hack/bin/cabal-install-all-artefacts.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +for d in $(find "$TOP_LEVEL" -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 dirname); do + cd "$d" + "$DIR/cabal-install-artefacts.sh" "$(basename "$d")" +done diff --git a/hack/bin/cabal-install-artefacts.sh b/hack/bin/cabal-install-artefacts.sh new file mode 100755 index 00000000000..215f7f868bf --- /dev/null +++ b/hack/bin/cabal-install-artefacts.sh @@ -0,0 +1,9 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +DIST="$TOP_LEVEL/dist" + +cabal-plan list-bins "$1"':exe:*' | awk '{print $2}' | xargs -I '{}' rsync -a {} "$DIST" diff --git a/hack/bin/cabal-project-local-template.sh b/hack/bin/cabal-project-local-template.sh new file mode 100755 index 00000000000..de45ddfd694 --- /dev/null +++ b/hack/bin/cabal-project-local-template.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +cd "$TOP_LEVEL" + +package_options=$1 + +local_projects=$(find . -name '*.cabal' | grep -v dist-newstyle | xargs -n 1 basename | sed 's|.cabal||g' | sort) + +for project in $local_projects; do + echo "package $project + $package_options" +done diff --git a/hack/bin/cabal-run-all-tests.sh b/hack/bin/cabal-run-all-tests.sh new file mode 100755 index 00000000000..7d84637417f --- /dev/null +++ b/hack/bin/cabal-run-all-tests.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +find "$TOP_LEVEL" -name '*.cabal' | + grep -v dist-newstyle | + xargs -n 1 dirname | + xargs -n 1 basename | + xargs -n 1 "$DIR/cabal-run-tests.sh" diff --git a/hack/bin/cabal-run-tests.sh b/hack/bin/cabal-run-tests.sh new file mode 100755 index 00000000000..7364ea40fa2 --- /dev/null +++ b/hack/bin/cabal-run-tests.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash +set -euo pipefail + +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +TOP_LEVEL="$(cd "$DIR/../.." && pwd)" + +pkgName=${1:-Please specify package name} + +# This is required because some tests (e.g. golden tests) depend on the path +# where they are run from. +pkgDir=$(find "$TOP_LEVEL" -name "$pkgName.cabal" | grep -v dist-newstyle | head -1 | xargs -n 1 dirname) +cd "$pkgDir" + +cabal-plan list-bins "$pkgName"':test:*' | awk '{print $2}' | xargs --no-run-if-empty -n 1 bash -c diff --git a/hack/bin/nix-hls.sh b/hack/bin/nix-hls.sh index 488cc122e6e..9b633f5e460 100755 --- a/hack/bin/nix-hls.sh +++ b/hack/bin/nix-hls.sh @@ -5,6 +5,8 @@ set -euo pipefail DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" TOP_LEVEL="$(cd "$DIR/../.." && pwd)" -env=$(nix-build --no-out-link "$PWD/direnv.nix") -export PATH="$env/bin:$PATH" +env=$(nix-build --no-out-link "$TOP_LEVEL/direnv.nix") +eval "$(direnv stdlib)" +load_prefix "$env" + haskell-language-server-wrapper "$@" diff --git a/hack/bin/set-chart-image-version.sh b/hack/bin/set-chart-image-version.sh new file mode 100755 index 00000000000..966a96c7c9d --- /dev/null +++ b/hack/bin/set-chart-image-version.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash + +USAGE="$0 ..." +docker_tag=${1?$USAGE} +charts=${@:2} + +TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" +CHARTS_DIR="$TOP_LEVEL/.local/charts" + +for chart in $charts +do +if [[ "$chart" == "nginz" ]]; then + # nginz has a different docker tag indentation + sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" +else + sed -i "s/ tag: .*/ tag: $docker_tag/g" "$CHARTS_DIR/$chart/values.yaml" +fi +done diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index b5d12a05cb0..9166df1bd79 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/libs/bilge/src/Bilge/IO.hs @@ -91,7 +91,7 @@ data Debug Full deriving (Eq, Ord, Show, Enum) -type Http a = HttpT IO a +type Http = HttpT IO newtype HttpT m a = HttpT { unwrap :: ReaderT Manager m a diff --git a/libs/bilge/src/Bilge/RPC.hs b/libs/bilge/src/Bilge/RPC.hs index 04cb232ec31..8e91f0880f4 100644 --- a/libs/bilge/src/Bilge/RPC.hs +++ b/libs/bilge/src/Bilge/RPC.hs @@ -45,6 +45,9 @@ import System.Logger.Class class HasRequestId m where getRequestId :: m RequestId +instance Monad m => HasRequestId (ReaderT RequestId m) where + getRequestId = ask + data RPCException = RPCException { rpceRemote :: !LText, rpceRequest :: !Request, diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index a26223c7aa4..d68adc82518 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: 9a030e92940be80f5ff4f31e38dbbddc2d24567f1114953edf9924cf61f9c43f +-- hash: 0e7f101562d82c7e04fbc1824f5bc9ef427915eacf3bd7370a2412a016a022be name: cassandra-util version: 0.16.5 @@ -35,6 +35,7 @@ library aeson >=0.7 , base >=4.6 && <5.0 , conduit + , containers , cql >=3.0.0 , cql-io >=0.14 , cql-io-tinylog diff --git a/libs/cassandra-util/package.yaml b/libs/cassandra-util/package.yaml index ca9dc4318b5..cb0241dc840 100644 --- a/libs/cassandra-util/package.yaml +++ b/libs/cassandra-util/package.yaml @@ -12,6 +12,7 @@ dependencies: - aeson >=0.7 - base >=4.6 && <5.0 - conduit +- containers - cql >=3.0.0 - cql-io >=0.14 - cql-io-tinylog diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 2b166cc9b4c..cb479bf5abd 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -26,8 +26,8 @@ import Cassandra.CQL as C ( Ascii (Ascii), BatchType (BatchLogged, BatchUnLogged), Blob (Blob), - ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn), - Consistency (All, One, Quorum), + ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn, VarCharColumn), + Consistency (All, LocalQuorum, One), -- DO NOT EXPORT 'Quorum' here (until a DC migration is complete) Cql, Keyspace (Keyspace), PagingState (..), @@ -38,6 +38,7 @@ import Cassandra.CQL as C Set (Set), Tagged (Tagged), TimeUuid (TimeUuid), + Tuple (), Value (CqlAscii, CqlBigInt, CqlBlob, CqlBoolean, CqlDouble, CqlInt, CqlList, CqlText, CqlUdt), Version (V4), W, diff --git a/libs/cassandra-util/src/Cassandra/CQL.hs b/libs/cassandra-util/src/Cassandra/CQL.hs index 058b6a5bd41..c0e29560691 100644 --- a/libs/cassandra-util/src/Cassandra/CQL.hs +++ b/libs/cassandra-util/src/Cassandra/CQL.hs @@ -25,8 +25,8 @@ import Database.CQL.Protocol as C ( Ascii (Ascii), BatchType (BatchLogged, BatchUnLogged), Blob (Blob), - ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn), - Consistency (All, One, Quorum), + ColumnType (AsciiColumn, BigIntColumn, BlobColumn, BooleanColumn, DoubleColumn, IntColumn, ListColumn, MaybeColumn, TextColumn, TimestampColumn, UdtColumn, UuidColumn, VarCharColumn), + Consistency (All, LocalQuorum, One), -- DO NOT EXPORT 'Quorum' here (until a DC migration is complete) Cql, Keyspace (Keyspace), PagingState (..), @@ -37,6 +37,7 @@ import Database.CQL.Protocol as C Set (Set), Tagged (Tagged), TimeUuid (TimeUuid), + Tuple (), Value (CqlAscii, CqlBigInt, CqlBlob, CqlBoolean, CqlDouble, CqlInt, CqlList, CqlText, CqlTimestamp, CqlUdt), Version (V4), W, diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index f11c0b7a6c2..ae289828c0d 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -23,6 +23,8 @@ module Cassandra.Settings ( module C, initialContactsDisco, initialContactsPlain, + dcAwareRandomPolicy, + dcFilterPolicyIfConfigured, ) where @@ -30,10 +32,11 @@ import Control.Lens import Data.Aeson.Lens import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (pack, stripSuffix, unpack) -import Database.CQL.IO as C (Policy, Settings, addContact, defSettings, setCompression, setConnectTimeout, setContacts, setIdleTimeout, setKeyspace, setLogger, setMaxConnections, setMaxStreams, setMaxTimeouts, setPolicy, setPoolStripes, setPortNumber, setPrepareStrategy, setProtocolVersion, setResponseTimeout, setRetrySettings, setSendTimeout) +import Database.CQL.IO as C hiding (values) import Database.CQL.IO.Tinylog as C (mkLogger) import Imports import Network.Wreq +import qualified System.Logger as Log -- | This function is likely only useful at Wire, as it is Wire-infra specific. -- Given a server name and a url returning a wire-custom "disco" json (AWS describe-instances-like json), e.g. @@ -62,3 +65,25 @@ initialContactsDisco (pack -> srv) url = liftIO $ do -- | Puts the address into a list using the same signature as the other initialContacts initialContactsPlain :: MonadIO m => Text -> m (NonEmpty String) initialContactsPlain address = pure $ unpack address :| [] + +-- | Use dcAwareRandomPolicy if config option filterNodesByDatacentre is set, +-- otherwise use all available nodes with the default random policy. +-- +-- This is only useful during a cassandra datacentre migration. +dcFilterPolicyIfConfigured :: Log.Logger -> Maybe Text -> IO Policy +dcFilterPolicyIfConfigured lgr mDatacentre = do + Log.info lgr $ + Log.msg ("Using the following cassandra load balancing options ('Policy'):" :: Text) + . Log.field "filter_datacentre" (show mDatacentre) + maybe random dcAwareRandomPolicy mDatacentre + +-- | Return hosts in random order for a given DC. +-- +-- This is only useful during a cassandra datacentre migration. +dcAwareRandomPolicy :: Text -> IO Policy +dcAwareRandomPolicy dc = do + randomPolicy <- C.random + pure $ randomPolicy {acceptable = dcAcceptable} + where + dcAcceptable :: Host -> IO Bool + dcAcceptable host = pure $ (host ^. dataCentre) == dc diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index fb7d933f708..4c7304bccc2 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 866e03ca5b340b2470e8f7b376b18824786b15873330f6fd8483de086cfae28d +-- hash: 65015665656bc1ae721971ef3e88ed707aa7a2be02ba04cf4aab39ac6188714a name: extended version: 0.1.0 @@ -36,12 +36,13 @@ library aeson , base , bytestring - , cql-io + , cassandra-util , errors , exceptions , extra , http-types , imports + , metrics-wai , optparse-applicative , servant , servant-server diff --git a/libs/extended/package.yaml b/libs/extended/package.yaml index 4ba1de39d18..aa4cdd43ab9 100644 --- a/libs/extended/package.yaml +++ b/libs/extended/package.yaml @@ -21,12 +21,13 @@ dependencies: - imports - optparse-applicative - tinylog -- cql-io - exceptions +- cassandra-util # for servant's 'ReqBodyCustomError' type defined here. - errors - http-types +- metrics-wai - servant - servant-server - servant-swagger diff --git a/libs/extended/src/Servant/API/Extended.hs b/libs/extended/src/Servant/API/Extended.hs index 4b69d1561fe..90e1a8516fa 100644 --- a/libs/extended/src/Servant/API/Extended.hs +++ b/libs/extended/src/Servant/API/Extended.hs @@ -23,6 +23,7 @@ module Servant.API.Extended where import qualified Data.ByteString.Lazy as BL import Data.EitherR (fmapL) +import Data.Metrics.Servant import Data.String.Conversions (cs) import Data.Typeable import GHC.TypeLits @@ -113,3 +114,6 @@ instance HasSwagger (ReqBodyCustomError cts tag a :> api) where toSwagger Proxy = toSwagger (Proxy @(ReqBody' '[Required, Strict] cts a :> api)) + +instance RoutesToPaths rest => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where + getRoutes = getRoutes @rest diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 352e344cfc3..4c9787ee26b 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -31,13 +31,13 @@ module System.Logger.Extended ) where +import Cassandra (MonadClient) import Control.Monad.Catch import Data.Aeson import Data.Aeson.Encoding (list, pair, text) import qualified Data.ByteString.Lazy.Builder as B import qualified Data.ByteString.Lazy.Char8 as L import Data.String.Conversions (cs) -import Database.CQL.IO import GHC.Generics import Imports import System.Logger as Log diff --git a/libs/galley-types/src/Galley/Types/Conversations/Members.hs b/libs/galley-types/src/Galley/Types/Conversations/Members.hs index 42a3fb9ddad..cd172988eb1 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Members.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Members.hs @@ -22,6 +22,8 @@ module Galley.Types.Conversations.Members remoteMemberToOther, LocalMember (..), localMemberToOther, + newMember, + newMemberWithRole, MemberStatus (..), defMemberStatus, ) @@ -32,7 +34,7 @@ import Data.Id as Id import Data.Qualified import Imports import Wire.API.Conversation -import Wire.API.Conversation.Role (RoleName) +import Wire.API.Conversation.Role (RoleName, roleNameWireAdmin) import Wire.API.Provider.Service (ServiceRef) -- | Internal (cassandra) representation of a remote conversation member. @@ -59,6 +61,18 @@ data LocalMember = LocalMember } deriving stock (Show) +newMember :: UserId -> LocalMember +newMember u = newMemberWithRole (u, roleNameWireAdmin) + +newMemberWithRole :: (UserId, RoleName) -> LocalMember +newMemberWithRole (u, r) = + LocalMember + { lmId = u, + lmService = Nothing, + lmStatus = defMemberStatus, + lmConvRoleName = r + } + localMemberToOther :: Domain -> LocalMember -> OtherMember localMemberToOther domain x = OtherMember diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index bcbc0ce3ecc..8e727e90a1d 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -31,6 +31,7 @@ module Galley.Types.Teams flagAppLockDefaults, flagClassifiedDomains, flagConferenceCalling, + flagSelfDeletingMessages, Defaults (..), unDefaults, FeatureSSO (..), @@ -214,7 +215,8 @@ data FeatureFlags = FeatureFlags _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'TeamFeatureAppLock)), _flagClassifiedDomains :: !(TeamFeatureStatus 'TeamFeatureClassifiedDomains), _flagFileSharing :: !(Defaults (TeamFeatureStatus 'TeamFeatureFileSharing)), - _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)) + _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'TeamFeatureConferenceCalling)), + _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) } deriving (Eq, Show, Generic) @@ -260,9 +262,10 @@ instance FromJSON FeatureFlags where <*> (fromMaybe defaultClassifiedDomains <$> (obj .:? "classifiedDomains")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "fileSharing")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) + <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) instance ToJSON FeatureFlags where - toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling) = + toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling selfDeletingMessages) = object $ [ "sso" .= sso, "legalhold" .= legalhold, @@ -270,7 +273,8 @@ instance ToJSON FeatureFlags where "appLock" .= appLock, "classifiedDomains" .= classifiedDomains, "fileSharing" .= fileSharing, - "conferenceCalling" .= conferenceCalling + "conferenceCalling" .= conferenceCalling, + "selfDeletingMessages" .= selfDeletingMessages ] instance FromJSON FeatureSSO where @@ -362,6 +366,7 @@ roleHiddenPermissions role = HiddenPermissions p p ChangeTeamFeature TeamFeatureAppLock, ChangeTeamFeature TeamFeatureFileSharing, ChangeTeamFeature TeamFeatureClassifiedDomains {- the features not listed here can only be changed in stern -}, + ChangeTeamFeature TeamFeatureSelfDeletingMessages, ReadIdp, CreateUpdateDeleteIdp, CreateReadDeleteScimToken, @@ -381,6 +386,7 @@ roleHiddenPermissions role = HiddenPermissions p p ViewTeamFeature TeamFeatureFileSharing, ViewTeamFeature TeamFeatureClassifiedDomains, ViewTeamFeature TeamFeatureConferenceCalling, + ViewTeamFeature TeamFeatureSelfDeletingMessages, ViewLegalHoldUserSettings, ViewTeamSearchVisibility ] diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index 73791c71a6e..3ed957c77d0 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -96,3 +96,4 @@ instance Arbitrary FeatureFlags where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/libs/metrics-wai/metrics-wai.cabal b/libs/metrics-wai/metrics-wai.cabal index 3631c86077f..7658bf9348a 100644 --- a/libs/metrics-wai/metrics-wai.cabal +++ b/libs/metrics-wai/metrics-wai.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 1fdffa4b08c579feb0c18fe4c3c12c81ee6c503b5672735f7df5a02e02081c67 +-- hash: aefa1a394ca2caa5cad577e67967aace67b79d4c94afeba4dd399b77de826a6c name: metrics-wai version: 0.5.7 @@ -40,6 +40,7 @@ library , imports , metrics-core >=0.3 , servant + , servant-multipart , string-conversions , text >=0.11 , wai >=3 @@ -70,6 +71,7 @@ test-suite unit , metrics-core >=0.3 , metrics-wai , servant + , servant-multipart , string-conversions , text >=0.11 , wai >=3 diff --git a/libs/metrics-wai/package.yaml b/libs/metrics-wai/package.yaml index 85b90bb530a..75e681fd7aa 100644 --- a/libs/metrics-wai/package.yaml +++ b/libs/metrics-wai/package.yaml @@ -16,6 +16,7 @@ dependencies: - metrics-core >=0.3 - containers - servant +- servant-multipart - string-conversions - text >=0.11 - wai >=3 diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index b1398b9cb4c..1bcac5d86e1 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -40,6 +40,7 @@ import Network.Wai.Middleware.Prometheus import qualified Network.Wai.Middleware.Prometheus as Promth import Network.Wai.Routing (Routes, prepare) import Servant.API +import Servant.Multipart -- | This does not catch errors, so it must be called outside of 'WU.catchErrors'. servantPrometheusMiddleware :: forall proxy api. (RoutesToPaths api) => proxy api -> Wai.Middleware @@ -79,27 +80,59 @@ class RoutesToPaths routes where -- "seg" :> routes instance - {-# OVERLAPPING #-} - ( KnownSymbol seg, - RoutesToPaths segs - ) => + (KnownSymbol seg, RoutesToPaths segs) => RoutesToPaths (seg :> segs) where getRoutes = [Node (Right . cs $ symbolVal (Proxy @seg)) (getRoutes @segs)] -- :> routes instance - {-# OVERLAPPING #-} - ( KnownSymbol capture, - RoutesToPaths segs - ) => + (KnownSymbol capture, RoutesToPaths segs) => RoutesToPaths (Capture' mods capture a :> segs) where getRoutes = [Node (Left (cs (":" <> symbolVal (Proxy @capture)))) (getRoutes @segs)] +instance + (RoutesToPaths rest) => + RoutesToPaths (Header' mods name a :> rest) + where + getRoutes = getRoutes @rest + +instance + (RoutesToPaths rest) => + RoutesToPaths (ReqBody' mods cts a :> rest) + where + getRoutes = getRoutes @rest + +instance + (RoutesToPaths rest) => + RoutesToPaths (Summary summary :> rest) + where + getRoutes = getRoutes @rest + +instance + RoutesToPaths rest => + RoutesToPaths (QueryParam' mods name a :> rest) + where + getRoutes = getRoutes @rest + +instance RoutesToPaths rest => RoutesToPaths (MultipartForm tag a :> rest) where + getRoutes = getRoutes @rest + +instance + RoutesToPaths rest => + RoutesToPaths (Description desc :> rest) + where + getRoutes = getRoutes @rest + +instance RoutesToPaths (Verb method status cts a) where + getRoutes = [] + +instance RoutesToPaths (NoContentVerb method) where + getRoutes = [] + -- route :<|> routes instance - {-# OVERLAPPING #-} ( RoutesToPaths route, RoutesToPaths routes ) => @@ -107,13 +140,5 @@ instance where getRoutes = getRoutes @route <> getRoutes @routes -instance - {-# OVERLAPPABLE #-} - ( RoutesToPaths segs - ) => - RoutesToPaths (anything :> segs) - where - getRoutes = getRoutes @segs - -instance {-# OVERLAPPABLE #-} RoutesToPaths anything where +instance RoutesToPaths Raw where getRoutes = [] diff --git a/libs/types-common-journal/package.yaml b/libs/types-common-journal/package.yaml deleted file mode 100644 index f6d0f4d1309..00000000000 --- a/libs/types-common-journal/package.yaml +++ /dev/null @@ -1,40 +0,0 @@ -defaults: - local: ../../package-defaults.yaml -name: types-common-journal -version: '0.1.0' -synopsis: Shared protobuf type definitions. -description: Shared protobuf type definitions for journaling. -category: System -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2017 Wire Swiss GmbH -license: AGPL-3 -extra-source-files: -- proto/TeamEvents.proto -- proto/UserEvents.proto -ghc-options: -- -fno-warn-redundant-constraints -dependencies: -- base ==4.* -- bytestring -- imports -- proto-lens-runtime -- time -- types-common -- uuid -library: - source-dirs: src - ghc-prof-options: -fprof-auto-exported - exposed-modules: - # do not remove this list! stack won't be able to generate it from the protobuf source files! - - Data.Proto - - Data.Proto.Id - - Proto.TeamEvents - - Proto.TeamEvents_Fields - - Proto.UserEvents - - Proto.UserEvents_Fields -custom-setup: - dependencies: - - base - - Cabal - - proto-lens-setup diff --git a/libs/types-common-journal/types-common-journal.cabal b/libs/types-common-journal/types-common-journal.cabal index 8f0490851d6..f804fd9991d 100644 --- a/libs/types-common-journal/types-common-journal.cabal +++ b/libs/types-common-journal/types-common-journal.cabal @@ -1,10 +1,10 @@ -cabal-version: 1.24 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: e1935f392440ca2f304ef17fbfe551f6cda9b616b15272792df66ed83e01123b +-- hash: 00a76393f405b068d1b0ffe0c3d0f59370b3ad9ac10a9c0bc08f5abe721bc351 name: types-common-journal version: 0.1.0 @@ -42,6 +42,8 @@ library default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fno-warn-redundant-constraints ghc-prof-options: -fprof-auto-exported + build-tool-depends: + proto-lens-protoc:proto-lens-protoc build-depends: base ==4.* , bytestring @@ -51,3 +53,8 @@ library , types-common , uuid default-language: Haskell2010 + autogen-modules: + Proto.TeamEvents + Proto.TeamEvents_Fields + Proto.UserEvents + Proto.UserEvents_Fields diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 4bce70e078a..fb89c8e86bb 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -21,6 +21,7 @@ module Data.Qualified ( -- * Qualified + QTag (..), Qualified (..), qToPair, QualifiedWithTag, diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index 33313e9a5ce..1897caa8e69 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -87,7 +87,13 @@ makeLenses ''Endpoint data CassandraOpts = CassandraOpts { _casEndpoint :: !Endpoint, - _casKeyspace :: !Text + _casKeyspace :: !Text, + -- | If this option is unset, use all available nodes. + -- If this option is set, use only cassandra nodes in the given datacentre + -- + -- This option is most likely only necessary during a cassandra DC migration + -- FUTUREWORK: remove this option again, or support a datacentre migration feature + _casFilterNodesByDatacentre :: !(Maybe Text) } deriving (Show, Generic) @@ -156,27 +162,6 @@ parseConfigPath defaultPath desc = do parseAWSEndpoint :: ReadM AWSEndpoint parseAWSEndpoint = readerAsk >>= maybe (error "Could not parse AWS endpoint") return . fromByteString . fromString -cassandraParser :: Parser CassandraOpts -cassandraParser = - CassandraOpts - <$> ( Endpoint - <$> ( textOption $ - long "cassandra-host" - <> metavar "HOSTNAME" - <> help "Cassandra hostname or address" - ) - <*> ( option auto $ - long "cassandra-port" - <> metavar "PORT" - <> help "Cassandra port" - ) - ) - <*> ( textOption $ - long "cassandra-keyspace" - <> metavar "STRING" - <> help "Cassandra keyspace" - ) - discoUrlParser :: Parser Text discoUrlParser = textOption $ diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 423c7788a59..cb2cfc2522f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -20,6 +20,7 @@ module Wire.API.Federation.Client where +import Control.Monad.Catch import Control.Monad.Except (ExceptT, MonadError (..), withExceptT) import Control.Monad.State (MonadState (..), StateT, evalStateT, gets) import Data.ByteString.Builder (toLazyByteString) @@ -27,13 +28,13 @@ import qualified Data.ByteString.Lazy as LBS import Data.Domain (Domain, domainText) import qualified Data.Text as T import Imports -import Mu.GRpc.Client.TyApps (GRpcMessageProtocol (MsgProtoBuf), GRpcReply (..), GrpcClient, gRpcCall, grpcClientConfigSimple) +import Mu.GRpc.Client.TyApps import qualified Network.HTTP.Types as HTTP import Servant.Client (ResponseF (..)) import qualified Servant.Client as Servant import Servant.Client.Core (RequestBody (..), RequestF (..), RunClient (..)) import Util.Options (Endpoint (..)) -import Wire.API.Federation.GRPC.Client (createGrpcClient, reason) +import Wire.API.Federation.GRPC.Client import qualified Wire.API.Federation.GRPC.Types as Proto -- FUTUREWORK: Remove originDomain from here and make it part of all the API @@ -50,7 +51,10 @@ newtype FederatorClient (component :: Proto.Component) m a = FederatorClient {ru deriving newtype (Functor, Applicative, Monad, MonadReader FederatorClientEnv, MonadState (Maybe ByteString), MonadIO) runFederatorClientWith :: Monad m => GrpcClient -> Domain -> Domain -> FederatorClient component m a -> m a -runFederatorClientWith client targetDomain originDomain = flip evalStateT Nothing . flip runReaderT (FederatorClientEnv client targetDomain originDomain) . runFederatorClient +runFederatorClientWith client targetDomain originDomain = + flip evalStateT Nothing + . flip runReaderT (FederatorClientEnv client targetDomain originDomain) + . runFederatorClient class KnownComponent (c :: Proto.Component) where componentVal :: Proto.Component @@ -123,6 +127,7 @@ data FederationError | FederationNotImplemented | FederationNotConfigured | FederationCallFailure FederationClientFailure + | FederationUnexpectedBody Text deriving (Show, Eq, Typeable) instance Exception FederationError @@ -167,11 +172,12 @@ mkFederatorClient = do >>= either (throwError . FederationUnavailable . reason) pure executeFederated :: - (MonadIO m, HasFederatorConfig m) => + (MonadIO m, MonadMask m, HasFederatorConfig m) => Domain -> FederatorClient component (ExceptT FederationClientFailure m) a -> ExceptT FederationError m a executeFederated targetDomain action = do - federatorClient <- mkFederatorClient originDomain <- lift federationDomain - withExceptT FederationCallFailure (runFederatorClientWith federatorClient targetDomain originDomain action) + bracket mkFederatorClient closeGrpcClient $ \federatorClient -> + withExceptT FederationCallFailure $ + runFederatorClientWith federatorClient targetDomain originDomain action diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 6aa875b608a..8b363936164 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -76,6 +76,7 @@ federationErrorToWai (FederationCallFailure failure) = addErrorData $ Wai.federrPath = T.decodeUtf8 (fedFailPath failure) } } +federationErrorToWai (FederationUnexpectedBody s) = federationUnexpectedBody s noFederationStatus :: Status noFederationStatus = status403 diff --git a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs index ec6a2aa44c1..5e745e85240 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/GRPC/Client.hs @@ -18,11 +18,13 @@ module Wire.API.Federation.GRPC.Client ( GrpcClientErr (..), createGrpcClient, + closeGrpcClient, grpcClientError, ) where import Control.Exception +import Control.Monad.Except import qualified Data.Text as T import Imports import Mu.GRpc.Client.Record (setupGrpcClient') @@ -41,6 +43,11 @@ createGrpcClient cfg = do Right (Left err) -> Left (grpcClientError (Just cfg) err) Right (Right client) -> Right client +-- | Close federator client and ignore errors, since the only possible error +-- here is EarlyEndOfStream, which should not concern us at this point. +closeGrpcClient :: MonadIO m => GrpcClient -> m () +closeGrpcClient = void . liftIO . runExceptT . close + grpcClientError :: Exception e => Maybe GrpcClientConfig -> e -> GrpcClientErr grpcClientError mcfg err = GrpcClientErr . T.pack $ diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 9d813db174d..b69330dc9ff 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -8,16 +8,20 @@ author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2020 Wire Swiss GmbH license: AGPL-3 + dependencies: - aeson >=0.6 -- containers >=0.5 -- imports -- types-common >=0.16 -- servant-swagger-ui - case-insensitive +- containers >=0.5 +- filepath - hscim +- imports +- metrics-wai - saml2-web-sso -- filepath +- servant +- servant-swagger-ui +- types-common >=0.16 + library: source-dirs: src dependencies: @@ -62,7 +66,6 @@ library: - QuickCheck >=2.14 - quickcheck-instances >=0.3.16 - resourcet - - servant - servant-client - servant-client-core - servant-multipart @@ -83,6 +86,7 @@ library: - wire-message-proto-lens - x509 - wai + tests: wire-api-tests: main: Main.hs @@ -121,3 +125,41 @@ tests: - vector - wire-api - wire-message-proto-lens + + wire-api-golden-tests: + main: Main.hs + source-dirs: test/golden + ghc-options: + - -threaded + - -with-rtsopts=-N + dependencies: + - aeson-qq + - aeson-pretty + - base + - bytestring + - bytestring-conversion + - cassava + - currency-codes + - directory + - iso3166-country-codes + - iso639 + - lens + - mime + - pem + - pretty + - proto-lens + - QuickCheck + - string-conversions + - swagger2 + - tasty + - tasty-expected-failure + - tasty-hunit + - tasty-quickcheck + - text + - time + - unordered-containers + - uri-bytestring + - uuid + - vector + - wire-api + - wire-message-proto-lens diff --git a/libs/wire-api/src/Wire/API/Conversation/Action.hs b/libs/wire-api/src/Wire/API/Conversation/Action.hs index a7bf22c23b2..9080c867328 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Action.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Action.hs @@ -34,8 +34,7 @@ import Wire.API.Conversation.Role import Wire.API.Event.Conversation import Wire.API.Util.Aeson (CustomEncoded (..)) --- | An update to a conversation, including addition and removal of members. --- Used to send notifications to users and to remote backends. +-- | A sum type consisting of all possible conversation actions. data ConversationAction = ConversationActionAddMembers (NonEmpty (Qualified UserId)) RoleName | ConversationActionRemoveMembers (NonEmpty (Qualified UserId)) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 11f28240723..ca896ff1462 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -3,6 +3,7 @@ module Wire.API.ErrorDescription where import Control.Lens (at, (%~), (.~), (<>~), (?~)) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS +import Data.Metrics.Servant import Data.SOP (I (..), NP (..), NS (..)) import Data.Schema import Data.Swagger (Swagger) @@ -45,6 +46,9 @@ instance route _ = route (Proxy @api) hoistServerWithContext _ = hoistServerWithContext (Proxy @api) +instance RoutesToPaths api => RoutesToPaths (CanThrow err :> api) where + getRoutes = getRoutes @api + errorDescriptionAddToSwagger :: forall (code :: Nat) (label :: Symbol) (desc :: Symbol). (KnownStatus code, KnownSymbol label, KnownSymbol desc) => @@ -226,10 +230,13 @@ noIdentity n = ErrorDescription (Text.pack (symbolVal (Proxy @desc)) <> " (code type OperationDenied = ErrorDescription 403 "operation-denied" "Insufficient permissions" -operationDenied :: Show perm => perm -> OperationDenied -operationDenied p = +operationDeniedSpecialized :: String -> OperationDenied +operationDeniedSpecialized p = ErrorDescription $ - "Insufficient permissions (missing " <> Text.pack (show p) <> ")" + "Insufficient permissions (missing " <> Text.pack p <> ")" + +operationDenied :: Show perm => perm -> OperationDenied +operationDenied = operationDeniedSpecialized . show type NotATeamMember = ErrorDescription 403 "no-team-member" "Requesting user is not a team member" diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index d6177821af1..d64dac272f6 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -30,7 +30,7 @@ import Data.Json.Util (ToJSONObject (..)) import Data.Schema import qualified Data.Swagger as S import Imports -import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureStatusNoConfig, TeamFeatureStatusWithConfig) +import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureSelfDeletingMessagesConfig, TeamFeatureStatusNoConfig, TeamFeatureStatusWithConfig) data Event = Event { _eventType :: EventType, @@ -53,6 +53,7 @@ data EventData = EdFeatureWithoutConfigChanged TeamFeatureStatusNoConfig | EdFeatureApplockChanged (TeamFeatureStatusWithConfig TeamFeatureAppLockConfig) | EdFeatureClassifiedDomainsChanged (TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig) + | EdFeatureSelfDeletingMessagesChanged (TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig) deriving (Eq, Show, Generic) makePrisms ''EventData @@ -73,6 +74,7 @@ taggedEventDataSchema = TeamFeatureFileSharing -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureClassifiedDomains -> tag _EdFeatureClassifiedDomainsChanged (unnamed schema) TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema) + TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema) eventObjectSchema :: ObjectSchema SwaggerDoc Event eventObjectSchema = diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index be89caee6c5..79b9f508253 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -47,6 +47,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Containers.ListUtils import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import Data.Metrics.Servant import Data.Proxy import Data.SOP import qualified Data.Sequence as Seq @@ -633,3 +634,6 @@ instance method = reflectMethod (Proxy @method) hoistClientMonad _ _ f = f + +instance RoutesToPaths (MultiVerb method cs as r) where + getRoutes = [] diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 9dcf9066518..f52a0cc0fe9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -23,6 +23,7 @@ module Wire.API.Routes.Public where import Control.Lens ((<>~)) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id as Id +import Data.Metrics.Servant import Data.Swagger import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol) @@ -94,6 +95,9 @@ instance hoistServerWithContext _ pc nt s = Servant.hoistServerWithContext (Proxy @(InternalAuth ztype opts :> api)) pc nt s +instance RoutesToPaths api => RoutesToPaths (ZAuthServant ztype opts :> api) where + getRoutes = getRoutes @api + -- FUTUREWORK: Make a PR to the servant-swagger package with this instance instance ToSchema a => ToSchema (Headers ls a) where declareNamedSchema _ = declareNamedSchema (Proxy @a) @@ -116,3 +120,6 @@ instance HasServer api ctx => HasServer (OmitDocs :> api) ctx where route _ = route (Proxy :: Proxy api) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s + +instance RoutesToPaths api => RoutesToPaths (OmitDocs :> api) where + getRoutes = getRoutes @api diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 41cd9d2ae17..136c82de3a9 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -601,6 +601,7 @@ data Api routes = Api '[Servant.JSON] (PostOtrResponses MessageSendingStatus) (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus), + -- team features teamFeatureStatusSSOGet :: routes :- FeatureStatusGet 'TeamFeatureSSO, @@ -652,6 +653,12 @@ data Api routes = Api teamFeatureStatusConferenceCallingGet :: routes :- FeatureStatusGet 'TeamFeatureConferenceCalling, + teamFeatureStatusSelfDeletingMessagesGet :: + routes + :- FeatureStatusGet 'TeamFeatureSelfDeletingMessages, + teamFeatureStatusSelfDeletingMessagesPut :: + routes + :- FeatureStatusPut 'TeamFeatureSelfDeletingMessages, featureAllFeatureConfigsGet :: routes :- AllFeatureConfigsGet, @@ -681,7 +688,10 @@ data Api routes = Api :- FeatureConfigGet 'TeamFeatureClassifiedDomains, featureConfigConferenceCallingGet :: routes - :- FeatureConfigGet 'TeamFeatureConferenceCalling + :- FeatureConfigGet 'TeamFeatureConferenceCalling, + featureConfigSelfDeletingMessagesGet :: + routes + :- FeatureConfigGet 'TeamFeatureSelfDeletingMessages } deriving (Generic) diff --git a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs b/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs index 9e4f2ab24c6..78febbd5799 100644 --- a/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs +++ b/libs/wire-api/src/Wire/API/Routes/QualifiedCapture.hs @@ -22,6 +22,7 @@ module Wire.API.Routes.QualifiedCapture where import Data.Domain +import Data.Metrics.Servant import Data.Qualified import Data.Swagger import GHC.TypeLits @@ -96,3 +97,11 @@ instance clientWithRoute pm _ req (Qualified value domain) = clientWithRoute pm (Proxy @(WithDomain mods capture a api)) req domain value hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy @api) f . cl + +instance (RoutesToPaths api, KnownSymbol (AppendSymbol capture "_domain"), KnownSymbol capture) => RoutesToPaths (QualifiedCapture' mods capture a :> api) where + getRoutes = + getRoutes + @( Capture' mods (AppendSymbol capture "_domain") Domain + :> Capture' mods capture a + :> api + ) diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 17f75474c8a..f746c3465c3 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -128,6 +128,7 @@ models = Team.Feature.modelForTeamFeature Team.Feature.TeamFeatureClassifiedDomains, Team.Feature.modelTeamFeatureAppLockConfig, Team.Feature.modelTeamFeatureClassifiedDomainsConfig, + Team.Feature.modelTeamFeatureSelfDeletingMessagesConfig, Team.Invitation.modelTeamInvitation, Team.Invitation.modelTeamInvitationList, Team.Invitation.modelTeamInvitationRequest, diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index c943a4db1e0..f466fe3102c 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -22,6 +22,7 @@ module Wire.API.Team.Feature ( TeamFeatureName (..), TeamFeatureStatus, TeamFeatureAppLockConfig (..), + TeamFeatureSelfDeletingMessagesConfig (..), TeamFeatureClassifiedDomainsConfig (..), TeamFeatureStatusValue (..), FeatureHasNoConfig, @@ -33,6 +34,7 @@ module Wire.API.Team.Feature AllFeatureConfigs (..), defaultAppLockStatus, defaultClassifiedDomains, + defaultSelfDeletingMessagesStatus, -- * Swagger typeTeamFeatureName, @@ -41,6 +43,7 @@ module Wire.API.Team.Feature modelTeamFeatureStatusWithConfig, modelTeamFeatureAppLockConfig, modelTeamFeatureClassifiedDomainsConfig, + modelTeamFeatureSelfDeletingMessagesConfig, modelForTeamFeature, ) where @@ -90,10 +93,13 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) -- * services/galley/test/integration/API/Teams/Feature.hs -- * add an integration test for the feature -- * extend testAllFeatures +-- * consider personal-account configurability (like for `conferenceCalling`, see +-- eg. https://github.com/wireapp/wire-server/pull/1811, +-- https://github.com/wireapp/wire-server/pull/1818) -- --- --- An overview of places to change (including compiler errors and failing tests) can be found --- in eg. https://github.com/wireapp/wire-server/pull/1652. +-- An example of all the places to change (including compiler errors and failing tests) can be found +-- in eg. https://github.com/wireapp/wire-server/pull/1652. (applock and conference calling also +-- add interesting aspects, though.) -- -- Using something like '[minBound..]' on those expressions would require dependent types. We -- could generate exhaustive lists of those calls using TH, along the lines of: @@ -119,6 +125,7 @@ data TeamFeatureName | TeamFeatureFileSharing | TeamFeatureClassifiedDomains | TeamFeatureConferenceCalling + | TeamFeatureSelfDeletingMessages deriving stock (Eq, Show, Ord, Generic, Enum, Bounded, Typeable) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -162,6 +169,10 @@ instance KnownTeamFeatureName 'TeamFeatureConferenceCalling where type KnownTeamFeatureNameSymbol 'TeamFeatureConferenceCalling = "conferenceCalling" knownTeamFeatureName = TeamFeatureConferenceCalling +instance KnownTeamFeatureName 'TeamFeatureSelfDeletingMessages where + type KnownTeamFeatureNameSymbol 'TeamFeatureSelfDeletingMessages = "selfDeletingMessages" + knownTeamFeatureName = TeamFeatureSelfDeletingMessages + instance FromByteString TeamFeatureName where parser = Parser.takeByteString >>= \b -> @@ -179,6 +190,7 @@ instance FromByteString TeamFeatureName where Right "fileSharing" -> pure TeamFeatureFileSharing Right "classifiedDomains" -> pure TeamFeatureClassifiedDomains Right "conferenceCalling" -> pure TeamFeatureConferenceCalling + Right "selfDeletingMessages" -> pure TeamFeatureSelfDeletingMessages Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t -- TODO: how do we make this consistent with 'KnownTeamFeatureNameSymbol'? add a test for @@ -193,6 +205,7 @@ instance ToByteString TeamFeatureName where builder TeamFeatureFileSharing = "fileSharing" builder TeamFeatureClassifiedDomains = "classifiedDomains" builder TeamFeatureConferenceCalling = "conferenceCalling" + builder TeamFeatureSelfDeletingMessages = "selfDeletingMessages" instance ToSchema TeamFeatureName where schema = @@ -280,6 +293,7 @@ type family TeamFeatureStatus (a :: TeamFeatureName) :: * where TeamFeatureStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig TeamFeatureStatus 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig TeamFeatureStatus 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig type FeatureHasNoConfig (a :: TeamFeatureName) = (TeamFeatureStatus a ~ TeamFeatureStatusNoConfig) :: Constraint @@ -294,6 +308,7 @@ modelForTeamFeature name@TeamFeatureAppLock = modelTeamFeatureStatusWithConfig n modelForTeamFeature TeamFeatureFileSharing = modelTeamFeatureStatusNoConfig modelForTeamFeature name@TeamFeatureClassifiedDomains = modelTeamFeatureStatusWithConfig name modelTeamFeatureClassifiedDomainsConfig modelForTeamFeature TeamFeatureConferenceCalling = modelTeamFeatureStatusNoConfig +modelForTeamFeature name@TeamFeatureSelfDeletingMessages = modelTeamFeatureStatusWithConfig name modelTeamFeatureSelfDeletingMessagesConfig ---------------------------------------------------------------------- -- TeamFeatureStatusNoConfig @@ -409,6 +424,33 @@ defaultAppLockStatus = TeamFeatureEnabled (TeamFeatureAppLockConfig (EnforceAppLock False) 60) +---------------------------------------------------------------------- +-- TeamFeatureSelfDeletingMessagesConfig + +data TeamFeatureSelfDeletingMessagesConfig = TeamFeatureSelfDeletingMessagesConfig + { sdmEnforcedTimeoutSeconds :: Int32 + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema TeamFeatureSelfDeletingMessagesConfig) + deriving (Arbitrary) via (GenericUniform TeamFeatureSelfDeletingMessagesConfig) + +instance ToSchema TeamFeatureSelfDeletingMessagesConfig where + schema = + object "TeamFeatureSelfDeletingMessagesConfig" $ + TeamFeatureSelfDeletingMessagesConfig + <$> sdmEnforcedTimeoutSeconds .= field "enforcedTimeoutSeconds" schema + +modelTeamFeatureSelfDeletingMessagesConfig :: Doc.Model +modelTeamFeatureSelfDeletingMessagesConfig = + Doc.defineModel "TeamFeatureSelfDeletingMessagesConfig" $ do + Doc.property "enforcedTimeoutSeconds" Doc.int32' $ Doc.description "optional; default: `0` (no enforcement)" + +defaultSelfDeletingMessagesStatus :: TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig +defaultSelfDeletingMessagesStatus = + TeamFeatureStatusWithConfig + TeamFeatureEnabled + (TeamFeatureSelfDeletingMessagesConfig 0) + ---------------------------------------------------------------------- -- internal diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 7a98a355eb4..e5cb2e78f07 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -213,7 +213,6 @@ data UserProfile = UserProfile -- i.e. it is a "bot". profileService :: Maybe ServiceRef, profileHandle :: Maybe Handle, - profileLocale :: Maybe Locale, profileExpire :: Maybe UTCTimeMillis, profileTeam :: Maybe TeamId, profileEmail :: Maybe Email, @@ -238,7 +237,6 @@ instance ToSchema UserProfile where .= fmap (fromMaybe False) (opt (field "deleted" schema)) <*> profileService .= opt (field "service" schema) <*> profileHandle .= opt (field "handle" schema) - <*> profileLocale .= opt (field "locale" schema) <*> profileExpire .= opt (field "expires_at" schema) <*> profileTeam .= opt (field "team" schema) <*> profileEmail .= opt (field "email" schema) @@ -429,7 +427,6 @@ connectedProfile u legalHoldStatus = profileAssets = userAssets u, profileAccentId = userAccentId u, profileService = userService u, - profileLocale = Just (userLocale u), profileDeleted = userDeleted u, profileExpire = userExpire u, profileTeam = userTeam u, @@ -459,8 +456,7 @@ publicProfile u legalHoldStatus = profileLegalholdStatus } = connectedProfile u legalHoldStatus in UserProfile - { profileLocale = Nothing, - profileEmail = Nothing, + { profileEmail = Nothing, profileQualifiedId, profileHandle, profileName, diff --git a/libs/wire-api/src/Wire/API/User/Saml.hs b/libs/wire-api/src/Wire/API/User/Saml.hs index c9b21fdf3a0..7c7c99fed5a 100644 --- a/libs/wire-api/src/Wire/API/User/Saml.hs +++ b/libs/wire-api/src/Wire/API/User/Saml.hs @@ -88,6 +88,7 @@ substituteVar' var val = ST.intercalate val . ST.splitOn var type Opts = Opts' DerivedOpts +-- FUTUREWORK: Shouldn't these types be in spar, not in wire-api? data Opts' a = Opts { saml :: !SAML.Config, brig :: !Endpoint, diff --git a/libs/wire-api/test/golden/Main.hs b/libs/wire-api/test/golden/Main.hs new file mode 100644 index 00000000000..fc3112b0939 --- /dev/null +++ b/libs/wire-api/test/golden/Main.hs @@ -0,0 +1,39 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Main + ( main, + ) +where + +import Imports +import Test.Tasty +import qualified Test.Wire.API.Golden.FromJSON as Golden.FromJSON +import qualified Test.Wire.API.Golden.Generated as Golden.Generated +import qualified Test.Wire.API.Golden.Manual as Golden.Manual +import qualified Test.Wire.API.Golden.Protobuf as Golden.Protobuf + +main :: IO () +main = + defaultMain $ + testGroup + "Tests" + [ Golden.Generated.tests, + Golden.Manual.tests, + Golden.FromJSON.tests, + Golden.Protobuf.tests + ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/FromJSON.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AccessRole_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRole_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AccessRole_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRole_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AccessToken_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessToken_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AccessToken_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessToken_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Access_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Access_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Access_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Access_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Action_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Action_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Action_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Action_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Activate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Activate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Activate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Activate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationKey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationKey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationKey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationKey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AddBotResponse_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AddBotResponse_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AddBotResponse_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AddBotResponse_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AddBot_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AddBot_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AddBot_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AddBot_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AppName_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AppName_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AppName_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AppName_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ApproveLegalHoldForUserRequest_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ApproveLegalHoldForUserRequest_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ApproveLegalHoldForUserRequest_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ApproveLegalHoldForUserRequest_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetKey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetKey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetKey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetKey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetRetention_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetRetention_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetRetention_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetRetention_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetSettings_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetSettings_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetSettings_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetSettings_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetSize_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetSize_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetSize_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetSize_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetToken_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetToken_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/AssetToken_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AssetToken_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Asset_asset.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Asset_asset.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BindingNewTeamUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BindingNewTeamUser_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BindingNewTeamUser_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BindingNewTeamUser_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BindingNewTeam_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BindingNewTeam_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BindingNewTeam_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BindingNewTeam_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BotConvView_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotConvView_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BotConvView_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotConvView_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BotUserView_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/BotUserView_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/BotUserView_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CheckHandles_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CheckHandles_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CheckHandles_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CheckHandles_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ChunkSize_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ChunkSize_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ChunkSize_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ChunkSize_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientClass_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientClass_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientClass_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientClass_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientMismatch_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientMismatch_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientMismatch_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientMismatch_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientPrekey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientPrekey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientPrekey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientPrekey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientType_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientType_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ClientType_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ClientType_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Client_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Client_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Client_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ColourId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ColourId_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ColourId_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ColourId_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CompletePasswordReset_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CompletePasswordReset_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CompletePasswordReset_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Connect_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Connect_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Connect_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConnectionRequest_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConnectionRequest_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConnectionRequest_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConnectionRequest_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConnectionUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConnectionUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConnectionUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConnectionUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Contact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Contact_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Contact_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Contact_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvMembers_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvMembers_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvMembers_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvType_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvType_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConvType_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvType_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationAccessData_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationAccessData_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationAccessData_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationAccessData_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationList_20Conversation_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20_28Id_20_2a_20C_29_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationList_20_28Id_20_2a_20C_29_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationList_20_28Id_20_2a_20C_29_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationList_20_28Id_20_2a_20C_29_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationMessageTimerUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationMessageTimerUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationMessageTimerUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationMessageTimerUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationReceiptModeUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationReceiptModeUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationReceiptModeUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationReceiptModeUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRename_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRename_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRename_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRename_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRole_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRole_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRole_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRole_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRolesList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRolesList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ConversationRolesList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConversationRolesList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Conversation_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Conversation_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieId_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieId_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieId_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieLabel_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieLabel_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieLabel_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieLabel_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieType_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieType_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CookieType_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CookieType_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Cookie_20_28_29_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Cookie_20_28_29_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Cookie_20_28_29_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Cookie_20_28_29_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CustomBackend_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CustomBackend_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/CustomBackend_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/CustomBackend_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteProvider_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteProvider_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteProvider_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteProvider_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteService_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteService_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteService_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteService_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteUser_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeleteUser_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeleteUser_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeletionCodeTimeout_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeletionCodeTimeout_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DeletionCodeTimeout_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DeletionCodeTimeout_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DisableLegalHoldForUserRequest_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DisableLegalHoldForUserRequest_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/DisableLegalHoldForUserRequest_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/DisableLegalHoldForUserRequest_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EmailUpdate_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EmailUpdate_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EmailUpdate_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EmailUpdate_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EmailUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EmailUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EmailUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EmailUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Email_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Email_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Email_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Email_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EventType_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EventType_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EventType_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EventType_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EventType_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EventType_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/EventType_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/EventType_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Event_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/HandleUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/HandleUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/HandleUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/HandleUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationList_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationRequest_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Invitation_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Invitation_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Invitation_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Invitation_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Invite_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Invite_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Invite_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Invite_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LastPrekey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LastPrekey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LastPrekey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LastPrekey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LegalHoldServiceConfirm_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LegalHoldServiceConfirm_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LegalHoldServiceConfirm_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LegalHoldServiceConfirm_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LegalHoldServiceRemove_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LegalHoldServiceRemove_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LegalHoldServiceRemove_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LegalHoldServiceRemove_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LimitedQualifiedUserIdList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LimitedQualifiedUserIdList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LimitedQualifiedUserIdList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LimitedQualifiedUserIdList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ListType_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ListType_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ListType_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ListType_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LocaleUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LocaleUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LocaleUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LocaleUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Locale_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Locale_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Locale_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Locale_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginCodeTimeout_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginCodeTimeout_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginCodeTimeout_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginCodeTimeout_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/LoginId_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LoginId_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Login_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Login_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ManagedBy_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ManagedBy_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ManagedBy_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ManagedBy_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MemberUpdateData_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MemberUpdateData_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MemberUpdateData_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MemberUpdateData_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MemberUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MemberUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MemberUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MemberUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Member_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Member_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Member_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MutedStatus_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MutedStatus_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/MutedStatus_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/MutedStatus_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NameUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NameUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NameUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NameUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Name_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Name_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Name_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Name_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewAssetToken_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewAssetToken_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewAssetToken_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewAssetToken_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotRequest_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewBotResponse_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotResponse_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewBotResponse_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewBotResponse_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewClient_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewClient_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewLegalHoldClient_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewLegalHoldClient_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewLegalHoldClient_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewLegalHoldClient_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewLegalHoldService_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewLegalHoldService_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewLegalHoldService_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewLegalHoldService_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewOtrMessage_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewOtrMessage_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewOtrMessage_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewOtrMessage_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewPasswordReset_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewProviderResponse_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewProviderResponse_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewProviderResponse_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewProviderResponse_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewProvider_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewProvider_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewProvider_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewProvider_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewServiceResponse_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewServiceResponse_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewServiceResponse_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewServiceResponse_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewService_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewService_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewService_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewService_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewTeamMember_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/NewUser_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Offset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Offset_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Offset_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Offset_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtherMemberUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtherMemberUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtherMemberUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtherMemberUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtherMember_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtherMember_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtherMember_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtherMember_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtrMessage_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtrMessage_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtrMessage_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtrMessage_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtrRecipients_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtrRecipients_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/OtrRecipients_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/OtrRecipients_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordChange_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordChange_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordChange_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordChange_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordChange_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordChange_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordChange_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordChange_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordResetCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordResetCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordResetCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordResetCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordResetKey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordResetKey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordResetKey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordResetKey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordReset_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordReset_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PasswordReset_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PasswordReset_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PendingLoginCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PendingLoginCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PendingLoginCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PendingLoginCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Permissions_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Permissions_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Permissions_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PhoneUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PhoneUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PhoneUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PhoneUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Phone_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Phone_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Phone_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Phone_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Pict_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Pict_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Pict_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Pict_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PrekeyBundle_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PrekeyBundle_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PrekeyBundle_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PrekeyBundle_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PrekeyId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PrekeyId_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PrekeyId_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PrekeyId_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Prekey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Prekey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Prekey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Prekey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Priority_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Priority_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Priority_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Priority_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PropertyKey_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PropertyKey_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PropertyKey_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PropertyKey_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PropertyValue_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PropertyValue_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PropertyValue_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PropertyValue_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderActivationResponse_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderActivationResponse_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderActivationResponse_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderActivationResponse_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderLogin_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderLogin_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderLogin_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderLogin_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderProfile_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderProfile_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ProviderProfile_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ProviderProfile_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Provider_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Provider_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Provider_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Provider_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PubClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PubClient_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PubClient_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PubClient_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PushTokenList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PushTokenList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PushTokenList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PushTokenList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PushToken_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PushToken_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/PushToken_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/PushToken_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Push_2eToken_2eTransport_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QualifiedNewOtrMessage_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QualifiedNewOtrMessage_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QualifiedNewOtrMessage_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QualifiedNewOtrMessage_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotificationList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/QueuedNotification_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ReceiptMode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ReceiptMode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ReceiptMode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ReceiptMode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Relation_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Relation_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Relation_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Relation_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveBotResponse_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveBotResponse_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveBotResponse_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveBotResponse_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveCookies_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveCookies_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveCookies_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveCookies_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveLegalHoldSettingsRequest_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveLegalHoldSettingsRequest_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RemoveLegalHoldSettingsRequest_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RemoveLegalHoldSettingsRequest_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RequestNewLegalHoldClient_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RequestNewLegalHoldClient_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RequestNewLegalHoldClient_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RequestNewLegalHoldClient_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableAsset_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ResumableSettings_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichField_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichField_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichField_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichField_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfoAssocList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfoAssocList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfoAssocList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfoAssocList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfoMapAndList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfoMapAndList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfoMapAndList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfoMapAndList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfo_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfo_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RichInfo_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RichInfo_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RmClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RmClient_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RmClient_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RmClient_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RoleName_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RoleName_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/RoleName_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RoleName_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Role_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Role_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Role_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Role_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SFTServer_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SFTServer_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SFTServer_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Scheme_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Scheme_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Scheme_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Scheme_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20Contact_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SearchResult_20TeamContact_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SelfProfile_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SelfProfile_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SelfProfile_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendActivationCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SendLoginCode_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendLoginCode_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SendLoginCode_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SendLoginCode_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKeyPEM_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKeyPEM_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKeyPEM_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKeyPEM_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKeyType_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKeyType_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKeyType_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKeyType_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKey_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKey_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceKey_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceKey_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceProfilePage_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceProfilePage_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceProfilePage_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceProfilePage_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceProfile_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceProfile_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceProfile_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceProfile_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceRef_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceRef_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceRef_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceRef_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceTagList_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceTagList_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceTagList_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceTagList_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceTag_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceTag_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceTag_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceTag_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceToken_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceToken_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ServiceToken_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ServiceToken_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Service_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Service_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Service_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Service_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SimpleMember_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SimpleMember_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SimpleMember_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SimpleMember_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SimpleMembers_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SimpleMembers_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/SimpleMembers_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SimpleMembers_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamBinding_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamBinding_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamBinding_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamBinding_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamContact_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamContact_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamContact_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamContact_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamConversation_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamConversation_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamDeleteData_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamDeleteData_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamDeleteData_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamDeleteData_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusNoConfig_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusNoConfig_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusNoConfig_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusNoConfig_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusValue_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusValue_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusValue_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusValue_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusWithConfig_20TeamFeatureAppLockConfig_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusWithConfig_20TeamFeatureAppLockConfig_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamFeatureStatusWithConfig_20TeamFeatureAppLockConfig_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamFeatureStatusWithConfig_20TeamFeatureAppLockConfig_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamList_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamList_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamList_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMemberDeleteData_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberDeleteData_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMemberDeleteData_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberDeleteData_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMemberList_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMember_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamMember_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamMember_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamSearchVisibilityView_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamSearchVisibilityView_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamSearchVisibilityView_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamSearchVisibilityView_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamSearchVisibility_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamSearchVisibility_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamSearchVisibility_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamSearchVisibility_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Team_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Team_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Team_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Team_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TokenType_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TokenType_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TokenType_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TokenType_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Token_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Token_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Token_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Token_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TotalSize_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TotalSize_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TotalSize_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TotalSize_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Transport_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Transport_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Transport_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Transport_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnHost_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnHost_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnHost_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnHost_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnURI_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnURI_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnURI_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnURI_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnUsername_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TurnUsername_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TypingData_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TypingData_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TypingData_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TypingData_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TypingStatus_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TypingStatus_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/TypingStatus_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TypingStatus_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateBotPrekeys_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateBotPrekeys_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateBotPrekeys_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateBotPrekeys_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateClient_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateClient_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateClient_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateProvider_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateProvider_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateProvider_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateProvider_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateServiceConn_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateServiceConn_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateServiceConn_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateServiceConn_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateServiceWhitelist_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateServiceWhitelist_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateServiceWhitelist_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateServiceWhitelist_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateService_provider.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateService_provider.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UpdateService_provider.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UpdateService_provider.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserClientMap_20Int_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserClientMap_20Int_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserClientMap_20Int_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserClientMap_20Int_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserClients_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserClients_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserClients_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserClients_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserConnectionList_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserConnectionList_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserConnectionList_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserConnectionList_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserConnection_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserConnection_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserConnection_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserConnection_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserHandleInfo_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserHandleInfo_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserHandleInfo_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserHandleInfo_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserIdentity_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserLegalHoldStatusResponse_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserLegalHoldStatusResponse_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserLegalHoldStatusResponse_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserLegalHoldStatusResponse_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs similarity index 91% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs index b9363e28b80..e1586dde396 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserProfile_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserProfile_user.hs @@ -20,10 +20,8 @@ module Test.Wire.API.Golden.Generated.UserProfile_user where import Data.Domain (Domain (Domain, _domainText)) import Data.Handle (Handle (Handle, fromHandle)) -import Data.ISO3166_CountryCodes (CountryCode (MU)) import Data.Id (Id (Id)) import Data.Json.Util (readUTCTimeMillis) -import qualified Data.LanguageCodes (ISO639_1 (NY)) import Data.LegalHold (UserLegalHoldStatus (..)) import Data.Qualified (Qualified (Qualified, qDomain, qUnqualified)) import qualified Data.UUID as UUID (fromString) @@ -31,10 +29,7 @@ import Imports (Bool (False, True), Maybe (Just, Nothing), fromJust) import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) import Wire.API.User ( ColourId (ColourId, fromColourId), - Country (Country, fromCountry), Email (Email, emailDomain, emailLocal), - Language (Language), - Locale (Locale, lCountry, lLanguage), Name (Name, fromName), Pict (Pict, fromPict), UserProfile (..), @@ -55,7 +50,6 @@ testObject_UserProfile_user_1 = profileDeleted = False, profileService = Nothing, profileHandle = Nothing, - profileLocale = Nothing, profileExpire = Nothing, profileTeam = Nothing, profileEmail = Nothing, @@ -89,8 +83,6 @@ testObject_UserProfile_user_2 = "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx" } ), - profileLocale = - Just (Locale {lLanguage = Language Data.LanguageCodes.NY, lCountry = Just (Country {fromCountry = MU})}), profileExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T01:42:22.437Z")), profileTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000200000002"))), profileEmail = Just (Email {emailLocal = "\172353 ", emailDomain = ""}), diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserSSOId_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserUpdate_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserUpdate_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/UserUpdate_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserUpdate_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/User_2eProfile_2eAsset_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_2eProfile_2eAsset_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/User_2eProfile_2eAsset_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_2eProfile_2eAsset_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/User_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/User_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/VerifyDeleteUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/VerifyDeleteUser_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/VerifyDeleteUser_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/VerifyDeleteUser_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ViewLegalHoldServiceInfo_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ViewLegalHoldServiceInfo_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ViewLegalHoldServiceInfo_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ViewLegalHoldServiceInfo_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ViewLegalHoldService_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ViewLegalHoldService_team.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/ViewLegalHoldService_team.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ViewLegalHoldService_team.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Wrapped_20_22some_5fint_22_20Int_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Wrapped_20_22some_5fint_22_20Int_user.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generated/Wrapped_20_22some_5fint_22_20Int_user.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Wrapped_20_22some_5fint_22_20Int_user.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Generator.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ClientCapability.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ClientCapability.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ClientCapability.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ClientCapability.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ClientCapabilityList.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ClientCapabilityList.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ClientCapabilityList.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ClientCapabilityList.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConvIdsPage.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConvIdsPage.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConvIdsPage.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConvIdsPage.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationCoverView.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationCoverView.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationCoverView.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationCoverView.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationPagingState.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationPagingState.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationPagingState.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationPagingState.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ConversationsResponse.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationsResponse.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/GetPaginatedConversationIds.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversations.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ListConversations.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/ListConversations.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ListConversations.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/QualifiedUserClientPrekeyMap.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/QualifiedUserClientPrekeyMap.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/QualifiedUserClientPrekeyMap.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/QualifiedUserClientPrekeyMap.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/UserClientPrekeyMap.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserIdList.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/UserIdList.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Manual/UserIdList.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/UserIdList.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Protobuf.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Protobuf.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Protobuf.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Protobuf.hs diff --git a/libs/wire-api/test/unit/Test/Wire/API/Golden/Runner.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs similarity index 100% rename from libs/wire-api/test/unit/Test/Wire/API/Golden/Runner.hs rename to libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs diff --git a/libs/wire-api/test/golden/testObject_UserProfile_user_2.json b/libs/wire-api/test/golden/testObject_UserProfile_user_2.json index 0e515e092a5..ed38b1acdff 100644 --- a/libs/wire-api/test/golden/testObject_UserProfile_user_2.json +++ b/libs/wire-api/test/golden/testObject_UserProfile_user_2.json @@ -7,7 +7,6 @@ "handle": "emsonpvo3-x_4ys4qjtjtkfgx.mag6pi2ldq.77m5vnsn_tte41r-0vwgklpeejr1t4se0bknu4tsuqs-njzh34-ba_mj8lm5x6aro4o.2wsqe0ldx", "id": "00000002-0000-0002-0000-000000000001", "legalhold_status": "no_consent", - "locale": "ny-MU", "name": "si4v󴃿\u001b^'ゟk喁\u0015?􈒳\u0000Bw;\u00083*R/𨄵lrI", "picture": [], "qualified_id": { diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 982dff2fca9..540037b6e0a 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -23,13 +23,10 @@ where import Imports import Test.Tasty import qualified Test.Wire.API.Call.Config as Call.Config -import qualified Test.Wire.API.Golden.FromJSON as Golden.FromJSON -import qualified Test.Wire.API.Golden.Generated as Golden.Generated -import qualified Test.Wire.API.Golden.Manual as Golden.Manual -import qualified Test.Wire.API.Golden.Protobuf as Golden.Protobuf 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 +import qualified Test.Wire.API.Routes as Routes import qualified Test.Wire.API.Swagger as Swagger import qualified Test.Wire.API.Team.Member as Team.Member import qualified Test.Wire.API.User as User @@ -50,8 +47,5 @@ main = Roundtrip.ByteString.tests, Swagger.tests, Roundtrip.CSV.tests, - Golden.Generated.tests, - Golden.Manual.tests, - Golden.FromJSON.tests, - Golden.Protobuf.tests + Routes.tests ] 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 97dc0e0aa3d..6e09181e543 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 @@ -204,6 +204,7 @@ tests = testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureFileSharing), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureClassifiedDomains), testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureConferenceCalling), + testRoundTrip @(Team.Feature.TeamFeatureStatus 'Team.Feature.TeamFeatureSelfDeletingMessages), testRoundTrip @Team.Feature.TeamFeatureStatusValue, testRoundTrip @Team.Invitation.InvitationRequest, testRoundTrip @Team.Invitation.Invitation, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Routes.hs b/libs/wire-api/test/unit/Test/Wire/API/Routes.hs new file mode 100644 index 00000000000..0c28074f69e --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Routes.hs @@ -0,0 +1,23 @@ +module Test.Wire.API.Routes where + +import Data.Metrics.Servant +import Data.Tree +import Imports +import Servant.API +import qualified Test.Tasty as T +import Test.Tasty.HUnit +import Wire.API.Routes.QualifiedCapture + +tests :: T.TestTree +tests = + T.testGroup "Routes" $ + [T.testGroup "QualifiedCapture" [testCase "must expose the captures in metrics" qualifiedCaptureMetrics]] + +type QualifiedCaptureAPI = "users" :> QualifiedCapture' '[] "uid" Int :> Get '[] Int + +qualifiedCaptureMetrics :: Assertion +qualifiedCaptureMetrics = + assertEqual + "match metrics path" + [Node (Right "users") [Node (Left ":uid_domain") [Node (Left ":uid") []]]] + (getRoutes @QualifiedCaptureAPI) diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index 86c4a0687fe..cea7b4f227e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -47,7 +47,7 @@ testUserProfile = do uid <- Id <$> UUID.nextRandom let domain = Domain "example.com" let colour = ColourId 0 - let userProfile = UserProfile (Qualified uid domain) (Name "name") (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent + let userProfile = UserProfile (Qualified uid domain) (Name "name") (Pict []) [] colour False Nothing Nothing Nothing Nothing Nothing UserLegalHoldNoConsent let profileJSONAsText = show $ Aeson.encode userProfile let msg = "toJSON encoding must not convert Nothing to null, but instead omit those json fields for backwards compatibility. UserProfileJSON:" <> profileJSONAsText assertBool msg (not $ "null" `isInfixOf` profileJSONAsText) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 623fa0c173f..0b9c20d7dc2 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 2d17ec32d1990b4f59c918291cd7a1286d20e5c54ad921ecd5eb9d01b4b9f1c8 +-- hash: f7a6c4eafbaab04b23ffb79fcde736cd8d0894f91c6ef1eace2de5b98d9a47e5 name: wire-api version: 0.1.0 @@ -142,6 +142,7 @@ library , iso639 >=0.1 , lens >=4.12 , memory + , metrics-wai , mime >=0.4 , mtl , pem >=0.2 @@ -175,11 +176,10 @@ library , x509 default-language: Haskell2010 -test-suite wire-api-tests +test-suite wire-api-golden-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Test.Wire.API.Call.Config Test.Wire.API.Golden.FromJSON Test.Wire.API.Golden.Generated Test.Wire.API.Golden.Generated.Access_user @@ -421,9 +421,64 @@ test-suite wire-api-tests Test.Wire.API.Golden.Manual.UserIdList Test.Wire.API.Golden.Protobuf Test.Wire.API.Golden.Runner + Paths_wire_api + hs-source-dirs: + test/golden + default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns + 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-pretty + , aeson-qq + , base + , bytestring + , bytestring-conversion + , case-insensitive + , cassava + , containers >=0.5 + , currency-codes + , directory + , filepath + , hscim + , imports + , iso3166-country-codes + , iso639 + , lens + , metrics-wai + , mime + , pem + , pretty + , proto-lens + , saml2-web-sso + , servant + , servant-swagger-ui + , string-conversions + , swagger2 + , tasty + , tasty-expected-failure + , tasty-hunit + , tasty-quickcheck + , text + , time + , types-common >=0.16 + , unordered-containers + , uri-bytestring + , uuid + , vector + , wire-api + , wire-message-proto-lens + default-language: Haskell2010 + +test-suite wire-api-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Test.Wire.API.Call.Config Test.Wire.API.Roundtrip.Aeson Test.Wire.API.Roundtrip.ByteString Test.Wire.API.Roundtrip.CSV + Test.Wire.API.Routes Test.Wire.API.Swagger Test.Wire.API.Team.Member Test.Wire.API.User @@ -453,11 +508,13 @@ test-suite wire-api-tests , iso3166-country-codes , iso639 , lens + , metrics-wai , mime , pem , pretty , proto-lens , saml2-web-sso + , servant , servant-swagger-ui , string-conversions , swagger2 diff --git a/libs/wire-message-proto-lens/package.yaml b/libs/wire-message-proto-lens/package.yaml deleted file mode 100644 index 54bfe246ea7..00000000000 --- a/libs/wire-message-proto-lens/package.yaml +++ /dev/null @@ -1,30 +0,0 @@ -defaults: - local: ../../package-defaults.yaml -name: wire-message-proto-lens -version: '0.1.0' -synopsis: Shared protobuf type definitions for Wire Messaging. -description: Shared protobuf type definitions for Wire Messaging. -category: System -author: Wire Swiss GmbH -maintainer: Wire Swiss GmbH -copyright: (c) 2021 Wire Swiss GmbH -license: AGPL-3 -extra-source-files: -- generic-message-proto/proto/otr.proto -ghc-options: -- -fno-warn-redundant-constraints -dependencies: -- base -- proto-lens-runtime -library: - source-dirs: . - ghc-prof-options: -fprof-auto-exported - exposed-modules: - # do not remove this list! stack won't be able to generate it from the protobuf source files! - - Proto.Otr - - Proto.Otr_Fields -custom-setup: - dependencies: - - base - - Cabal - - proto-lens-setup diff --git a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal index a4e5644e15b..cb9e559b95c 100644 --- a/libs/wire-message-proto-lens/wire-message-proto-lens.cabal +++ b/libs/wire-message-proto-lens/wire-message-proto-lens.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.24 +cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.33.0. -- @@ -39,4 +39,8 @@ library build-depends: base , proto-lens-runtime + build-tool-depends: proto-lens-protoc:proto-lens-protoc default-language: Haskell2010 + autogen-modules: + Proto.Otr + Proto.Otr_Fields diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0b10a5456a0..8544b86ac5b 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 3f6cdbdd5b65f096b8f3e838b1009c4a1a0dd5e295304d123a4ad90ebcdf2057 +-- hash: 67fbb228d01b995595cb10594e0e80b0ca794cb9ecabcd5ed8f5a894c8881de7 name: brig version: 1.35.0 @@ -324,7 +324,6 @@ executable brig-integration , cassandra-util , containers , cookie - , cql-io , data-timeout , email-validate , exceptions diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index ee9b28c2f26..b5ca314dfb9 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: brig_test + # filterNodesByDatacentre: datacenter1 elasticsearch: url: http://127.0.0.1:9200 diff --git a/services/brig/federation-tests.sh b/services/brig/federation-tests.sh index 8c1732bd9aa..76acd31691e 100755 --- a/services/brig/federation-tests.sh +++ b/services/brig/federation-tests.sh @@ -27,4 +27,14 @@ kubectl -n "$NAMESPACE" get configmap brig -o jsonpath='{.data.brig\.yaml}' >b.y sed -i "s=privateKeys: /etc/wire/brig/secrets/secretkey.txt=privateKeys: test/resources/zauth/privkeys.txt=g" b.yaml sed -i "s=publicKeys: /etc/wire/brig/secrets/publickey.txt=publicKeys: test/resources/zauth/pubkeys.txt=g" b.yaml -telepresence --namespace "$NAMESPACE" --also-proxy cassandra-ephemeral --run bash -c "export INTEGRATION_FEDERATION_TESTS=1; ./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" +# We need to pass --also-proxy to cannon pod IPs, as for some reason (maybe due +# to calico) the pod IPs in some clusters are not within the podCIDR range +# defined on the nodes and cannons need to be accessed directly (without using +# the kubernetes services) +declare -a alsoProxyOptions +while read -r ip; do + alsoProxyOptions+=("--also-proxy=${ip}") +done < <(kubectl get pods -n "$NAMESPACE" -l wireService=cannon -o json | jq -r '.items[].status.podIPs[].ip') + +# shellcheck disable=SC2086 +telepresence --namespace "$NAMESPACE" --also-proxy=cassandra-ephemeral ${alsoProxyOptions[*]} --run bash -c "export INTEGRATION_FEDERATION_TESTS=1; ./dist/brig-integration -p federation-end2end-user -i i.yaml -s b.yaml" diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 0fb6928ca17..14fbd8b3456 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -201,7 +201,6 @@ executables: - cassandra-util - containers - cookie - - cql-io - data-timeout - email-validate - exceptions diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 00899404253..98fca2d7d3e 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -395,20 +395,21 @@ initCassandra :: Opts -> Logger -> IO Cas.ClientState initCassandra o g = do c <- maybe - (Cas.initialContactsPlain ((Opt.cassandra o) ^. casEndpoint . epHost)) + (Cas.initialContactsPlain (Opt.cassandra o ^. casEndpoint . epHost)) (Cas.initialContactsDisco "cassandra_brig") (unpack <$> Opt.discoUrl o) p <- Cas.init $ Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) . Cas.setContacts (NE.head c) (NE.tail c) - . Cas.setPortNumber (fromIntegral ((Opt.cassandra o) ^. casEndpoint . epPort)) - . Cas.setKeyspace (Keyspace ((Opt.cassandra o) ^. casKeyspace)) + . Cas.setPortNumber (fromIntegral (Opt.cassandra o ^. casEndpoint . epPort)) + . Cas.setKeyspace (Keyspace (Opt.cassandra o ^. casKeyspace)) . Cas.setMaxConnections 4 . Cas.setPoolStripes 4 . Cas.setSendTimeout 3 . Cas.setResponseTimeout 10 . Cas.setProtocolVersion Cas.V4 + . Cas.setPolicy (Cas.dcFilterPolicyIfConfigured g (Opt.cassandra o ^. casFilterNodesByDatacentre)) $ Cas.defSettings runClient p $ versionCheck schemaVersion return p diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 76475084e7f..ff4ead2ebf2 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -239,7 +239,7 @@ insert c = do let e = codeForEmail c let p = codeForPhone c let t = round (codeTTL c) - retry x5 (write cql (params Quorum (k, s, v, r, e, p, a, t))) + retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) where cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () cql = @@ -248,7 +248,7 @@ insert c = do -- | Lookup a pending code. lookup :: MonadClient m => Key -> Scope -> m (Maybe Code) -lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params Quorum (k, s))) +lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) where cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) cql = @@ -269,7 +269,7 @@ verify k s v = lookup k s >>= maybe (return Nothing) continue -- | Delete a code associated with the given key and scope. delete :: MonadClient m => Key -> Scope -> m () -delete k s = retry x5 $ write cql (params Quorum (k, s)) +delete k s = retry x5 $ write cql (params LocalQuorum (k, s)) where cql :: PrepQuery W (Key, Scope) () cql = "DELETE FROM vcodes WHERE key = ? AND scope = ?" diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 55329cca716..8cce76a40bc 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -141,7 +141,7 @@ newActivation uk timeout u = do where insert t k c = do key <- liftIO $ mkActivationKey uk - retry x5 . write keyInsert $ params Quorum (key, t, k, c, u, maxAttempts, round timeout) + retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) return $ Activation key c genCode = ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" @@ -151,7 +151,7 @@ newActivation uk timeout u = do lookupActivationCode :: UserKey -> AppIO (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) - >>= retry x1 . query1 codeSelect . params Quorum . Identity + >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity -- | Verify an activation code. verifyCode :: @@ -159,7 +159,7 @@ verifyCode :: ActivationCode -> ExceptT ActivationError AppIO (UserKey, Maybe UserId) verifyCode key code = do - s <- lift . retry x1 . query1 keySelect $ params Quorum (Identity key) + s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of Just (ttl, Ascii t, k, c, u, r) -> if @@ -175,7 +175,7 @@ verifyCode key code = do Just p -> return (userPhoneKey p, u) Nothing -> throwE invalidCode mkScope _ _ _ = throwE invalidCode - countdown = lift . retry x5 . write keyInsert . params Quorum + countdown = lift . retry x5 . write keyInsert . params LocalQuorum revoke = lift $ deleteActivationPair key mkActivationKey :: UserKey -> IO ActivationKey @@ -186,7 +186,7 @@ mkActivationKey k = do return . ActivationKey $ Ascii.encodeBase64Url bs deleteActivationPair :: ActivationKey -> AppIO () -deleteActivationPair = write keyDelete . params Quorum . Identity +deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError invalidUser = InvalidActivationCode "User does not exist." diff --git a/services/brig/src/Brig/Data/Blacklist.hs b/services/brig/src/Brig/Data/Blacklist.hs index 6a1325d51a7..89e571811ac 100644 --- a/services/brig/src/Brig/Data/Blacklist.hs +++ b/services/brig/src/Brig/Data/Blacklist.hs @@ -38,15 +38,15 @@ import Imports -- UserKey blacklisting insert :: MonadClient m => UserKey -> m () -insert uk = retry x5 $ write keyInsert (params Quorum (Identity $ keyText uk)) +insert uk = retry x5 $ write keyInsert (params LocalQuorum (Identity $ keyText uk)) exists :: MonadClient m => UserKey -> m Bool exists uk = return . isJust =<< fmap runIdentity - <$> retry x1 (query1 keySelect (params Quorum (Identity $ keyText uk))) + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText uk))) delete :: MonadClient m => UserKey -> m () -delete uk = retry x5 $ write keyDelete (params Quorum (Identity $ keyText uk)) +delete uk = retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText uk)) keyInsert :: PrepQuery W (Identity Text) () keyInsert = "INSERT INTO blacklist (key) VALUES (?)" @@ -61,13 +61,13 @@ keyDelete = "DELETE FROM blacklist WHERE key = ?" -- Excluded phone prefixes insertPrefix :: MonadClient m => ExcludedPrefix -> m () -insertPrefix prefix = retry x5 $ write ins (params Quorum (phonePrefix prefix, comment prefix)) +insertPrefix prefix = retry x5 $ write ins (params LocalQuorum (phonePrefix prefix, comment prefix)) where ins :: PrepQuery W (PhonePrefix, Text) () ins = "INSERT INTO excluded_phones (prefix, comment) VALUES (?, ?)" deletePrefix :: MonadClient m => PhonePrefix -> m () -deletePrefix prefix = retry x5 $ write del (params Quorum (Identity prefix)) +deletePrefix prefix = retry x5 $ write del (params LocalQuorum (Identity prefix)) where del :: PrepQuery W (Identity PhonePrefix) () del = "DELETE FROM excluded_phones WHERE prefix = ?" @@ -84,7 +84,7 @@ existsAnyPrefix phone = do selectPrefixes :: MonadClient m => [Text] -> m [ExcludedPrefix] selectPrefixes prefixes = do - results <- retry x1 (query sel (params Quorum (Identity $ prefixes))) + results <- retry x1 (query sel (params LocalQuorum (Identity $ prefixes))) return $ (\(p, c) -> ExcludedPrefix p c) <$> results where sel :: PrepQuery R (Identity [Text]) (PhonePrefix, Text) diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 45b5631220e..b6a322f8877 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -130,13 +130,13 @@ addClient u newId c maxPermClients loc cps = do lon = Longitude . view longitude <$> loc mdl = newClientModel c prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, lat, lon, mdl, C.Set . Set.toList <$> cps) - retry x5 $ write insertClient (params Quorum prm) + retry x5 $ write insertClient (params LocalQuorum prm) return $! Client newId (newClientType c) now (newClientClass c) (newClientLabel c) (newClientCookie c) loc mdl (ClientCapabilityList $ fromMaybe mempty cps) lookupClient :: MonadClient m => UserId -> ClientId -> m (Maybe Client) lookupClient u c = fmap toClient - <$> retry x1 (query1 selectClient (params Quorum (u, c))) + <$> retry x1 (query1 selectClient (params LocalQuorum (u, c))) lookupClientsBulk :: (MonadClient m) => [UserId] -> m (Map UserId (Imports.Set Client)) lookupClientsBulk uids = liftClient $ do @@ -147,7 +147,7 @@ lookupClientsBulk uids = liftClient $ do getClientSetWithUser u = (u,) . Set.fromList <$> executeQuery u executeQuery :: MonadClient m => UserId -> m [Client] - executeQuery u = toClient <$$> retry x1 (query selectClients (params Quorum (Identity u))) + executeQuery u = toClient <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) lookupPubClientsBulk :: (MonadClient m) => [UserId] -> m (UserMap (Imports.Set PubClient)) lookupPubClientsBulk uids = liftClient $ do @@ -158,17 +158,17 @@ lookupPubClientsBulk uids = liftClient $ do getClientSetWithUser u = (u,) . Set.fromList . map toPubClient <$> executeQuery u executeQuery :: MonadClient m => UserId -> m [(ClientId, Maybe ClientClass)] - executeQuery u = retry x1 (query selectPubClients (params Quorum (Identity u))) + executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) lookupClients :: MonadClient m => UserId -> m [Client] lookupClients u = map toClient - <$> retry x1 (query selectClients (params Quorum (Identity u))) + <$> retry x1 (query selectClients (params LocalQuorum (Identity u))) lookupClientIds :: MonadClient m => UserId -> m [ClientId] lookupClientIds u = map runIdentity - <$> retry x1 (query selectClientIds (params Quorum (Identity u))) + <$> retry x1 (query selectClientIds (params LocalQuorum (Identity u))) lookupUsersClientIds :: MonadClient m => [UserId] -> m [(UserId, Set.Set ClientId)] lookupUsersClientIds us = @@ -179,22 +179,22 @@ lookupUsersClientIds us = lookupPrekeyIds :: MonadClient m => UserId -> ClientId -> m [PrekeyId] lookupPrekeyIds u c = map runIdentity - <$> retry x1 (query selectPrekeyIds (params Quorum (u, c))) + <$> retry x1 (query selectPrekeyIds (params LocalQuorum (u, c))) hasClient :: MonadClient m => UserId -> ClientId -> m Bool -hasClient u d = isJust <$> retry x1 (query1 checkClient (params Quorum (u, d))) +hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) rmClient :: UserId -> ClientId -> AppIO () rmClient u c = do - retry x5 $ write removeClient (params Quorum (u, c)) - retry x5 $ write removeClientKeys (params Quorum (u, c)) + retry x5 $ write removeClient (params LocalQuorum (u, c)) + retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) unlessM (isJust <$> view randomPrekeyLocalLock) $ deleteOptLock u c updateClientLabel :: MonadClient m => UserId -> ClientId -> Maybe Text -> m () -updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params Quorum (l, u, c)) +updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params LocalQuorum (l, u, c)) updateClientCapabilities :: MonadClient m => UserId -> ClientId -> Maybe (Imports.Set ClientCapability) -> m () -updateClientCapabilities u c fs = retry x5 $ write updateClientCapabilitiesQuery (params Quorum (C.Set . Set.toList <$> fs, u, c)) +updateClientCapabilities u c fs = retry x5 $ write updateClientCapabilitiesQuery (params LocalQuorum (C.Set . Set.toList <$> fs, u, c)) updatePrekeys :: MonadClient m => UserId -> ClientId -> [Prekey] -> ExceptT ClientDataError m () updatePrekeys u c pks = do @@ -204,7 +204,7 @@ updatePrekeys u c pks = do throwE MalformedPrekeys for_ pks $ \k -> do let args = (u, c, prekeyId k, prekeyKey k) - retry x5 $ write insertClientKey (params Quorum args) + retry x5 $ write insertClientKey (params LocalQuorum args) where check a b = do i <- CryptoBox.isPrekey b @@ -217,18 +217,18 @@ claimPrekey u c = view randomPrekeyLocalLock >>= \case -- Use random prekey selection strategy Just localLock -> withLocalLock localLock $ do - prekeys <- retry x1 $ query userPrekeys (params Quorum (u, c)) + prekeys <- retry x1 $ query userPrekeys (params LocalQuorum (u, c)) prekey <- pickRandomPrekey prekeys removeAndReturnPreKey prekey -- Use DynamoDB based optimistic locking strategy Nothing -> withOptLock u c $ do - prekey <- retry x1 $ query1 userPrekey (params Quorum (u, c)) + prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) removeAndReturnPreKey prekey where removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> AppIO (Maybe ClientPrekey) removeAndReturnPreKey (Just (i, k)) = do if i /= lastPrekeyId - then retry x1 $ write removePrekey (params Quorum (u, c, i)) + then retry x1 $ write removePrekey (params LocalQuorum (u, c, i)) else Log.debug $ field "user" (toByteString u) diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 79d69990561..5c7ccf38d7a 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -78,10 +78,10 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = write connectionInsert $ - params Quorum (tUnqualified self, ltarget, rel, now, cnv) + params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionInsert $ - params Quorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) retry x5 $ foldQualified self local remote target pure $ UserConnection @@ -107,10 +107,10 @@ updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = write connectionUpdate $ - params Quorum (status, now, tUnqualified self, ltarget) + params LocalQuorum (status, now, tUnqualified self, ltarget) let remote (qUntagged -> Qualified rtarget domain) = write remoteConnectionUpdate $ - params Quorum (status, now, tUnqualified self, domain, rtarget) + params LocalQuorum (status, now, tUnqualified self, domain, rtarget) retry x5 $ foldQualified self local remote target pure now @@ -120,12 +120,12 @@ lookupConnection self target = runMaybeT $ do let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- MaybeT . query1 connectionSelect $ - params Quorum (tUnqualified self, ltarget) + params LocalQuorum (tUnqualified self, ltarget) pure (rel, time, fmap (qUntagged . qualifyAs self) mcnv) let remote (qUntagged -> Qualified rtarget domain) = do (rel, time, cdomain, cnv) <- MaybeT . query1 remoteConnectionSelectFrom $ - params Quorum (tUnqualified self, domain, rtarget) + params LocalQuorum (tUnqualified self, domain, rtarget) pure (rel, time, Just (Qualified cnv cdomain)) (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target pure $ @@ -146,9 +146,9 @@ lookupRelationWithHistory :: AppIO (Maybe RelationWithHistory) lookupRelationWithHistory self target = do let local (tUnqualified -> ltarget) = - query1 relationSelect (params Quorum (tUnqualified self, ltarget)) + query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) let remote (qUntagged -> Qualified rtarget domain) = - query1 remoteRelationSelect (params Quorum (tUnqualified self, domain, rtarget)) + query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation @@ -163,10 +163,10 @@ lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> retry x1 $ - paginate connectionsSelectFrom (paramsP Quorum (tUnqualified lfrom, u) (size + 1)) + paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) Nothing -> retry x1 $ - paginate connectionsSelect (paramsP Quorum (Identity (tUnqualified lfrom)) (size + 1)) + paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) where toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim trim p = p {result = take (fromIntegral size) (result p)} @@ -180,7 +180,7 @@ lookupLocalConnectionsPage :: Range 1 1000 Int32 -> m (PageWithState UserConnection) lookupLocalConnectionsPage self pagingState (fromRange -> size) = - fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | For a given user 'A', lookup their outgoing connections (A -> X) to remote users. lookupRemoteConnectionsPage :: @@ -193,19 +193,19 @@ lookupRemoteConnectionsPage self pagingState size = fmap (toRemoteUserConnection self) <$> paginateWithState remoteConnectionSelect - (paramsPagingState Quorum (Identity (tUnqualified self)) size pagingState) + (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus from to = map toConnectionStatus - <$> retry x1 (query connectionStatusSelect (params Quorum (from, to))) + <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). lookupConnectionStatus' :: [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus' from = map toConnectionStatus - <$> retry x1 (query connectionStatusSelect' (params Quorum (Identity from))) + <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do @@ -214,7 +214,7 @@ lookupLocalConnectionStatuses froms tos = do lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query relationsSelect (params Quorum (from, tUnqualified tos))) + <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do @@ -223,7 +223,7 @@ lookupRemoteConnectionStatuses froms tos = do lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) - <$> retry x1 (query remoteRelationsSelect (params Quorum (from, tDomain tos, tUnqualified tos))) + <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] lookupAllStatuses lfroms = do @@ -236,15 +236,15 @@ lookupAllStatuses lfroms = do lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupLocalStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) - <$> retry x1 (query relationsSelectAll (params Quorum (Identity from))) + <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupRemoteStatuses from = map (\(d, u, r) -> toConnectionStatusV2 from d u r) - <$> retry x1 (query remoteRelationsSelectAll (params Quorum (Identity from))) + <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) lookupRemoteConnectedUsersC :: forall m. (MonadClient m) => UserId -> Int32 -> ConduitT () [Remote UserId] m () lookupRemoteConnectedUsersC u maxResults = - paginateC remoteConnectionsSelectUsers (paramsP Quorum (Identity u) maxResults) x1 + paginateC remoteConnectionsSelectUsers (paramsP LocalQuorum (Identity u) maxResults) x1 .| C.map (map (uncurry toRemoteUnsafe)) -- | See 'lookupContactListWithRelation'. @@ -256,7 +256,7 @@ lookupContactList u = -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). lookupContactListWithRelation :: UserId -> AppIO [(UserId, RelationWithHistory)] lookupContactListWithRelation u = - retry x1 (query contactsSelect (params Quorum (Identity u))) + retry x1 (query contactsSelect (params LocalQuorum (Identity u))) -- | Count the number of connections a user has in a specific relation status. -- (If you want to distinguish 'RelationWithHistory', write a new function.) @@ -280,17 +280,17 @@ countConnections u r = do deleteConnections :: UserId -> AppIO () deleteConnections u = do runConduit $ - paginateC contactsSelect (paramsP Quorum (Identity u) 100) x1 + paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 delete) - retry x1 . write connectionClear $ params Quorum (Identity u) - retry x1 . write remoteConnectionClear $ params Quorum (Identity u) + retry x1 . write connectionClear $ params LocalQuorum (Identity u) + retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) where - delete (other, _status) = write connectionDelete $ params Quorum (other, u) + delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = pooledForConcurrentlyN_ 16 locals $ \u -> - write remoteConnectionDelete $ params Quorum (u, remoteDomain, remoteUser) + write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) -- Queries diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index e9a2d60f4f2..5bd06b68a38 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -59,7 +59,7 @@ createLoginCode u = do verifyLoginCode :: UserId -> LoginCode -> AppIO Bool verifyLoginCode u c = do - code <- retry x1 (query1 codeSelect (params Quorum (Identity u))) + code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime case code of Just (c', _, t) | c == c' && t >= now -> deleteLoginCode u >> return True @@ -70,7 +70,7 @@ verifyLoginCode u c = do lookupLoginCode :: UserId -> AppIO (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime - validate now =<< retry x1 (query1 codeSelect (params Quorum (Identity u))) + validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) where validate now (Just (c, _, t)) | now < t = return (Just (pending c now t)) validate _ _ = return Nothing @@ -78,10 +78,10 @@ lookupLoginCode u = do timeout now t = Timeout (t `diffUTCTime` now) deleteLoginCode :: UserId -> AppIO () -deleteLoginCode u = retry x5 . write codeDelete $ params Quorum (Identity u) +deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> AppIO () -insertLoginCode u c n t = retry x5 . write codeInsert $ params Quorum (u, c, n, t, round ttl) +insertLoginCode u c n t = retry x5 . write codeInsert $ params LocalQuorum (u, c, n, t, round ttl) -- Queries diff --git a/services/brig/src/Brig/Data/PasswordReset.hs b/services/brig/src/Brig/Data/PasswordReset.hs index 62b85323161..c486515d394 100644 --- a/services/brig/src/Brig/Data/PasswordReset.hs +++ b/services/brig/src/Brig/Data/PasswordReset.hs @@ -53,7 +53,7 @@ createPasswordResetCode u target = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime code <- liftIO $ either (const genEmailCode) (const genPhoneCode) target - retry x5 . write codeInsert $ params Quorum (key, code, u, maxAttempts, ttl `addUTCTime` now, round ttl) + retry x5 . write codeInsert $ params LocalQuorum (key, code, u, maxAttempts, ttl `addUTCTime` now, round ttl) return (key, code) where genEmailCode = PasswordResetCode . Ascii.encodeBase64Url <$> randBytes 24 @@ -65,7 +65,7 @@ lookupPasswordResetCode :: UserId -> AppIO (Maybe PasswordResetCode) lookupPasswordResetCode u = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime - validate now =<< retry x1 (query1 codeSelect (params Quorum (Identity key))) + validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity key))) where validate now (Just (c, _, _, Just t)) | t > now = return $ Just c validate _ _ = return Nothing @@ -73,7 +73,7 @@ lookupPasswordResetCode u = do verifyPasswordResetCode :: PasswordResetPair -> AppIO (Maybe UserId) verifyPasswordResetCode (k, c) = do now <- liftIO =<< view currentTime - code <- retry x1 (query1 codeSelect (params Quorum (Identity k))) + code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity k))) case code of Just (c', u, _, Just t) | c == c' && t >= now -> return (Just u) Just (c', u, Just n, Just t) | n > 1 && t > now -> do @@ -82,10 +82,10 @@ verifyPasswordResetCode (k, c) = do Just (_, _, _, _) -> deletePasswordResetCode k >> return Nothing Nothing -> return Nothing where - countdown = retry x5 . write codeInsert . params Quorum + countdown = retry x5 . write codeInsert . params LocalQuorum deletePasswordResetCode :: PasswordResetKey -> AppIO () -deletePasswordResetCode k = retry x5 . write codeDelete $ params Quorum (Identity k) +deletePasswordResetCode k = retry x5 . write codeDelete $ params LocalQuorum (Identity k) mkPasswordResetKey :: (MonadIO m) => UserId -> m PasswordResetKey mkPasswordResetKey u = do diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index 832e3ca23dc..18f49c7dd7e 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -42,31 +42,31 @@ data PropertiesDataError insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () insertProperty u k v = do - n <- lift . fmap (maybe 0 runIdentity) . retry x1 $ query1 propertyCount (params Quorum (Identity u)) + n <- lift . fmap (maybe 0 runIdentity) . retry x1 $ query1 propertyCount (params LocalQuorum (Identity u)) unless (n < maxProperties) $ throwE TooManyProperties - lift . retry x5 $ write propertyInsert (params Quorum (u, k, v)) + lift . retry x5 $ write propertyInsert (params LocalQuorum (u, k, v)) deleteProperty :: UserId -> PropertyKey -> AppIO () -deleteProperty u k = retry x5 $ write propertyDelete (params Quorum (u, k)) +deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) clearProperties :: UserId -> AppIO () -clearProperties u = retry x5 $ write propertyReset (params Quorum (Identity u)) +clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) lookupProperty :: UserId -> PropertyKey -> AppIO (Maybe PropertyValue) lookupProperty u k = fmap runIdentity - <$> retry x1 (query1 propertySelect (params Quorum (u, k))) + <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) lookupPropertyKeys :: UserId -> AppIO [PropertyKey] lookupPropertyKeys u = map runIdentity - <$> retry x1 (query propertyKeysSelect (params Quorum (Identity u))) + <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) lookupPropertyKeysAndValues :: UserId -> AppIO PropertyKeysAndValues lookupPropertyKeysAndValues u = PropertyKeysAndValues - <$> retry x1 (query propertyKeysValuesSelect (params Quorum (Identity u))) + <$> retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) ------------------------------------------------------------------------------- -- Queries diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 8187266ceb6..eed03c3e649 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -220,7 +220,7 @@ insertAccount :: AppIO () insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let Locale l c = userLocale u addPrepQuery userInsert @@ -261,60 +261,60 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc \VALUES (?, ?, ?, ?, ?)" updateLocale :: UserId -> Locale -> AppIO () -updateLocale u (Locale l c) = write userLocaleUpdate (params Quorum (l, c, u)) +updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) updateUser :: UserId -> UserUpdate -> AppIO () updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum for_ uupName $ \n -> addPrepQuery userDisplayNameUpdate (n, u) for_ uupPict $ \p -> addPrepQuery userPictUpdate (p, u) for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) updateEmail :: UserId -> Email -> AppIO () -updateEmail u e = retry x5 $ write userEmailUpdate (params Quorum (e, u)) +updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) updatePhone :: UserId -> Phone -> AppIO () -updatePhone u p = retry x5 $ write userPhoneUpdate (params Quorum (p, u)) +updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) updateSSOId :: UserId -> Maybe UserSSOId -> AppIO Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of Just _ -> do - retry x5 $ write userSSOIdUpdate (params Quorum (ssoid, u)) + retry x5 $ write userSSOIdUpdate (params LocalQuorum (ssoid, u)) pure True Nothing -> pure False updateManagedBy :: UserId -> ManagedBy -> AppIO () -updateManagedBy u h = retry x5 $ write userManagedByUpdate (params Quorum (h, u)) +updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) updateHandle :: UserId -> Handle -> AppIO () -updateHandle u h = retry x5 $ write userHandleUpdate (params Quorum (h, u)) +updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) updatePassword :: UserId -> PlainTextPassword -> AppIO () updatePassword u t = do p <- liftIO $ mkSafePassword t - retry x5 $ write userPasswordUpdate (params Quorum (p, u)) + retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) updateRichInfo :: UserId -> RichInfoAssocList -> AppIO () -updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params Quorum (ri, u)) +updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> AppIO (Maybe ApiFt.TeamFeatureStatusNoConfig) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.tfwoStatus <$> mbStatus - retry x5 $ write update (params Quorum (flag, uid)) + retry x5 $ write update (params LocalQuorum (flag, uid)) pure mbStatus where update :: PrepQuery W (Maybe ApiFt.TeamFeatureStatusValue, UserId) () update = fromString $ "update user set feature_conference_calling = ? where id = ?" deleteEmail :: UserId -> AppIO () -deleteEmail u = retry x5 $ write userEmailDelete (params Quorum (Identity u)) +deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) deletePhone :: UserId -> AppIO () -deletePhone u = retry x5 $ write userPhoneDelete (params Quorum (Identity u)) +deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () deleteServiceUser pid sid bid = do @@ -322,7 +322,7 @@ deleteServiceUser pid sid bid = do Nothing -> pure () Just (_, mbTid) -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cql (pid, sid, bid) for_ mbTid $ \tid -> addPrepQuery cqlTeam (pid, sid, tid, bid) @@ -337,19 +337,19 @@ deleteServiceUser pid sid bid = do \WHERE provider = ? AND service = ? AND team = ? AND user = ?" updateStatus :: UserId -> AccountStatus -> AppIO () -updateStatus u s = retry x5 $ write userStatusUpdate (params Quorum (s, u)) +updateStatus u s = retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) -- | Whether the account has been activated by verifying -- an email address or phone number. isActivated :: UserId -> AppIO Bool isActivated u = (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params Quorum (Identity u))) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) filterActive :: [UserId] -> AppIO [UserId] filterActive us = map (view _1) . filter isActiveUser - <$> retry x1 (query accountStateSelectAll (params Quorum (Identity us))) + <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) where isActiveUser :: (UserId, Bool, Maybe AccountStatus) -> Bool isActiveUser (_, True, Just Active) = True @@ -362,42 +362,42 @@ activateUser :: UserId -> UserIdentity -> AppIO () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident - retry x5 $ write userActivatedUpdate (params Quorum (email, phone, u)) + retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) deactivateUser :: UserId -> AppIO () deactivateUser u = - retry x5 $ write userDeactivatedUpdate (params Quorum (Identity u)) + retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) lookupLocale :: UserId -> AppIO (Maybe Locale) lookupLocale u = do defLoc <- setDefaultLocale <$> view settings - fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params Quorum (Identity u))) + fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) lookupName :: UserId -> AppIO (Maybe Name) lookupName u = fmap runIdentity - <$> retry x1 (query1 nameSelect (params Quorum (Identity u))) + <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) lookupPassword :: UserId -> AppIO (Maybe Password) lookupPassword u = join . fmap runIdentity - <$> retry x1 (query1 passwordSelect (params Quorum (Identity u))) + <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) lookupStatus :: UserId -> AppIO (Maybe AccountStatus) lookupStatus u = join . fmap runIdentity - <$> retry x1 (query1 statusSelect (params Quorum (Identity u))) + <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) lookupRichInfo :: UserId -> AppIO (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity - <$> retry x1 (query1 richInfoSelect (params Quorum (Identity u))) + <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users lookupRichInfoMultiUsers :: [UserId] -> AppIO [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) - <$> retry x1 (query richInfoSelectMulti (params Quorum (Identity users))) + <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) -- | Lookup user (no matter what status) and return 'TeamId'. Safe to use for authorization: -- suspended / deleted / ... users can't login, so no harm done if we authorize them *after* @@ -405,10 +405,10 @@ lookupRichInfoMultiUsers users = do lookupUserTeam :: UserId -> AppIO (Maybe TeamId) lookupUserTeam u = join . fmap runIdentity - <$> retry x1 (query1 teamSelect (params Quorum (Identity u))) + <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus)) -lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params Quorum (Identity u))) +lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity u))) where f (pw, st) = (pw, fromMaybe Active st) @@ -419,7 +419,7 @@ lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] lookupUsers hpi usrs = do loc <- setDefaultLocale <$> view settings domain <- viewFederationDomain - toUsers domain loc hpi <$> retry x1 (query usersSelect (params Quorum (Identity usrs))) + toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) lookupAccount :: UserId -> AppIO (Maybe UserAccount) lookupAccount u = listToMaybe <$> lookupAccounts [u] @@ -428,10 +428,10 @@ lookupAccounts :: [UserId] -> AppIO [UserAccount] lookupAccounts usrs = do loc <- setDefaultLocale <$> view settings domain <- viewFederationDomain - fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params Quorum (Identity usrs))) + fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) lookupServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO (Maybe (ConvId, Maybe TeamId)) -lookupServiceUser pid sid bid = retry x1 (query1 cql (params Quorum (pid, sid, bid))) +lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) cql = @@ -444,7 +444,7 @@ lookupServiceUsers :: ServiceId -> ConduitM () [(BotId, ConvId, Maybe TeamId)] AppIO () lookupServiceUsers pid sid = - paginateC cql (paramsP Quorum (pid, sid) 100) x1 + paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 where cql :: PrepQuery R (ProviderId, ServiceId) (BotId, ConvId, Maybe TeamId) cql = @@ -457,7 +457,7 @@ lookupServiceUsersForTeam :: TeamId -> ConduitM () [(BotId, ConvId)] AppIO () lookupServiceUsersForTeam pid sid tid = - paginateC cql (paramsP Quorum (pid, sid, tid) 100) x1 + paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 where cql :: PrepQuery R (ProviderId, ServiceId, TeamId) (BotId, ConvId) cql = @@ -466,7 +466,7 @@ lookupServiceUsersForTeam pid sid tid = lookupFeatureConferenceCalling :: MonadClient m => UserId -> m (Maybe ApiFt.TeamFeatureStatusNoConfig) lookupFeatureConferenceCalling uid = do - let q = query1 select (params Quorum (Identity uid)) + let q = query1 select (params LocalQuorum (Identity uid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q pure $ ApiFt.TeamFeatureStatusNoConfig <$> mStatusValue where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index 408973ff0dd..12ab1e27881 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -149,20 +149,20 @@ keyAvailable k u = do lookupKey :: UserKey -> AppIO (Maybe UserId) lookupKey k = fmap runIdentity - <$> retry x1 (query1 keySelect (params Quorum (Identity $ keyText k))) + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) insertKey :: UserId -> UserKey -> AppIO () insertKey u k = do hk <- hashKey k let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k - retry x5 $ write insertHashed (params Quorum (hk, kt, u)) - retry x5 $ write keyInsert (params Quorum (keyText k, u)) + retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) + retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) deleteKey :: UserKey -> AppIO () deleteKey k = do hk <- hashKey k - retry x5 $ write deleteHashed (params Quorum (Identity hk)) - retry x5 $ write keyDelete (params Quorum (Identity $ keyText k)) + retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) + retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) hashKey :: UserKey -> AppIO UserKeyHash hashKey uk = do diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index f56025ccd26..44283515d20 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -40,14 +40,14 @@ data UserPendingActivation = UserPendingActivation usersPendingActivationAdd :: UserPendingActivation -> AppIO () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do - retry x5 . write insertExpiration . params Quorum $ (uid, expiresAt) + retry x5 . write insertExpiration . params LocalQuorum $ (uid, expiresAt) where insertExpiration :: PrepQuery W (UserId, UTCTime) () insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" usersPendingActivationList :: AppIO (Page UserPendingActivation) usersPendingActivationList = do - uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params Quorum ())) + uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where selectExpired :: PrepQuery R () (UserId, UTCTime) selectExpired = @@ -58,7 +58,7 @@ usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () usersPendingActivationRemoveMultiple uids = - retry x5 . write deleteExpired . params Quorum $ (Identity uids) + retry x5 . write deleteExpired . params LocalQuorum $ (Identity uids) where deleteExpired :: PrepQuery W (Identity [UserId]) () deleteExpired = diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 6ceed1c77fa..df063cbdd0d 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -93,6 +93,7 @@ import Data.Coerce (coerce) 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, (#)) @@ -118,7 +119,7 @@ import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Client -import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) +import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Message (UserClients) import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatus) import Wire.API.Team.LegalHold (LegalholdProtectee) @@ -275,13 +276,8 @@ notifyUserDeletionRemotes deleted = do Just rangedUids -> do luidDeleted <- qualifyLocal deleted eitherFErr <- runExceptT (notifyUserDeleted luidDeleted (qualifyAs uids rangedUids)) - case eitherFErr of - Left fErr -> do - logFederationError (tDomain uids) fErr - -- FUTUTREWORK: Do something better here? - -- FUTUREWORK: Write test that this happens - throwM $ federationErrorToWai fErr - Right () -> pure () + whenLeft eitherFErr $ + logFederationError (tDomain uids) logFederationError :: Domain -> FederationError -> AppT IO () logFederationError domain fErr = diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index af0313ae037..35118aa13cc 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -51,7 +51,7 @@ insertAccount :: m ProviderId insertAccount name pass url descr = do pid <- randomId - retry x5 $ write cql $ params Quorum (pid, name, pass, url, descr) + retry x5 $ write cql $ params LocalQuorum (pid, name, pass, url, descr) return pid where cql :: PrepQuery W (ProviderId, Name, Password, HttpsUrl, Text) () @@ -66,7 +66,7 @@ updateAccountProfile :: m () updateAccountProfile p name url descr = retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ name $ \x -> addPrepQuery cqlName (x, p) for_ url $ \x -> addPrepQuery cqlUrl (x, p) for_ descr $ \x -> addPrepQuery cqlDescr (x, p) @@ -83,7 +83,7 @@ lookupAccountData :: MonadClient m => ProviderId -> m (Maybe (Name, Maybe Email, HttpsUrl, Text)) -lookupAccountData p = retry x1 $ query1 cql $ params Quorum (Identity p) +lookupAccountData p = retry x1 $ query1 cql $ params LocalQuorum (Identity p) where cql :: PrepQuery R (Identity ProviderId) (Name, Maybe Email, HttpsUrl, Text) cql = "SELECT name, email, url, descr FROM provider WHERE id = ?" @@ -112,7 +112,7 @@ lookupPassword p = fmap (fmap runIdentity) $ retry x1 $ query1 cql $ - params Quorum (Identity p) + params LocalQuorum (Identity p) where cql :: PrepQuery R (Identity ProviderId) (Identity Password) cql = "SELECT password FROM provider WHERE id = ?" @@ -121,7 +121,7 @@ deleteAccount :: MonadClient m => ProviderId -> m () -deleteAccount pid = retry x5 $ write cql $ params Quorum (Identity pid) +deleteAccount pid = retry x5 $ write cql $ params LocalQuorum (Identity pid) where cql :: PrepQuery W (Identity ProviderId) () cql = "DELETE FROM provider WHERE id = ?" @@ -133,7 +133,7 @@ updateAccountPassword :: m () updateAccountPassword pid pwd = do p <- liftIO $ mkSafePassword pwd - retry x5 $ write cql $ params Quorum (p, pid) + retry x5 $ write cql $ params LocalQuorum (p, pid) where cql :: PrepQuery W (Password, ProviderId) () cql = "UPDATE provider SET password = ? where id = ?" @@ -148,7 +148,7 @@ insertKey :: EmailKey -> m () insertKey p old new = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged for_ old $ \old' -> addPrepQuery cqlKeyDelete (Identity (emailKeyUniq old')) addPrepQuery cqlKeyInsert (emailKeyUniq new, p) @@ -169,13 +169,13 @@ lookupKey k = fmap (fmap runIdentity) $ retry x1 $ query1 cql $ - params Quorum (Identity (emailKeyUniq k)) + params LocalQuorum (Identity (emailKeyUniq k)) where cql :: PrepQuery R (Identity Text) (Identity ProviderId) cql = "SELECT provider FROM provider_keys WHERE key = ?" deleteKey :: MonadClient m => EmailKey -> m () -deleteKey k = retry x5 $ write cql $ params Quorum (Identity (emailKeyUniq k)) +deleteKey k = retry x5 $ write cql $ params LocalQuorum (Identity (emailKeyUniq k)) where cql :: PrepQuery W (Identity Text) () cql = "DELETE FROM provider_keys WHERE key = ?" @@ -202,7 +202,7 @@ insertService pid name summary descr url token key fprint assets tags = do retry x5 $ write cql $ params - Quorum + LocalQuorum (pid, sid, name, summary, descr, url, [token], [key], [fprint], assets, tagSet, False) return sid where @@ -237,7 +237,7 @@ lookupService pid sid = fmap (fmap mk) $ retry x1 $ query1 cql $ - params Quorum (pid, sid) + params LocalQuorum (pid, sid) where cql :: PrepQuery @@ -258,7 +258,7 @@ listServices p = fmap (map mk) $ retry x1 $ query cql $ - params Quorum (Identity p) + params LocalQuorum (Identity p) where cql :: PrepQuery @@ -286,7 +286,7 @@ updateService :: Bool -> m () updateService pid sid svcName svcTags nameChange summary descr assets tagsChange enabled = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchUnLogged -- If there is a name change, update the service name; if enabled, update indexes for_ nameChange $ \(oldName, newName) -> do @@ -331,7 +331,7 @@ deleteService pid sid name tags = do -- consumers won't be able to retry a half-done 'deleteService' call. deleteServiceWhitelist Nothing pid sid retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchUnLogged addPrepQuery cql (pid, sid) deleteServicePrefix sid name @@ -408,7 +408,7 @@ lookupServiceConn pid sid = fmap (fmap mk) $ retry x1 $ query1 cql $ - params Quorum (pid, sid) + params LocalQuorum (pid, sid) where cql :: PrepQuery R (ProviderId, ServiceId) (HttpsUrl, List1 ServiceToken, List1 (Fingerprint Rsa), Bool) cql = @@ -427,7 +427,7 @@ updateServiceConn :: Maybe Bool -> m () updateServiceConn pid sid url tokens keys enabled = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged for_ url $ \x -> addPrepQuery cqlBaseUrl (x, pid, sid) for_ tokens $ \x -> addPrepQuery cqlTokens (x, pid, sid) @@ -459,7 +459,7 @@ insertServiceIndexes :: m () insertServiceIndexes pid sid name tags = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged insertServicePrefix pid sid name insertServiceTags pid sid name tags @@ -473,7 +473,7 @@ deleteServiceIndexes :: m () deleteServiceIndexes pid sid name tags = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged deleteServicePrefix sid name deleteServiceTags pid sid name tags @@ -740,16 +740,16 @@ insertServiceWhitelist tid pid sid = deleteServiceWhitelist :: MonadClient m => Maybe TeamId -> ProviderId -> ServiceId -> m () deleteServiceWhitelist mbTid pid sid = case mbTid of Nothing -> do - teams <- retry x5 $ query lookupRev $ params Quorum (pid, sid) + teams <- retry x5 $ query lookupRev $ params LocalQuorum (pid, sid) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery deleteAllRev (pid, sid) for_ teams $ \(Identity tid) -> addPrepQuery delete1 (tid, pid, sid) Just tid -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delete1 (tid, pid, sid) addPrepQuery delete1Rev (tid, pid, sid) where diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 76a472b768b..7216d751d44 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -95,7 +95,7 @@ insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName let inv = Invitation t role iid now minviter email inviteeName phone retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, phone, round timeout) addPrepQuery cqlInvitationInfo (code, t, iid, round timeout) addPrepQuery cqlInvitationByEmail (email, t, iid, code, round timeout) @@ -112,7 +112,7 @@ insertInvitation iid t role (toUTCTimeMillis -> now) minviter email inviteeName lookupInvitation :: MonadClient m => TeamId -> InvitationId -> m (Maybe Invitation) lookupInvitation t r = fmap toInvitation - <$> retry x1 (query1 cqlInvitation (params Quorum (t, r))) + <$> retry x1 (query1 cqlInvitation (params LocalQuorum (t, r))) where cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, Email, Maybe Name, Maybe Phone) cqlInvitation = "SELECT team, role, id, created_at, created_by, email, name, phone FROM team_invitation WHERE team = ? AND id = ?" @@ -126,13 +126,13 @@ lookupInvitationByCode i = lookupInvitationCode :: MonadClient m => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = fmap runIdentity - <$> retry x1 (query1 cqlInvitationCode (params Quorum (t, r))) + <$> retry x1 (query1 cqlInvitationCode (params LocalQuorum (t, r))) where cqlInvitationCode :: PrepQuery R (TeamId, InvitationId) (Identity InvitationCode) cqlInvitationCode = "SELECT code FROM team_invitation WHERE team = ? AND id = ?" lookupInvitationCodeEmail :: MonadClient m => TeamId -> InvitationId -> m (Maybe (InvitationCode, Email)) -lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params Quorum (t, r))) +lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) where cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, Email) cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" @@ -140,8 +140,8 @@ lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params lookupInvitations :: MonadClient m => TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> m (ResultPage Invitation) lookupInvitations team start (fromRange -> size) = do page <- case start of - Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP Quorum (team, ref) (size + 1)) - Nothing -> retry x1 $ paginate cqlSelect (paramsP Quorum (Identity team) (size + 1)) + Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP LocalQuorum (team, ref) (size + 1)) + Nothing -> retry x1 $ paginate cqlSelect (paramsP LocalQuorum (Identity team) (size + 1)) return $ toResult (hasMore page) $ map toInvitation (trim page) where trim p = take (fromIntegral size) (result p) @@ -162,12 +162,12 @@ deleteInvitation t i = do case codeEmail of Just (invCode, invEmail) -> retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery cqlInvitation (t, i) addPrepQuery cqlInvitationInfo (Identity invCode) addPrepQuery cqlInvitationEmail (invEmail, t) Nothing -> - retry x5 $ write cqlInvitation (params Quorum (t, i)) + retry x5 $ write cqlInvitation (params LocalQuorum (t, i)) where cqlInvitation :: PrepQuery W (TeamId, InvitationId) () cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" @@ -180,7 +180,7 @@ deleteInvitations :: (MonadClient m, MonadUnliftIO m) => TeamId -> m () deleteInvitations t = liftClient $ runConduit $ - paginateC cqlSelect (paramsP Quorum (Identity t) 100) x1 + paginateC cqlSelect (paramsP LocalQuorum (Identity t) 100) x1 .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) @@ -191,7 +191,7 @@ lookupInvitationInfo ic@(InvitationCode c) | c == mempty = return Nothing | otherwise = fmap (toInvitationInfo ic) - <$> retry x1 (query1 cqlInvitationInfo (params Quorum (Identity ic))) + <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) where toInvitationInfo i (t, r) = InvitationInfo i t r cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) @@ -205,7 +205,7 @@ lookupInvitationByEmail e = lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => Email -> m InvitationByEmail lookupInvitationInfoByEmail email = do - res <- retry x1 (query cqlInvitationEmail (params Quorum (Identity email))) + res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) case res of [] -> return InvitationByEmailNotFound (tid, invId, code) : [] -> @@ -224,7 +224,7 @@ lookupInvitationInfoByEmail email = do countInvitations :: MonadClient m => TeamId -> m Int64 countInvitations t = fromMaybe 0 . fmap runIdentity - <$> retry x1 (query1 cqlSelect (params Quorum (Identity t))) + <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) where cqlSelect :: PrepQuery R (Identity TeamId) (Identity Int64) cqlSelect = "SELECT count(*) FROM team_invitation WHERE team = ?" diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index 2fc7849d22f..5c0432d172c 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -66,7 +66,7 @@ withClaim u v t io = do -- [Note: Guarantees] claim = do let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params Quorum (ttl * 2, C.Set [u], v) + retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) claimed <- (== [u]) <$> lookupClaims v if claimed then liftIO $ timeout (fromIntegral ttl # Second) io @@ -88,7 +88,7 @@ deleteClaim :: m () deleteClaim u v t = do let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params Quorum (ttl * 2, C.Set [u], v) + retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) where cql :: PrepQuery W (Int32, C.Set (Id a), Text) () cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" @@ -99,7 +99,7 @@ lookupClaims v = fmap (maybe [] (fromSet . runIdentity)) $ retry x1 $ query1 cql $ - params Quorum (Identity v) + params LocalQuorum (Identity v) where cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) cql = "SELECT claims FROM unique_claims WHERE value = ?" diff --git a/services/brig/src/Brig/User/Auth/DB/Cookie.hs b/services/brig/src/Brig/User/Auth/DB/Cookie.hs index 9654883f479..7cdfcbdb964 100644 --- a/services/brig/src/Brig/User/Auth/DB/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/DB/Cookie.hs @@ -38,7 +38,7 @@ insertCookie u ck ttl = l = cookieLabel ck s = cookieSucc ck o = fromMaybe (TTL (round (diffUTCTime x c))) ttl - in retry x5 $ write cql (params Quorum (u, x, i, t, c, l, s, o)) + in retry x5 $ write cql (params LocalQuorum (u, x, i, t, c, l, s, o)) where cql :: PrepQuery W (UserId, UTCTime, CookieId, CookieType, UTCTime, Maybe CookieLabel, Maybe CookieId, TTL) () cql = @@ -47,7 +47,7 @@ insertCookie u ck ttl = lookupCookie :: MonadClient m => UserId -> UTCTime -> CookieId -> m (Maybe (Cookie ())) lookupCookie u t c = - fmap mkCookie <$> retry x1 (query1 cql (params Quorum (u, t, c))) + fmap mkCookie <$> retry x1 (query1 cql (params LocalQuorum (u, t, c))) where mkCookie (typ, created, label, csucc) = Cookie @@ -67,7 +67,7 @@ lookupCookie u t c = listCookies :: MonadClient m => UserId -> m [Cookie ()] listCookies u = - map toCookie <$> retry x1 (query cql (params Quorum (Identity u))) + map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u))) where cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) cql = @@ -90,14 +90,14 @@ listCookies u = deleteCookies :: MonadClient m => UserId -> [Cookie a] -> m () deleteCookies u cs = retry x5 . batch $ do setType BatchUnLogged - setConsistency Quorum + setConsistency LocalQuorum for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) where cql :: PrepQuery W (UserId, UTCTime, CookieId) () cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?" deleteAllCookies :: MonadClient m => UserId -> m () -deleteAllCookies u = retry x5 (write cql (params Quorum (Identity u))) +deleteAllCookies u = retry x5 (write cql (params LocalQuorum (Identity u))) where cql :: PrepQuery W (Identity UserId) () cql = "DELETE FROM user_cookies WHERE user = ?" diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 101aaf5e736..6827a41b27d 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -47,7 +47,7 @@ claimHandle uid oldHandle newHandle = runAppT env $ do -- Record ownership - retry x5 $ write handleInsert (params Quorum (newHandle, uid)) + retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) -- Update profile result <- User.updateHandle uid newHandle -- Free old handle (if it changed) @@ -58,13 +58,13 @@ claimHandle uid oldHandle newHandle = -- | Free a 'Handle', making it available to be claimed again. freeHandle :: UserId -> Handle -> AppIO () freeHandle uid h = do - retry x5 $ write handleDelete (params Quorum (Identity h)) + retry x5 $ write handleDelete (params LocalQuorum (Identity h)) let key = "@" <> fromHandle h deleteClaim uid key (30 # Minute) -- | Lookup the current owner of a 'Handle'. lookupHandle :: Handle -> AppIO (Maybe UserId) -lookupHandle = lookupHandleWithPolicy Quorum +lookupHandle = lookupHandleWithPolicy LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index ccb2e404140..94de3110c12 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -581,7 +581,7 @@ lookupIndexUser u = lookupForIndex :: (MonadThrow m, C.MonadClient m) => UserId -> m (Maybe IndexUser) lookupForIndex u = do - result <- C.retry C.x1 (C.query1 cql (C.params C.Quorum (Identity u))) + result <- C.retry C.x1 (C.query1 cql (C.params C.LocalQuorum (Identity u))) sequence $ reindexRowToIndexUser <$> result where cql :: C.PrepQuery C.R (Identity UserId) ReindexRow diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index 2f19e86e1d1..e0b380b313d 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -8,6 +8,7 @@ import Bilge import Brig.Data.User (lookupFeatureConferenceCalling) import qualified Brig.Options as Opt import Brig.Types.User (userId) +import qualified Cassandra as Cass import Control.Exception (ErrorCall (ErrorCall), throwIO) import Control.Lens ((^.), (^?!)) import qualified Data.Aeson.Lens as Aeson @@ -15,7 +16,6 @@ import qualified Data.Aeson.Types as Aeson import Data.ByteString.Conversion (toByteString') import Data.Id import qualified Data.Set as Set -import qualified Database.CQL.IO as Cass import Imports import Test.Tasty import Test.Tasty.HUnit diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index fb3a09bbc0e..d67ddf9476f 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -580,15 +580,9 @@ testBadFingerprint config db brig galley _cannon = do testAddRemoveBotTeam :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () testAddRemoveBotTeam config db brig galley cannon = withTestService config db brig defServiceApp $ \sref buf -> do - (u1, u2, h, tid, cid, pid, sid) <- prepareBotUsersTeam brig galley sref - let (uid1, uid2) = (userId u1, userId u2) - quid1 = userQualifiedId u1 + (u1, u2, h, _, cid, pid, sid) <- prepareBotUsersTeam brig galley sref + let quid1 = userQualifiedId u1 localDomain = qDomain quid1 - -- Ensure cannot add bots to managed conversations - cidFail <- Team.createManagedConv galley tid uid1 [uid2] Nothing - addBot brig uid1 pid sid cidFail !!! do - const 403 === statusCode - const (Just "invalid-conversation") === fmap Error.label . responseJsonMaybe testAddRemoveBotUtil localDomain pid sid cid u1 u2 h sref buf brig galley cannon testBotTeamOnlyConv :: Config -> DB.ClientState -> Brig -> Galley -> Cannon -> Http () diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index fcc529fd2da..78dd97bda49 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -136,6 +136,7 @@ tests _ at opts p b c ch g aws = test' aws p "delete /i/users/:uid - 202" $ testDeleteInternal b c aws, test' aws p "delete with profile pic" $ testDeleteWithProfilePic b ch, test' aws p "delete with connected remote users" $ testDeleteWithRemotes opts b, + test' aws p "delete with connected remote users and failed remote notifcations" $ testDeleteWithRemotesAndFailedNotifications opts b c, test' aws p "put /i/users/:uid/sso-id" $ testUpdateSSOId b g, testGroup "temporary customer extensions" @@ -1224,7 +1225,7 @@ testDeleteWithRemotes opts brig = do sendConnectionAction brig opts (userId localUser) remote2UserBlocked (Just FedBrig.RemoteConnect) Accepted void $ putConnectionQualified brig (userId localUser) remote2UserBlocked Blocked - let fedMockResponse = OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + let fedMockResponse = const (OutwardResponseBody (cs $ Aeson.encode EmptyResponse)) let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = case (requestMethod, requestPath) of @@ -1257,6 +1258,56 @@ testDeleteWithRemotes opts brig = do (eitherDecode . cs) (F.body r) Nothing -> Left "No request" +testDeleteWithRemotesAndFailedNotifications :: Opt.Opts -> Brig -> Cannon -> Http () +testDeleteWithRemotesAndFailedNotifications opts brig cannon = do + alice <- randomUser brig + alex <- randomUser brig + let localDomain = qDomain (userQualifiedId alice) + + let bDomain = Domain "b.example.com" + cDomain = Domain "c.example.com" + bob <- Qualified <$> randomId <*> pure bDomain + carl <- Qualified <$> randomId <*> pure cDomain + + postConnection brig (userId alice) (userId alex) !!! const 201 === statusCode + putConnection brig (userId alex) (userId alice) Accepted !!! const 200 === statusCode + sendConnectionAction brig opts (userId alice) bob (Just FedBrig.RemoteConnect) Accepted + sendConnectionAction brig opts (userId alice) carl (Just FedBrig.RemoteConnect) Accepted + + let fedMockResponse req = + if Domain (F.domain req) == bDomain + then F.OutwardResponseError (F.OutwardError F.ConnectionRefused "mocked connection problem with b domain") + else OutwardResponseBody (cs $ Aeson.encode EmptyResponse) + + let galleyHandler :: ReceivedRequest -> MockT IO Wai.Response + galleyHandler (ReceivedRequest requestMethod requestPath _requestBody) = + case (Http.parseMethod requestMethod, requestPath) of + (Right Http.DELETE, ["i", "user"]) -> do + let response = Wai.responseLBS Http.status200 [(Http.hContentType, "application/json")] (cs $ Aeson.encode EmptyResponse) + pure response + _ -> error "not mocked" + + (_, rpcCalls, _galleyCalls) <- WS.bracketR cannon (userId alex) $ \wsAlex -> do + let action = withMockedFederatorAndGalley opts localDomain fedMockResponse galleyHandler $ do + deleteUser (userId alice) (Just defPassword) brig !!! do + const 200 === statusCode + liftIO action <* do + void . liftIO . WS.assertMatch (5 # Second) wsAlex $ matchDeleteUserNotification (userQualifiedId alice) + + liftIO $ do + rRpc <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + cUdn <- assertRight $ parseFedRequest rRpc + udcnUser cUdn @?= userId alice + sort (fromRange (udcnConnections cUdn)) + @?= sort (map qUnqualified [carl]) + where + parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a + parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + testUpdateSSOId :: Brig -> Galley -> Http () testUpdateSSOId brig galley = do noSuchUserId <- Id <$> liftIO UUID.nextRandom diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index e2678598c97..1a22019afed 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -656,7 +656,7 @@ testAllConnectionsPaging b db = do DB.retry DB.x5 $ DB.write remoteConnectionInsert $ DB.params - DB.Quorum + DB.LocalQuorum (self, remoteDomain, qUnqualified qOther, SentWithHistory, now, qDomain qConv, qUnqualified qConv) testConnectionLimit :: Brig -> ConnectionLimit -> Http () diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 6ee884a3dc0..a3024bde91c 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -50,8 +50,10 @@ import qualified Data.Vector as Vec import Federation.Util (withTempMockFederator) import Gundeck.Types (Notification (..)) import Imports +import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import Util +import qualified Wire.API.Event.Conversation as Conv import qualified Wire.API.Federation.API.Brig as F import Wire.API.Federation.GRPC.Types hiding (body, path) import qualified Wire.API.Federation.GRPC.Types as F @@ -462,3 +464,15 @@ matchDeleteUserNotification quid n = do etype @?= Just "user.delete" eUnqualifiedId @?= Just (qUnqualified quid) eQualifiedId @?= Just quid + +matchConvLeaveNotification :: Qualified ConvId -> Qualified UserId -> [Qualified UserId] -> Notification -> IO () +matchConvLeaveNotification conv remover removeds n = do + let e = List1.head (WS.unpackPayload n) + ntfTransient n @?= False + Conv.evtConv e @?= conv + Conv.evtType e @?= Conv.MemberLeave + Conv.evtFrom e @?= remover + sorted (Conv.evtData e) @?= sorted (Conv.EdMembersLeave (Conv.QualifiedUserIdList removeds)) + where + sorted (Conv.EdMembersLeave (Conv.QualifiedUserIdList m)) = Conv.EdMembersLeave (Conv.QualifiedUserIdList (sort m)) + sorted x = x diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index c228de38bbb..9b7411bb8f3 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -132,7 +132,7 @@ waitUserExpiration opts' = do userExists :: MonadClient m => UserId -> m Bool userExists uid = do - x <- retry x1 (query1 usersSelect (params Quorum (Identity uid))) + x <- retry x1 (query1 usersSelect (params LocalQuorum (Identity uid))) pure $ case x of Nothing -> False diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index d197a6b3c8f..445fa1ab7c8 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -18,7 +18,7 @@ module Federation.End2end where import API.Search.Util -import API.User.Util (getUserClientsQualified) +import API.User.Util import Bilge import Bilge.Assert ((!!!), ( Brig -> Galley -> Galley -> Cannon -> Http () +testDeleteUser brig1 brig2 galley1 galley2 cannon1 = do + alice <- userQualifiedId <$> randomUser brig1 + bobDel <- userQualifiedId <$> randomUser brig2 + + connectUsersEnd2End brig1 brig2 alice bobDel + + conv1 <- + fmap cnvQualifiedId . responseJsonError + =<< createConversation galley1 (qUnqualified alice) [bobDel] + do + deleteUser (qUnqualified bobDel) (Just defPassword) brig2 !!! const 200 === statusCode + WS.assertMatch_ (5 # Second) wsAlice $ matchDeleteUserNotification bobDel + WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv1 bobDel [bobDel] + WS.assertMatch_ (5 # Second) wsAlice $ matchConvLeaveNotification conv2 bobDel [bobDel] diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index b6ad08f42d3..5a3ca0781b4 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -89,7 +89,7 @@ import Wire.API.Conversation import Wire.API.Conversation.Role (roleNameWireAdmin) import qualified Wire.API.Federation.API.Brig as FedBrig import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.GRPC.Types (OutwardResponse) +import Wire.API.Federation.GRPC.Types (FederatedRequest, OutwardResponse) import qualified Wire.API.Federation.Mock as Mock import Wire.API.Routes.MultiTablePaging @@ -1039,14 +1039,14 @@ withMockedGalley opts handler action = withMockedFederatorAndGalley :: Opt.Opts -> Domain -> - OutwardResponse -> + (FederatedRequest -> OutwardResponse) -> (ReceivedRequest -> MockT IO Wai.Response) -> Session a -> IO (a, Mock.ReceivedRequests, [ReceivedRequest]) withMockedFederatorAndGalley opts domain fedResp galleyHandler action = do result <- assertRight <=< runExceptT $ withTempMockedService initState galleyHandler $ \galleyMockState -> - Mock.withTempMockFederator (Mock.initState domain) (const (pure fedResp)) $ \fedMockState -> do + Mock.withTempMockFederator (Mock.initState domain) (pure . fedResp) $ \fedMockState -> do let opts' = opts { Opt.galley = Endpoint "127.0.0.1" (fromIntegral (serverPort galleyMockState)), diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 1fe137d8035..5324529818b 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -43,7 +43,6 @@ import Mu.GRpc.Client.Optics (GRpcReply) import Mu.GRpc.Client.Record (GRpcMessageProtocol (MsgProtoBuf)) import Mu.GRpc.Client.TyApps (gRpcCall) import Network.GRPC.Client.Helpers -import Network.HTTP2.Client.Exceptions import Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Polysemy @@ -86,7 +85,7 @@ interpretRemote = interpret $ \case target <- Polysemy.mapError (RemoteErrorDiscoveryFailure vDomain) $ discoverFederatorWithError vDomain - Polysemy.bracket (mkGrpcClient target) (closeGrpcClient target) $ \client -> + Polysemy.bracket (mkGrpcClient target) (embed @IO . closeGrpcClient) $ \client -> callInward client vRequest callInward :: MonadIO m => GrpcClient -> Request -> m (GRpcReply InwardResponse) @@ -158,20 +157,6 @@ mkGrpcClient target@(SrvTarget host port) = do . Polysemy.fromEither =<< Polysemy.fromExceptionVia (RemoteErrorTLSException target) (createGrpcClient cfg') -closeGrpcClient :: - Members '[Embed IO, Polysemy.Error RemoteError] r => - SrvTarget -> - GrpcClient -> - Sem r () -closeGrpcClient target = - Polysemy.mapError handle - . Polysemy.fromEitherM - . runExceptT - . close - where - handle :: ClientError -> RemoteError - handle = RemoteErrorClientFailure target . grpcClientError Nothing - logRemoteErrors :: Members '[Polysemy.Error RemoteError, TinyLog] r => Sem r x -> diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 8d87ff53fa5..2820598747b 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -19,6 +19,7 @@ module Test.Federator.IngressSpec where import Bilge import Control.Lens (view, (^.)) +import Control.Monad.Catch import Data.Aeson import qualified Data.ByteString.Lazy as LBS import Data.Default (def) @@ -43,7 +44,7 @@ import Test.Federator.Util import Test.Hspec import Test.Tasty.HUnit (assertFailure) import Util.Options (Endpoint (Endpoint)) -import Wire.API.Federation.GRPC.Client (createGrpcClient) +import Wire.API.Federation.GRPC.Client (closeGrpcClient, createGrpcClient) import Wire.API.Federation.GRPC.Types hiding (body, path) import qualified Wire.API.Federation.GRPC.Types as GRPC import Wire.API.User @@ -98,24 +99,34 @@ spec env = GRpcErrorString err -> err `shouldBe` "GRPC status indicates failure: status-code=INTERNAL, status-message=\"HTTP Status 400\"" _ -> assertFailure $ "Expect HTTP 400, got: " <> show grpcReply -inwardBrigCallViaIngress :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) +inwardBrigCallViaIngress :: + ( MonadIO m, + MonadMask m, + MonadHttp m, + MonadReader TestEnv m, + HasCallStack + ) => + ByteString -> + LBS.ByteString -> + m (GRpcReply InwardResponse) inwardBrigCallViaIngress requestPath payload = do Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> ask let target = SrvTarget (cs ingressHost) ingressPort runSettings <- optSettings . view teOpts <$> ask tlsSettings <- view teTLSSettings - c <- - liftIO - . Polysemy.runM - . Polysemy.runError @RemoteError - . discardLogs - . Polysemy.runInputConst tlsSettings - . Polysemy.runReader runSettings - $ mkGrpcClient target - client <- case c of - Left clientErr -> liftIO $ assertFailure (show clientErr) - Right cli -> pure cli - inwardBrigCallViaIngressWithClient client requestPath payload + bracket + ( liftIO + . Polysemy.runM + . Polysemy.runError @RemoteError + . discardLogs + . Polysemy.runInputConst tlsSettings + . Polysemy.runReader runSettings + $ mkGrpcClient target + ) + (either (const (pure ())) closeGrpcClient) + $ \case + Left clientErr -> liftIO $ assertFailure (show clientErr) + Right client -> inwardBrigCallViaIngressWithClient client requestPath payload inwardBrigCallViaIngressWithClient :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => GrpcClient -> ByteString -> LBS.ByteString -> m (GRpcReply InwardResponse) inwardBrigCallViaIngressWithClient client requestPath payload = do diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index bf7835bcda2..e80da9dd1ef 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -69,7 +69,8 @@ newtype TestFederator m a = TestFederator {unwrapTestFederator :: ReaderT TestEn MonadReader TestEnv, MonadFail, MonadThrow, - MonadCatch + MonadCatch, + MonadMask ) instance MonadRandom m => MonadRandom (TestFederator m) where diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 3535f859d1e..61d105ed7f5 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -20,6 +20,7 @@ module Test.Federator.Remote where import Data.Streaming.Network (bindRandomPortTCP) +import Federator.Env (TLSSettings) import Federator.Options import Federator.Remote import Federator.Run (mkTLSSettingsOrThrow) @@ -31,11 +32,13 @@ import qualified Network.Wai.Handler.WarpTLS as WarpTLS import Polysemy import qualified Polysemy.Error as Polysemy import qualified Polysemy.Input as Polysemy +import qualified Polysemy.Resource as Polysemy import Test.Federator.Options (defRunSettings) import Test.Tasty import Test.Tasty.HUnit import UnliftIO (bracket, timeout) import qualified UnliftIO.Async as Async +import Wire.API.Federation.GRPC.Client import Wire.Network.DNS.SRV (SrvTarget (SrvTarget)) tests :: TestTree @@ -59,16 +62,24 @@ settings = remoteCAStore = Just "test/resources/unit/unit-ca.pem" } -assertNoError :: - forall e r x. - (Show e, Member (Embed IO) r) => - Sem (Polysemy.Error e ': r) x -> - Sem r x +assertNoError :: IO (Either RemoteError x) -> IO x assertNoError action = - Polysemy.runError action >>= \case - Left err -> embed . assertFailure $ "Unexpected error: " <> show err + action >>= \case + Left err -> assertFailure $ "Unexpected error: " <> show err Right x -> pure x +mkTestGrpcClient :: TLSSettings -> Int -> IO (Either RemoteError ()) +mkTestGrpcClient tlsSettings port = + Polysemy.runM + . Polysemy.runResource + . Polysemy.runError + . Polysemy.runInputConst tlsSettings + $ do + Polysemy.bracket + (mkGrpcClient (SrvTarget "localhost" (fromIntegral port))) + (embed @IO . closeGrpcClient) + (const (pure ())) + testValidatesCertificateSuccess :: TestTree testValidatesCertificateSuccess = testGroup @@ -76,20 +87,16 @@ testValidatesCertificateSuccess = [ testCase "when hostname=localhost and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost" (fromIntegral port)), + assertNoError (mkTestGrpcClient tlsSettings port), testCase "when hostname=localhost. and certificate-for=localhost" $ do bracket (startMockServer certForLocalhost) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - void . Polysemy.runM . assertNoError @RemoteError . Polysemy.runInputConst tlsSettings $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)), + assertNoError (mkTestGrpcClient tlsSettings port), -- This is a limitation of the TLS library, this test just exists to document that. testCase "when hostname=localhost. and certificate-for=localhost." $ do bracket (startMockServer certForLocalhostDot) (\(serverThread, _) -> Async.cancel serverThread) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError @RemoteError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left _ -> pure () Right _ -> assertFailure "Congratulations, you fixed a known issue!" @@ -102,11 +109,7 @@ testValidatesCertificateWrongHostname = [ testCase "when the server's certificate doesn't match the hostname" $ bracket (startMockServer certForWrongDomain) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left (RemoteErrorTLSException _ _) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x @@ -114,11 +117,7 @@ testValidatesCertificateWrongHostname = testCase "when the server's certificate does not have the server key usage flag" $ bracket (startMockServer certWithoutServerKeyUsage) (Async.cancel . fst) $ \(_, port) -> do tlsSettings <- mkTLSSettingsOrThrow settings - eitherClient <- - Polysemy.runM - . Polysemy.runError - . Polysemy.runInputConst tlsSettings - $ mkGrpcClient (SrvTarget "localhost." (fromIntegral port)) + eitherClient <- mkTestGrpcClient tlsSettings port case eitherClient of Left (RemoteErrorTLSException _ _) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 81c99088c3a..7eeb2c3d6b9 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 8bf007e90cc28a7b92252e0fccfb998d850e30df040205e1bc7316b9008a0c9f +-- hash: 6f378c75d7938aa5f221f136049c8ca98f63e7ae682e0035fb912f3917cfd1b1 name: galley version: 0.83.0 @@ -25,6 +25,7 @@ flag static library exposed-modules: Galley.API + Galley.API.Action Galley.API.Clients Galley.API.Create Galley.API.CustomBackend @@ -45,23 +46,66 @@ library Galley.API.Util Galley.App Galley.Aws - Galley.Data - Galley.Data.CustomBackend - Galley.Data.Instances - Galley.Data.LegalHold - Galley.Data.Queries - Galley.Data.SearchVisibility + Galley.Cassandra + Galley.Cassandra.Access + Galley.Cassandra.Client + Galley.Cassandra.Code + Galley.Cassandra.Conversation + Galley.Cassandra.Conversation.Members + Galley.Cassandra.ConversationList + Galley.Cassandra.CustomBackend + Galley.Cassandra.Instances + Galley.Cassandra.LegalHold + Galley.Cassandra.Paging + Galley.Cassandra.Queries + Galley.Cassandra.ResultSet + Galley.Cassandra.SearchVisibility + Galley.Cassandra.Services + Galley.Cassandra.Store + Galley.Cassandra.Team + Galley.Cassandra.TeamFeatures + Galley.Cassandra.TeamNotifications + Galley.Data.Conversation + Galley.Data.Conversation.Types + Galley.Data.Scope Galley.Data.Services Galley.Data.TeamFeatures Galley.Data.TeamNotifications Galley.Data.Types Galley.Effects + Galley.Effects.BotAccess + Galley.Effects.BrigAccess + Galley.Effects.ClientStore + Galley.Effects.CodeStore + Galley.Effects.ConversationStore + Galley.Effects.CustomBackendStore + Galley.Effects.ExternalAccess + Galley.Effects.FederatorAccess Galley.Effects.FireAndForget + Galley.Effects.GundeckAccess + Galley.Effects.LegalHoldStore + Galley.Effects.ListItems + Galley.Effects.MemberStore + Galley.Effects.Paging + Galley.Effects.RemoteConversationListStore + Galley.Effects.SearchVisibilityStore + Galley.Effects.ServiceStore + Galley.Effects.SparAccess + Galley.Effects.TeamFeatureStore + Galley.Effects.TeamMemberStore + Galley.Effects.TeamNotificationStore + Galley.Effects.TeamStore + Galley.Env Galley.External Galley.External.LegalHoldService + Galley.External.LegalHoldService.Types Galley.Intra.Client + Galley.Intra.Effects + Galley.Intra.Federator + Galley.Intra.Federator.Types Galley.Intra.Journal Galley.Intra.Push + Galley.Intra.Push.Internal Galley.Intra.Spar Galley.Intra.Team Galley.Intra.User @@ -70,6 +114,7 @@ library Galley.Queue Galley.Run Galley.Types.Clients + Galley.Types.ToUserRole Galley.Types.UserList Galley.Validation Main @@ -78,7 +123,7 @@ library hs-source-dirs: src default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DerivingVia DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns - ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path + ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -fplugin=Polysemy.Plugin build-depends: HsOpenSSL >=0.11 , HsOpenSSL-x509-system >=0.1 @@ -124,6 +169,8 @@ library , optparse-applicative >=0.10 , pem , polysemy + , polysemy-plugin + , polysemy-wire-zoo , proto-lens >=0.2 , protobuf >=0.2 , raw-strings-qq >=1.0 @@ -134,6 +181,7 @@ library , saml2-web-sso >=0.18 , servant , servant-client + , servant-client-core , servant-server , servant-swagger , servant-swagger-ui @@ -240,7 +288,6 @@ executable galley-integration , cereal , containers , cookie - , cql-io , currency-codes , data-timeout , errors @@ -385,6 +432,7 @@ executable galley-schema V51_FeatureFileSharing V52_FeatureConferenceCalling V53_AddRemoteConvStatus + V54_TeamFeatureSelfDeletingMessages Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 5a617f7e3b2..16ab778ef1f 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: galley_test + # filterNodesByDatacentre: datacenter1 brig: host: 0.0.0.0 diff --git a/services/galley/migrate-data/src/Galley/DataMigration.hs b/services/galley/migrate-data/src/Galley/DataMigration.hs index 8bf027be615..4e5c7752632 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration.hs @@ -96,13 +96,13 @@ runMigration (Migration ver txt mig) = do persistVersion ver txt =<< liftIO getCurrentTime latestMigrationVersion :: MigrationActionT IO MigrationVersion -latestMigrationVersion = MigrationVersion . maybe 0 fromIntegral <$> C.query1 cql (C.params C.Quorum ()) +latestMigrationVersion = MigrationVersion . maybe 0 fromIntegral <$> C.query1 cql (C.params C.LocalQuorum ()) where cql :: C.QueryString C.R () (Identity Int32) cql = "select version from data_migration where id=1 order by version desc limit 1" persistVersion :: MigrationVersion -> Text -> UTCTime -> MigrationActionT IO () -persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.Quorum (fromIntegral v, desc, time)) +persistVersion (MigrationVersion v) desc time = C.write cql (C.params C.LocalQuorum (fromIntegral v, desc, time)) where cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" diff --git a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs index 786fe247695..09ee7cbfedd 100644 --- a/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs +++ b/services/galley/migrate-data/src/V1_BackfillBillingTeamMembers.hs @@ -57,14 +57,14 @@ pageSize = 1000 -- | Get team members from Galley getTeamMembers :: MonadClient m => ConduitM () [(TeamId, UserId, Maybe Permissions)] m () -getTeamMembers = paginateC cql (paramsP Quorum () pageSize) x5 +getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" createBillingTeamMembers :: MonadClient m => (TeamId, UserId) -> m () createBillingTeamMembers pair = - retry x5 $ write cql (params Quorum pair) + retry x5 $ write cql (params LocalQuorum pair) where cql :: PrepQuery W (TeamId, UserId) () cql = "INSERT INTO billing_team_member (team, user) values (?, ?)" diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 03a557c84e7..c7c5a15ff8c 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -26,6 +26,7 @@ dependencies: library: source-dirs: src + ghc-options: -fplugin=Polysemy.Plugin dependencies: - aeson >=0.11 - amazonka >=1.4.5 @@ -66,6 +67,8 @@ library: - optparse-applicative >=0.10 - pem - polysemy + - polysemy-plugin + - polysemy-wire-zoo - protobuf >=0.2 - proto-lens >=0.2 - QuickCheck >=2.14 @@ -73,6 +76,7 @@ library: - retry >=0.5 - safe-exceptions >=0.1 - servant + - servant-client-core - servant-server - servant-swagger - servant-swagger-ui @@ -166,7 +170,6 @@ executables: - cereal - containers - cookie - - cql-io - currency-codes - metrics-wai - data-timeout diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index c350df9f4dc..369a4644368 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -56,6 +56,7 @@ import qualified V50_AddLegalholdWhitelisted import qualified V51_FeatureFileSharing import qualified V52_FeatureConferenceCalling import qualified V53_AddRemoteConvStatus +import qualified V54_TeamFeatureSelfDeletingMessages main :: IO () main = do @@ -97,7 +98,8 @@ main = do V50_AddLegalholdWhitelisted.migration, V51_FeatureFileSharing.migration, V52_FeatureConferenceCalling.migration, - V53_AddRemoteConvStatus.migration + V53_AddRemoteConvStatus.migration, + V54_TeamFeatureSelfDeletingMessages.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Data -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs b/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs new file mode 100644 index 00000000000..35b2236e868 --- /dev/null +++ b/services/galley/schema/src/V54_TeamFeatureSelfDeletingMessages.hs @@ -0,0 +1,34 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V54_TeamFeatureSelfDeletingMessages + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 54 "Add feature config for self-deleting messages" $ do + schema' + [r| ALTER TABLE team_features ADD ( + self_deleting_messages_status int, + self_deleting_messages_ttl int + ) + |] diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs new file mode 100644 index 00000000000..4f3e508b11e --- /dev/null +++ b/services/galley/src/Galley/API/Action.hs @@ -0,0 +1,519 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.API.Action + ( -- * Conversation action class + IsConversationAction (..), + + -- * Conversation action types + ConversationDelete (..), + ConversationJoin (..), + ConversationLeave (..), + ConversationMemberUpdate (..), + + -- * Performing actions + updateLocalConversation, + + -- * Utilities + ensureConversationActionAllowed, + addMembersToLocalConversation, + notifyConversationAction, + ) +where + +import qualified Brig.Types.User as User +import Control.Lens +import Control.Monad.Trans.Maybe +import Data.Id +import Data.Kind +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Misc +import Data.Qualified +import qualified Data.Set as Set +import Data.Time.Clock +import Galley.API.Error +import Galley.API.Util +import Galley.App +import Galley.Data.Conversation +import Galley.Data.Services +import Galley.Data.Types +import Galley.Effects +import qualified Galley.Effects.BotAccess as E +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.CodeStore as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Polysemy +import Polysemy.Error +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Action +import Wire.API.Conversation.Role +import Wire.API.ErrorDescription +import Wire.API.Event.Conversation hiding (Conversation) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client +import Wire.API.Team.LegalHold +import Wire.API.Team.Member + +-- | An update to a conversation, including addition and removal of members. +-- Used to send notifications to users and to remote backends. +class IsConversationAction a where + type HasConversationActionEffects a (r :: EffectRow) :: Constraint + + conversationAction :: a -> ConversationAction + ensureAllowed :: + (IsConvMember mem, HasConversationActionEffects a r) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () + ensureAllowed _ _ _ _ = pure () + conversationActionTag' :: Qualified UserId -> a -> Action + performAction :: + ( HasConversationActionEffects a r, + Members '[ConversationStore] r + ) => + Qualified UserId -> + Local ConvId -> + Conversation -> + a -> + MaybeT (Galley r) (BotsAndMembers, a) + +-- | The action of some users joining a conversation. +data ConversationJoin = ConversationJoin + { cjUsers :: NonEmpty (Qualified UserId), + cjRole :: RoleName + } + +-- | The action of some users leaving a conversation. +newtype ConversationLeave = ConversationLeave + {clUsers :: NonEmpty (Qualified UserId)} + +-- | The action of promoting/demoting a member of a conversation. +data ConversationMemberUpdate = ConversationMemberUpdate + { cmuTarget :: Qualified UserId, + cmuUpdate :: OtherMemberUpdate + } + +-- | The action of deleting a conversation. +data ConversationDelete = ConversationDelete + +instance IsConversationAction ConversationJoin where + type + HasConversationActionEffects ConversationJoin r = + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r + + conversationAction cj = ConversationActionAddMembers (cjUsers cj) (cjRole cj) + ensureAllowed _ cj _ self = ensureConvRoleNotElevated self (cjRole cj) + conversationActionTag' _ _ = AddConversationMember + performAction qusr lcnv conv (ConversationJoin invited role) = do + let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited + + lift $ do + lusr <- liftSem $ ensureLocal lcnv qusr + ensureMemberLimit (toList (convLocalMembers conv)) newMembers + liftSem $ ensureAccess conv InviteAccess + checkLocals lusr (convTeam conv) (ulLocals newMembers) + checkRemotes lusr (ulRemotes newMembers) + checkLHPolicyConflictsLocal (ulLocals newMembers) + checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) + + addMembersToLocalConversation lcnv newMembers role + where + userIsMember u = (^. userId . to (== u)) + + checkLocals :: + Members + '[ BrigAccess, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => + Local UserId -> + Maybe TeamId -> + [UserId] -> + Galley r () + checkLocals lusr (Just tid) newUsers = do + tms <- liftSem $ E.selectTeamMembers tid newUsers + let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers + ensureAccessRole (convAccessRole conv) userMembershipMap + ensureConnectedOrSameTeam lusr newUsers + checkLocals lusr Nothing newUsers = do + ensureAccessRole (convAccessRole conv) (zip newUsers $ repeat Nothing) + ensureConnectedOrSameTeam lusr newUsers + + checkRemotes :: + Members '[BrigAccess, Error ActionError, Error FederationError, TeamStore] r => + Local UserId -> + [Remote UserId] -> + Galley r () + checkRemotes lusr remotes = do + -- if federator is not configured, we fail early, so we avoid adding + -- remote members to the database + unless (null remotes) $ do + endpoint <- federatorEndpoint + liftSem . when (isNothing endpoint) $ + throw FederationNotConfigured + ensureConnectedToRemotes lusr remotes + + checkLHPolicyConflictsLocal :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => + [UserId] -> + Galley r () + checkLHPolicyConflictsLocal newUsers = do + let convUsers = convLocalMembers conv + + allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers + + whenM (anyLegalholdActivated (lmId <$> convUsers)) $ + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + whenM (anyLegalholdActivated newUsers) $ do + unless allNewUsersGaveConsent $ + liftSem $ throw MissingLegalholdConsent + + convUsersLHStatus <- do + uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) + pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus + + if any + ( \(mem, status) -> + lmConvRoleName mem == roleNameWireAdmin + && consentGiven status == ConsentGiven + ) + convUsersLHStatus + then do + for_ convUsersLHStatus $ \(mem, status) -> + when (consentGiven status == ConsentNotGiven) $ do + qvictim <- qUntagged <$> qualifyLocal (lmId mem) + void . runMaybeT $ + updateLocalConversation lcnv qvictim Nothing $ + ConversationLeave (pure qvictim) + else liftSem $ throw MissingLegalholdConsent + + checkLHPolicyConflictsRemote :: + FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> + Galley r () + checkLHPolicyConflictsRemote _remotes = pure () + +instance IsConversationAction ConversationLeave where + type + HasConversationActionEffects ConversationLeave r = + (Members '[MemberStore] r) + conversationAction cl = ConversationActionRemoveMembers (clUsers cl) + conversationActionTag' qusr a + | pure qusr == clUsers a = LeaveConversation + | otherwise = RemoveConversationMember + performAction _qusr lcnv conv action = do + let presentVictims = filter (isConvMember lcnv conv) (toList (clUsers action)) + guard . not . null $ presentVictims + lift . liftSem $ E.deleteMembers (convId conv) (toUserList lcnv presentVictims) + pure (mempty, action) -- FUTUREWORK: should we return the filtered action here? + +instance IsConversationAction ConversationMemberUpdate where + type + HasConversationActionEffects ConversationMemberUpdate r = + (Members '[MemberStore, Error ConversationError] r) + conversationAction cmu = ConversationActionMemberUpdate (cmuTarget cmu) (cmuUpdate cmu) + conversationActionTag' _ _ = ModifyOtherConversationMember + performAction _qusr lcnv conv action = lift . liftSem $ do + void $ ensureOtherMember lcnv (cmuTarget action) conv + E.setOtherMember lcnv (cmuTarget action) (cmuUpdate action) + pure (mempty, action) + +instance IsConversationAction ConversationDelete where + type + HasConversationActionEffects ConversationDelete r = + Members '[Error FederationError, Error NotATeamMember, CodeStore, TeamStore] r + conversationAction ConversationDelete = ConversationActionDelete + ensureAllowed loc ConversationDelete conv self = + liftSem . for_ (convTeam conv) $ \tid -> do + lusr <- ensureLocal loc (convMemberId loc self) + void $ E.getTeamMember tid (tUnqualified lusr) >>= noteED @NotATeamMember + conversationActionTag' _ _ = DeleteConversation + performAction _ lcnv conv action = lift . liftSem $ do + key <- E.makeKey (tUnqualified lcnv) + E.deleteCode key ReusableCode + case convTeam conv of + Nothing -> E.deleteConversation (tUnqualified lcnv) + Just tid -> E.deleteTeamConversation tid (tUnqualified lcnv) + pure (mempty, action) + +instance IsConversationAction ConversationRename where + type + HasConversationActionEffects ConversationRename r = + Members '[Error ActionError, Error InvalidInput] r + + conversationAction = ConversationActionRename + conversationActionTag' _ _ = ModifyConversationName + performAction _ lcnv _ action = lift . liftSem $ do + cn <- rangeChecked (cupName action) + E.setConversationName (tUnqualified lcnv) cn + pure (mempty, action) + +instance IsConversationAction ConversationMessageTimerUpdate where + type HasConversationActionEffects ConversationMessageTimerUpdate r = () + conversationAction = ConversationActionMessageTimerUpdate + conversationActionTag' _ _ = ModifyConversationMessageTimer + performAction _ lcnv conv action = do + guard $ convMessageTimer conv /= cupMessageTimer action + lift . liftSem $ E.setConversationMessageTimer (tUnqualified lcnv) (cupMessageTimer action) + pure (mempty, action) + +instance IsConversationAction ConversationReceiptModeUpdate where + type HasConversationActionEffects ConversationReceiptModeUpdate r = () + conversationAction = ConversationActionReceiptModeUpdate + conversationActionTag' _ _ = ModifyConversationReceiptMode + performAction _ lcnv conv action = do + guard $ convReceiptMode conv /= Just (cruReceiptMode action) + lift . liftSem $ E.setConversationReceiptMode (tUnqualified lcnv) (cruReceiptMode action) + pure (mempty, action) + +instance IsConversationAction ConversationAccessData where + type + HasConversationActionEffects ConversationAccessData r = + Members + '[ BotAccess, + BrigAccess, + CodeStore, + Error ActionError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r + conversationAction = ConversationActionAccessUpdate + ensureAllowed _ target conv self = do + -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and + -- so on; users are not supposed to be able to make other conversations + -- have 'PrivateAccessRole' + liftSem $ + when + ( PrivateAccess `elem` cupAccess target + || PrivateAccessRole == cupAccessRole target + ) + $ throw InvalidTargetAccess + -- Team conversations incur another round of checks + case convTeam conv of + Just _ -> do + -- Access mode change might result in members being removed from the + -- conversation, so the user must have the necessary permission flag + ensureActionAllowed RemoveConversationMember self + Nothing -> + liftSem $ + when (cupAccessRole target == TeamAccessRole) $ + throw InvalidTargetAccess + conversationActionTag' _ _ = ModifyConversationAccess + performAction qusr lcnv conv action = do + guard $ convAccessData conv /= action + -- Remove conversation codes if CodeAccess is revoked + when + ( CodeAccess `elem` convAccess conv + && CodeAccess `notElem` cupAccess action + ) + $ lift $ do + key <- mkKey (tUnqualified lcnv) + liftSem $ E.deleteCode key ReusableCode + + -- Determine bots and members to be removed + let filterBotsAndMembers = filterActivated >=> filterTeammates + let current = convBotsAndMembers conv -- initial bots and members + desired <- lift . liftSem $ filterBotsAndMembers current -- desired bots and members + let toRemove = bmDiff current desired -- bots and members to be removed + + -- Update Cassandra + lift . liftSem $ E.setConversationAccess (tUnqualified lcnv) action + lift . fireAndForget $ do + -- Remove bots + traverse_ (liftSem . E.deleteBot (tUnqualified lcnv) . botMemId) (bmBots toRemove) + + -- Update current bots and members + let current' = current {bmBots = bmBots desired} + + -- Remove users and notify everyone + void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do + let rAction = ConversationLeave usersToRemove + void . runMaybeT $ performAction qusr lcnv conv rAction + notifyConversationAction qusr Nothing lcnv current' (conversationAction rAction) + pure (mempty, action) + where + filterActivated :: Member BrigAccess r => BotsAndMembers -> Sem r BotsAndMembers + filterActivated bm + | convAccessRole conv > ActivatedAccessRole + && cupAccessRole action <= ActivatedAccessRole = do + activated <- map User.userId <$> E.lookupActivatedUsers (toList (bmLocals bm)) + -- FUTUREWORK: should we also remove non-activated remote users? + pure $ bm {bmLocals = Set.fromList activated} + | otherwise = pure bm + + filterTeammates :: Member TeamStore r => BotsAndMembers -> Sem r BotsAndMembers + filterTeammates bm = do + -- In a team-only conversation we also want to remove bots and guests + case (cupAccessRole action, convTeam conv) of + (TeamAccessRole, Just tid) -> do + onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> + isJust <$> E.getTeamMember tid user + pure $ + BotsAndMembers + { bmLocals = Set.fromList onlyTeamUsers, + bmBots = mempty, + bmRemotes = mempty + } + _ -> pure bm + +-- | Update a local conversation, and notify all local and remote members. +updateLocalConversation :: + ( IsConversationAction a, + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r, + HasConversationActionEffects a r + ) => + Local ConvId -> + Qualified UserId -> + Maybe ConnId -> + a -> + MaybeT (Galley r) Event +updateLocalConversation lcnv qusr con action = do + -- retrieve conversation + (conv, self) <- + lift $ + getConversationAndMemberWithError ConvNotFound qusr (tUnqualified lcnv) + + -- perform checks + lift $ ensureConversationActionAllowed lcnv action conv self + + -- perform action + (extraTargets, action') <- performAction qusr lcnv conv action + + -- send notifications to both local and remote users + lift $ + notifyConversationAction + qusr + con + lcnv + (convBotsAndMembers conv <> extraTargets) + (conversationAction action') + +-------------------------------------------------------------------------------- +-- Utilities + +ensureConversationActionAllowed :: + ( IsConvMember mem, + IsConversationAction a, + HasConversationActionEffects a r, + Members '[Error ActionError, Error InvalidInput] r + ) => + Local x -> + a -> + Conversation -> + mem -> + Galley r () +ensureConversationActionAllowed loc action conv self = do + let tag = conversationActionTag' (convMemberId loc self) action + -- general action check + ensureActionAllowed tag self + -- check if it is a group conversation (except for rename actions) + when (tag /= ModifyConversationName) $ + liftSem $ ensureGroupConversation conv + -- extra action-specific checks + ensureAllowed loc action conv self + +-- | Add users to a conversation without performing any checks. Return extra +-- notification targets and the action performed. +addMembersToLocalConversation :: + Members '[MemberStore] r => + Local ConvId -> + UserList UserId -> + RoleName -> + MaybeT (Galley r) (BotsAndMembers, ConversationJoin) +addMembersToLocalConversation lcnv users role = do + (lmems, rmems) <- lift . liftSem $ E.createMembers (tUnqualified lcnv) (fmap (,role) users) + neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users + let action = ConversationJoin neUsers role + pure (bmFromMembers lmems rmems, action) + +notifyConversationAction :: + Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => + Qualified UserId -> + Maybe ConnId -> + Local ConvId -> + BotsAndMembers -> + ConversationAction -> + Galley r Event +notifyConversationAction quid con (qUntagged -> qcnv) targets action = do + localDomain <- viewFederationDomain + now <- liftIO getCurrentTime + let e = conversationActionToEvent now quid qcnv action + + -- notify remote participants + liftSem $ + E.runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> + F.onConversationUpdated F.clientRoutes localDomain $ + F.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action + + -- notify local participants and bots + pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index e9c90bf5a29..8d209b5765f 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -25,9 +25,9 @@ where import Control.Lens (view) import Data.Id import Galley.App -import qualified Galley.Data as Data import Galley.Effects -import qualified Galley.Intra.Client as Intra +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.ClientStore as E import Galley.Options import Galley.Types.Clients (clientIds, fromUserClients) import Imports @@ -35,25 +35,38 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClientsH :: Member BrigAccess r => UserId -> Galley r Response +getClientsH :: + Members '[BrigAccess, ClientStore] r => + UserId -> + Galley r Response getClientsH usr = do json <$> getClients usr -getClients :: Member BrigAccess r => UserId -> Galley r [ClientId] +getClients :: + Members '[BrigAccess, ClientStore] r => + UserId -> + Galley r [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then fromUserClients <$> Intra.lookupClients [usr] - else Data.lookupClients [usr] + liftSem $ + if isInternal + then fromUserClients <$> E.lookupClients [usr] + else E.getClients [usr] return $ clientIds usr clts -addClientH :: UserId ::: ClientId -> Galley r Response -addClientH (usr ::: clt) = do - Data.updateClient True usr clt +addClientH :: + Member ClientStore r => + UserId ::: ClientId -> + Galley r Response +addClientH (usr ::: clt) = liftSem $ do + E.createClient usr clt return empty -rmClientH :: UserId ::: ClientId -> Galley r Response -rmClientH (usr ::: clt) = do - Data.updateClient False usr clt +rmClientH :: + Member ClientStore r => + UserId ::: ClientId -> + Galley r Response +rmClientH (usr ::: clt) = liftSem $ do + E.deleteClient usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 182deff3267..8c4b698bf38 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -6,7 +6,7 @@ -- 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 @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Galley.API.Create ( createGroupConversation, internalCreateManagedConversationH, @@ -25,7 +24,6 @@ module Galley.API.Create where import Control.Lens hiding ((??)) -import Control.Monad.Catch import Data.Id import Data.List1 (list1) import Data.Misc (FutureWork (FutureWork)) @@ -39,21 +37,30 @@ import Galley.API.Mapping import Galley.API.One2One import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data +import Galley.Data.Conversation.Types import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.GundeckAccess as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.TeamStore as E import Galley.Intra.Push -import Galley.Types +import Galley.Types.Conversations.Members import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notTeamMember) import Galley.Types.UserList import Galley.Validation import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error +import Wire.API.Conversation hiding (Conversation, Member) import qualified Wire.API.Conversation as Public -import Wire.API.ErrorDescription (MissingLegalholdConsent) -import Wire.API.Federation.Error (federationNotImplemented) +import Wire.API.ErrorDescription +import Wire.API.Event.Conversation hiding (Conversation) +import Wire.API.Federation.Client import Wire.API.Routes.Public.Galley (ConversationResponse) import Wire.API.Routes.Public.Util import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) @@ -65,7 +72,22 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotIm -- -- See Note [managed conversations]. createGroupConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> Public.NewConvUnmanaged -> @@ -78,7 +100,22 @@ createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. internalCreateManagedConversationH :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley r Response internalCreateManagedConversationH (zusr ::: zcon ::: req) = do @@ -86,17 +123,32 @@ internalCreateManagedConversationH (zusr ::: zcon ::: req) = do handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv internalCreateManagedConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> NewConvManaged -> Galley r ConversationResponse internalCreateManagedConversation zusr zcon (NewConvManaged body) = do - case newConvTeam body of - Nothing -> throwM internalError - Just tinfo -> createTeamGroupConv zusr zcon tinfo body + tinfo <- liftSem $ note CannotCreateManagedConv (newConvTeam body) + createTeamGroupConv zusr zcon tinfo body ensureNoLegalholdConflicts :: + Members '[Error LegalHoldError, LegalHoldStore, TeamStore] r => [Remote UserId] -> [UserId] -> Galley r () @@ -104,40 +156,72 @@ ensureNoLegalholdConflicts remotes locals = do let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes whenM (anyLegalholdActivated locals) $ unlessM (allLegalholdConsentGiven locals) $ - throwErrorDescriptionType @MissingLegalholdConsent + liftSem $ throw MissingLegalholdConsent -- | A helper for creating a regular (non-team) group conversation. createRegularGroupConv :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + FederatorAccess, + Error ActionError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> NewConvUnmanaged -> Galley r ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body - checkedUsers <- checkedConvSize allUsers + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers ensureConnected lusr allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) c <- - Data.createConversation - lusr - name - (access body) - (accessRole body) - checkedUsers - (newConvTeam body) - (newConvMessageTimer body) - (newConvReceiptMode body) - (newConvUsersRole body) + liftSem $ + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } notifyCreatedConversation Nothing zusr (Just zcon) c conversationCreated zusr c -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Only supports unmanaged conversations. createTeamGroupConv :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + BrigAccess, + Error ActionError, + Error ConversationError, + Error InternalError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + TeamStore + ] + r => UserId -> ConnId -> Public.ConvTeamInfo -> @@ -145,14 +229,15 @@ createTeamGroupConv :: Galley r ConversationResponse createTeamGroupConv zusr zcon tinfo body = do lusr <- qualifyLocal zusr - name <- rangeCheckedMaybe (newConvName body) + name <- liftSem $ rangeCheckedMaybe (newConvName body) let allUsers = newConvMembers lusr body convTeam = cnvTeamId tinfo - zusrMembership <- Data.teamMember convTeam zusr + zusrMembership <- liftSem $ E.getTeamMember convTeam zusr void $ permissionCheck CreateConversation zusrMembership - checkedUsers <- checkedConvSize allUsers - convLocalMemberships <- mapM (Data.teamMember convTeam) (ulLocals allUsers) + o <- view options + checkedUsers <- liftSem $ checkedConvSize o allUsers + convLocalMemberships <- mapM (liftSem . E.getTeamMember convTeam) (ulLocals allUsers) ensureAccessRole (accessRole body) (zip (ulLocals allUsers) convLocalMemberships) -- In teams we don't have 1:1 conversations, only regular conversations. We want -- users without the 'AddRemoveConvMember' permission to still be able to create @@ -172,16 +257,20 @@ createTeamGroupConv zusr zcon tinfo body = do ensureConnectedToRemotes lusr (ulRemotes allUsers) ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) conv <- - Data.createConversation - lusr - name - (access body) - (accessRole body) - checkedUsers - (newConvTeam body) - (newConvMessageTimer body) - (newConvReceiptMode body) - (newConvUsersRole body) + liftSem $ + E.createConversation + NewConversation + { ncType = RegularConv, + ncCreator = tUnqualified lusr, + ncAccess = access body, + ncAccessRole = accessRole body, + ncName = name, + ncTeam = fmap cnvTeamId (newConvTeam body), + ncMessageTimer = newConvMessageTimer body, + ncReceiptMode = newConvReceiptMode body, + ncUsers = checkedUsers, + ncRole = newConvUsersRole body + } now <- liftIO getCurrentTime -- NOTE: We only send (conversation) events to members of the conversation notifyCreatedConversation (Just now) zusr (Just zcon) conv @@ -190,18 +279,36 @@ createTeamGroupConv zusr zcon tinfo body = do ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley r ConversationResponse +createSelfConversation :: + Members '[ConversationStore, Error InternalError] r => + UserId -> + Galley r ConversationResponse createSelfConversation zusr = do lusr <- qualifyLocal zusr - c <- Data.conversation (Id . toUUID $ zusr) + c <- liftSem $ E.getConversation (Id . toUUID $ zusr) maybe (create lusr) (conversationExisted zusr) c where create lusr = do - c <- Data.createSelfConversation lusr Nothing + c <- liftSem $ E.createSelfConversation lusr Nothing conversationCreated zusr c createOne2OneConversation :: - Members '[BrigAccess, FederatorAccess, GundeckAccess] r => + forall r. + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> NewConvUnmanaged -> @@ -209,12 +316,12 @@ createOne2OneConversation :: createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do lusr <- qualifyLocal zusr let allUsers = newConvMembers lusr j - other <- ensureOne (ulAll lusr allUsers) - when (qUntagged lusr == other) $ - throwM (invalidOp "Cannot create a 1-1 with yourself") + other <- liftSem $ ensureOne (ulAll lusr allUsers) + liftSem . when (qUntagged lusr == other) $ + throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of Just ti - | cnvManaged ti -> throwM noManagedTeamConv + | cnvManaged ti -> liftSem $ throw NoManagedTeamConv | otherwise -> do foldQualified lusr @@ -222,30 +329,44 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do (const (pure Nothing)) other Nothing -> ensureConnected lusr allUsers $> Nothing - n <- rangeCheckedMaybe (newConvName j) + n <- liftSem $ rangeCheckedMaybe (newConvName j) foldQualified lusr (createLegacyOne2OneConversationUnchecked lusr zcon n mtid) (createOne2OneConversationUnchecked lusr zcon n mtid . qUntagged) other where + verifyMembership :: TeamId -> UserId -> Galley r () verifyMembership tid u = do - membership <- Data.teamMember tid u - when (isNothing membership) $ - throwM noBindingTeamMembers + membership <- liftSem $ E.getTeamMember tid u + liftSem . when (isNothing membership) $ + throw NoBindingTeamMembers + checkBindingTeamPermissions :: + Local UserId -> + Local UserId -> + TeamId -> + Galley r (Maybe TeamId) checkBindingTeamPermissions lusr lother tid = do - zusrMembership <- Data.teamMember tid (tUnqualified lusr) + zusrMembership <- liftSem $ E.getTeamMember tid (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - Data.teamBinding tid >>= \case + liftSem (E.getTeamBinding tid) >>= \case Just Binding -> do verifyMembership tid (tUnqualified lusr) verifyMembership tid (tUnqualified lother) pure (Just tid) - Just _ -> throwM nonBindingTeam - Nothing -> throwM teamNotFound + Just _ -> liftSem $ throw NotABindingTeamMember + Nothing -> liftSem $ throw TeamNotFound createLegacyOne2OneConversationUnchecked :: - Members '[FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -254,17 +375,24 @@ createLegacyOne2OneConversationUnchecked :: Galley r ConversationResponse createLegacyOne2OneConversationUnchecked self zcon name mtid other = do lcnv <- localOne2OneConvId self other - mc <- Data.conversation (tUnqualified lcnv) + mc <- liftSem $ E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted (tUnqualified self) c Nothing -> do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) - c <- Data.createLegacyOne2OneConversation self x y name mtid + c <- liftSem $ E.createLegacyOne2OneConversation self x y name mtid notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c conversationCreated (tUnqualified self) c createOne2OneConversationUnchecked :: - Members '[FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error FederationError, + Error InternalError, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Maybe (Range 1 256 Text) -> @@ -280,7 +408,7 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId (qUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[ConversationStore, Error InternalError, FederatorAccess, GundeckAccess] r => Local ConvId -> Local UserId -> ConnId -> @@ -289,15 +417,16 @@ createOne2OneConversationLocally :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationLocally lcnv self zcon name mtid other = do - mc <- Data.conversation (tUnqualified lcnv) + mc <- liftSem $ E.getConversation (tUnqualified lcnv) case mc of Just c -> conversationExisted (tUnqualified self) c Nothing -> do - c <- Data.createOne2OneConversation lcnv self other name mtid + c <- liftSem $ E.createOne2OneConversation (tUnqualified lcnv) self other name mtid notifyCreatedConversation Nothing (tUnqualified self) (Just zcon) c conversationCreated (tUnqualified self) c createOne2OneConversationRemotely :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> @@ -306,10 +435,22 @@ createOne2OneConversationRemotely :: Qualified UserId -> Galley r ConversationResponse createOne2OneConversationRemotely _ _ _ _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createConnectConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InternalError, + Error InvalidInput, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> Connect -> @@ -323,15 +464,27 @@ createConnectConversation usr conn j = do (cRecipient j) createConnectConversationWithRemote :: + Member (Error FederationError) r => Local UserId -> Maybe ConnId -> Remote UserId -> Galley r ConversationResponse createConnectConversationWithRemote _ _ _ = - throwM federationNotImplemented + liftSem $ + throw FederationNotImplemented createLegacyConnectConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members + '[ ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error InternalError, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local UserId -> Maybe ConnId -> Local UserId -> @@ -339,18 +492,18 @@ createLegacyConnectConversation :: Galley r ConversationResponse createLegacyConnectConversation lusr conn lrecipient j = do (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) - n <- rangeCheckedMaybe (cName j) - conv <- Data.conversation (Data.localOne2OneConvId x y) + n <- liftSem $ rangeCheckedMaybe (cName j) + conv <- liftSem $ E.getConversation (Data.localOne2OneConvId x y) maybe (create x y n) (update n) conv where create x y n = do - c <- Data.createConnectConversation lusr x y n + c <- liftSem $ E.createConnectConversation x y n now <- liftIO getCurrentTime let lcid = qualifyAs lusr (Data.convId c) e = Event ConvConnect (qUntagged lcid) (qUntagged lusr) now (EdConnect j) notifyCreatedConversation Nothing (tUnqualified lusr) conn c for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers c)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -364,7 +517,7 @@ createLegacyConnectConversation lusr conn lrecipient j = do connect n conv | otherwise -> do lcid <- qualifyLocal (Data.convId conv) - mm <- Data.addMember lcid lusr + mm <- liftSem $ E.createMember lcid lusr let conv' = conv { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm @@ -384,14 +537,14 @@ createLegacyConnectConversation lusr conn lrecipient j = do localDomain <- viewFederationDomain let qconv = Qualified (Data.convId conv) localDomain n' <- case n of - Just x -> do - Data.updateConversation (Data.convId conv) x + Just x -> liftSem $ do + E.setConversationName (Data.convId conv) x return . Just $ fromRange x Nothing -> return $ Data.convName conv t <- liftIO getCurrentTime let e = Event ConvConnect qconv (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushRoute .~ RouteDirect & pushConn .~ conn @@ -401,10 +554,18 @@ createLegacyConnectConversation lusr conn lrecipient j = do ------------------------------------------------------------------------------- -- Helpers -conversationCreated :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationCreated :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationCreated usr cnv = Created <$> conversationView usr cnv -conversationExisted :: UserId -> Data.Conversation -> Galley r ConversationResponse +conversationExisted :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r ConversationResponse conversationExisted usr cnv = Existed <$> conversationView usr cnv handleConversationResponse :: ConversationResponse -> Response @@ -413,7 +574,7 @@ handleConversationResponse = \case Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) notifyCreatedConversation :: - Members '[FederatorAccess, GundeckAccess] r => + Members '[Error InternalError, FederatorAccess, GundeckAccess] r => Maybe UTCTime -> UserId -> Maybe ConnId -> @@ -429,7 +590,7 @@ notifyCreatedConversation dtime usr conn c = do -- of being added to a conversation registerRemoteConversationMemberships now localDomain c -- Notify local users - pushSome =<< mapM (toPush localDomain now) (Data.convLocalMembers c) + liftSem . E.push =<< mapM (toPush localDomain now) (Data.convLocalMembers c) where route | Data.convType c == RegularConv = RouteAny @@ -444,15 +605,23 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -localOne2OneConvId :: Local UserId -> Local UserId -> Galley r (Local ConvId) +localOne2OneConvId :: + Member (Error InvalidInput) r => + Local UserId -> + Local UserId -> + Galley r (Local ConvId) localOne2OneConvId self other = do (x, y) <- toUUIDs (tUnqualified self) (tUnqualified other) pure . qualifyAs self $ Data.localOne2OneConvId x y -toUUIDs :: UserId -> UserId -> Galley r (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: + Member (Error InvalidInput) r => + UserId -> + UserId -> + Galley r (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do - a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 - b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 + a' <- U.fromUUID (toUUID a) & note InvalidUUID4 & liftSem + b' <- U.fromUUID (toUUID b) & note InvalidUUID4 & liftSem return (a', b') accessRole :: NewConv -> AccessRole @@ -468,6 +637,6 @@ newConvMembers loc body = UserList (newConvUsers body) [] <> toUserList loc (newConvQualifiedUsers body) -ensureOne :: [a] -> Galley r a +ensureOne :: Member (Error InvalidInput) r => [a] -> Sem r a ensureOne [x] = pure x -ensureOne _ = throwM (invalidRange "One-to-one conversations can only have a single invited member") +ensureOne _ = throw (InvalidRange "One-to-one conversations can only have a single invited member") diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index fa98803c799..52cfd656b5d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -22,42 +22,57 @@ module Galley.API.CustomBackend ) where -import Control.Monad.Catch import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util import Galley.App -import qualified Galley.Data.CustomBackend as Data +import Galley.Effects.CustomBackendStore import Galley.Types import Imports hiding ((\\)) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import qualified Wire.API.CustomBackend as Public -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response +getCustomBackendByDomainH :: + Members + '[ CustomBackendStore, + Error CustomBackendError + ] + r => + Domain ::: JSON -> + Galley r Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: Domain -> Galley r Public.CustomBackend +getCustomBackendByDomain :: + Members '[CustomBackendStore, Error CustomBackendError] r => + Domain -> + Galley r Public.CustomBackend getCustomBackendByDomain domain = - Data.getCustomBackend domain >>= \case - Nothing -> throwM (customBackendNotFound domain) - Just customBackend -> pure customBackend + liftSem $ + getCustomBackend domain >>= \case + Nothing -> throw (CustomBackendNotFound domain) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley r Response +internalPutCustomBackendByDomainH :: + Members '[CustomBackendStore, Error InvalidInput] r => + Domain ::: JsonRequest CustomBackend -> + Galley r Response internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req -- simple enough to not need a separate function - Data.setCustomBackend domain customBackend + liftSem $ setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley r Response +internalDeleteCustomBackendByDomainH :: Member CustomBackendStore r => Domain ::: JSON -> Galley r Response internalDeleteCustomBackendByDomainH (domain ::: _) = do - Data.deleteCustomBackend domain + liftSem $ deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 005b93f32f5..ab555dcff61 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -17,8 +17,8 @@ module Galley.API.Error where -import Control.Monad.Catch (MonadThrow (..)) import Data.Domain (Domain, domainText) +import Data.Id import Data.Proxy import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) @@ -28,8 +28,249 @@ import Galley.Types.Teams (hardTruncationLimit) import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Polysemy +import qualified Polysemy.Error as P +import Polysemy.Internal (Append) import Servant.API.Status (KnownStatus (..)) +import Wire.API.Conversation (ConvType (..)) +import Wire.API.Conversation.Role (Action) import Wire.API.ErrorDescription +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +---------------------------------------------------------------------------- +-- Fine-grained API error types + +class APIError e where + toWai :: e -> Error + +data InternalError + = BadConvState ConvId + | BadMemberState + | NoPrekeyForUser + | CannotCreateManagedConv + | DeleteQueueFull + | InternalErrorWithDescription LText + +instance APIError InternalError where + toWai (BadConvState convId) = badConvState convId + toWai BadMemberState = mkError status500 "bad-state" "Bad internal member state." + toWai NoPrekeyForUser = internalError + toWai CannotCreateManagedConv = internalError + toWai DeleteQueueFull = deleteQueueFull + toWai (InternalErrorWithDescription t) = internalErrorWithDescription t + +data ActionError + = InvalidAction + | InvalidTargetAccess + | InvalidTargetUserOp + | ActionDenied Action + | AccessDenied + | InvalidOp ConvType + | OperationDenied String + | NotConnected + | NoAddToManaged + | BroadcastLimitExceeded + | InvalidTeamStatusUpdate + | InvalidPermissions + +instance APIError ActionError where + toWai InvalidAction = invalidActions + toWai InvalidTargetAccess = errorDescriptionTypeToWai @InvalidTargetAccess + toWai (ActionDenied action) = errorDescriptionToWai (actionDenied action) + toWai AccessDenied = accessDenied + toWai (InvalidOp RegularConv) = invalidOp "invalid operation" + toWai (InvalidOp SelfConv) = invalidSelfOp + toWai (InvalidOp One2OneConv) = invalidOne2OneOp + toWai (InvalidOp ConnectConv) = invalidConnectOp + toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p + toWai NotConnected = errorDescriptionTypeToWai @NotConnected + toWai InvalidTargetUserOp = invalidTargetUserOp + toWai NoAddToManaged = noAddToManaged + toWai BroadcastLimitExceeded = broadcastLimitExceeded + toWai InvalidTeamStatusUpdate = invalidTeamStatusUpdate + toWai InvalidPermissions = invalidPermissions + +data CustomBackendError = CustomBackendNotFound Domain + +instance APIError CustomBackendError where + toWai (CustomBackendNotFound d) = customBackendNotFound d + +data InvalidInput + = CustomRolesNotSupported + | InvalidRange LText + | InvalidUUID4 + | BulkGetMemberLimitExceeded + | InvalidPayload LText + +instance APIError InvalidInput where + toWai CustomRolesNotSupported = badRequest "Custom roles not supported" + toWai (InvalidRange t) = invalidRange t + toWai InvalidUUID4 = invalidUUID4 + toWai BulkGetMemberLimitExceeded = bulkGetMemberLimitExceeded + toWai (InvalidPayload t) = invalidPayload t + +data AuthenticationError + = ReAuthFailed + +instance APIError AuthenticationError where + toWai ReAuthFailed = reAuthFailed + +data ConversationError + = ConvAccessDenied + | ConvNotFound + | TooManyMembers + | ConvMemberNotFound + | NoBindingTeamMembers + | NoManagedTeamConv + +instance APIError ConversationError where + toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied + toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound + toWai TooManyMembers = tooManyMembers + toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound + toWai NoBindingTeamMembers = noBindingTeamMembers + toWai NoManagedTeamConv = noManagedTeamConv + +data TeamError + = NoBindingTeam + | NoAddToBinding + | NotABindingTeamMember + | NotAOneMemberTeam + | TeamNotFound + | TeamMemberNotFound + | TeamSearchVisibilityNotEnabled + | UserBindingExists + | TooManyTeamMembers + | CannotEnableLegalHoldServiceLargeTeam + +instance APIError TeamError where + toWai NoBindingTeam = noBindingTeam + toWai NoAddToBinding = noAddToBinding + toWai NotABindingTeamMember = nonBindingTeam + toWai NotAOneMemberTeam = notAOneMemberTeam + toWai TeamNotFound = teamNotFound + toWai TeamMemberNotFound = teamMemberNotFound + toWai TeamSearchVisibilityNotEnabled = teamSearchVisibilityNotEnabled + toWai UserBindingExists = userBindingExists + toWai TooManyTeamMembers = tooManyTeamMembers + toWai CannotEnableLegalHoldServiceLargeTeam = cannotEnableLegalHoldServiceLargeTeam + +data TeamFeatureError + = AppLockinactivityTimeoutTooLow + | LegalHoldFeatureFlagNotEnabled + | LegalHoldWhitelistedOnly + | DisableSsoNotImplemented + +instance APIError TeamFeatureError where + toWai AppLockinactivityTimeoutTooLow = inactivityTimeoutTooLow + toWai LegalHoldFeatureFlagNotEnabled = legalHoldFeatureFlagNotEnabled + toWai LegalHoldWhitelistedOnly = legalHoldWhitelistedOnly + toWai DisableSsoNotImplemented = disableSsoNotImplemented + +data TeamNotificationError + = InvalidTeamNotificationId + +instance APIError TeamNotificationError where + toWai InvalidTeamNotificationId = invalidTeamNotificationId + +instance APIError FederationError where + toWai = federationErrorToWai + +data LegalHoldError + = MissingLegalholdConsent + | NoUserLegalHoldConsent + | LegalHoldNotEnabled + | LegalHoldDisableUnimplemented + | LegalHoldServiceInvalidKey + | LegalHoldServiceBadResponse + | UserLegalHoldAlreadyEnabled + | LegalHoldServiceNotRegistered + | LegalHoldCouldNotBlockConnections + | UserLegalHoldIllegalOperation + | TooManyTeamMembersOnTeamWithLegalhold + | NoLegalHoldDeviceAllocated + | UserLegalHoldNotPending + +instance APIError LegalHoldError where + toWai MissingLegalholdConsent = errorDescriptionTypeToWai @MissingLegalholdConsent + toWai NoUserLegalHoldConsent = userLegalHoldNoConsent + toWai LegalHoldNotEnabled = legalHoldNotEnabled + toWai LegalHoldDisableUnimplemented = legalHoldDisableUnimplemented + toWai LegalHoldServiceInvalidKey = legalHoldServiceInvalidKey + toWai LegalHoldServiceBadResponse = legalHoldServiceBadResponse + toWai UserLegalHoldAlreadyEnabled = userLegalHoldAlreadyEnabled + toWai LegalHoldServiceNotRegistered = legalHoldServiceNotRegistered + toWai LegalHoldCouldNotBlockConnections = legalHoldCouldNotBlockConnections + toWai UserLegalHoldIllegalOperation = userLegalHoldIllegalOperation + toWai TooManyTeamMembersOnTeamWithLegalhold = tooManyTeamMembersOnTeamWithLegalhold + toWai NoLegalHoldDeviceAllocated = noLegalHoldDeviceAllocated + toWai UserLegalHoldNotPending = userLegalHoldNotPending + +data CodeError = CodeNotFound + +instance APIError CodeError where + toWai CodeNotFound = errorDescriptionTypeToWai @CodeNotFound + +data ClientError = UnknownClient + +instance APIError ClientError where + toWai UnknownClient = errorDescriptionTypeToWai @UnknownClient + +throwED :: + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Sem r a +throwED = P.throw mkErrorDescription + +noteED :: + forall e code label desc r a. + ( e ~ ErrorDescription code label desc, + KnownSymbol desc, + Member (P.Error e) r + ) => + Maybe a -> + Sem r a +noteED = P.note (mkErrorDescription :: e) + +type AllErrorEffects = + '[ P.Error ActionError, + P.Error AuthenticationError, + P.Error ClientError, + P.Error CodeError, + P.Error ConversationError, + P.Error CustomBackendError, + P.Error FederationError, + P.Error InternalError, + P.Error InvalidInput, + P.Error LegalHoldError, + P.Error TeamError, + P.Error TeamFeatureError, + P.Error TeamNotificationError, + P.Error NotATeamMember + ] + +mapAllErrors :: Member (P.Error Error) r => Sem (Append AllErrorEffects r) a -> Sem r a +mapAllErrors = + P.mapError errorDescriptionToWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + . P.mapError toWai + +---------------------------------------------------------------------------- +-- Error description integration errorDescriptionToWai :: forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). @@ -49,22 +290,8 @@ errorDescriptionTypeToWai :: Error errorDescriptionTypeToWai = errorDescriptionToWai (mkErrorDescription :: e) -throwErrorDescription :: - (KnownStatus code, KnownSymbol lbl, MonadThrow m) => - ErrorDescription code lbl desc -> - m a -throwErrorDescription = throwM . errorDescriptionToWai - -throwErrorDescriptionType :: - forall e (code :: Nat) (lbl :: Symbol) (desc :: Symbol) m a. - ( KnownStatus code, - KnownSymbol lbl, - KnownSymbol desc, - MonadThrow m, - e ~ ErrorDescription code lbl desc - ) => - m a -throwErrorDescriptionType = throwErrorDescription (mkErrorDescription :: e) +---------------------------------------------------------------------------- +-- Other errors internalError :: Error internalError = internalErrorWithDescription "internal error" @@ -123,6 +350,12 @@ noBindingTeam = mkError status403 "no-binding-team" "Operation allowed only on b notAOneMemberTeam :: Error notAOneMemberTeam = mkError status403 "not-one-member-team" "Can only delete teams with a single member." +badConvState :: ConvId -> Error +badConvState cid = + mkError status500 "bad-state" $ + "Connect conversation with more than 2 members: " + <> LT.pack (show cid) + bulkGetMemberLimitExceeded :: Error bulkGetMemberLimitExceeded = mkError diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 5889cb12a1a..348bec3dec9 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -18,32 +18,34 @@ module Galley.API.Federation where import Brig.Types.Connection (Relation (Accepted)) import Control.Lens (itraversed, (<.>)) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Maybe (runMaybeT) import Data.ByteString.Conversion (toByteString') import Data.Containers.ListUtils (nubOrd) -import Data.Domain +import Data.Domain (Domain) import Data.Id (ConvId, UserId) import Data.Json.Util (Base64ByteString (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified -import Data.Range +import Data.Range (Range (fromRange)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT -import Galley.API.Error (invalidPayload) +import Galley.API.Action +import Galley.API.Error import qualified Galley.API.Mapping as Mapping -import Galley.API.Message (MessageMetadata (..), UserType (..), postQualifiedOtrMessage, sendLocalMessages) -import Galley.API.Update (notifyConversationMetadataUpdate) -import qualified Galley.API.Update as API +import Galley.API.Message import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Effects -import Galley.Intra.User (getConnections) -import Galley.Types.Conversations.Members (LocalMember (..), defMemberStatus) +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.MemberStore as E +import Galley.Types.Conversations.Members +import Galley.Types.UserList (UserList (UserList)) import Imports +import Polysemy.Error (Error, throw) import Servant (ServerT) import Servant.API.Generic (ToServantApi) import Servant.Server.Generic (genericServerT) @@ -53,52 +55,41 @@ import Wire.API.Conversation.Action import Wire.API.Conversation.Member (OtherMember (..)) import qualified Wire.API.Conversation.Role as Public import Wire.API.Event.Conversation -import Wire.API.Federation.API.Common -import Wire.API.Federation.API.Galley - ( ConversationUpdate (..), - GetConversationsRequest (..), - GetConversationsResponse (..), - LeaveConversationRequest (..), - LeaveConversationResponse (..), - MessageSendRequest (..), - MessageSendResponse (..), - NewRemoteConversation (..), - RemoteMessage (..), - UserDeletedConversationsNotification, - ) -import qualified Wire.API.Federation.API.Galley as FederationAPIGalley +import Wire.API.Federation.API.Common (EmptyResponse (..)) +import qualified Wire.API.Federation.API.Galley as F +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection -import Wire.API.Routes.Public.Galley.Responses (RemoveFromConversationError (..)) -import Wire.API.ServantProto (FromProto (..)) +import Wire.API.Routes.Public.Galley.Responses +import Wire.API.ServantProto import Wire.API.User.Client (userClientMap) -federationSitemap :: ServerT (ToServantApi FederationAPIGalley.Api) (Galley GalleyEffects) +federationSitemap :: ServerT (ToServantApi F.Api) (Galley GalleyEffects) federationSitemap = genericServerT $ - FederationAPIGalley.Api - { FederationAPIGalley.onConversationCreated = onConversationCreated, - FederationAPIGalley.getConversations = getConversations, - FederationAPIGalley.onConversationUpdated = onConversationUpdated, - FederationAPIGalley.leaveConversation = leaveConversation, - FederationAPIGalley.onMessageSent = onMessageSent, - FederationAPIGalley.sendMessage = sendMessage, - FederationAPIGalley.onUserDeleted = onUserDeleted + F.Api + { F.onConversationCreated = onConversationCreated, + F.getConversations = getConversations, + F.onConversationUpdated = onConversationUpdated, + F.leaveConversation = leaveConversation, + F.onMessageSent = onMessageSent, + F.sendMessage = sendMessage, + F.onUserDeleted = onUserDeleted } onConversationCreated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - NewRemoteConversation ConvId -> + F.NewRemoteConversation ConvId -> Galley r () onConversationCreated domain rc = do let qrc = fmap (toRemoteUnsafe domain) rc loc <- qualifyLocal () - let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (rcNonCreatorMembers rc))) + let (localUserIds, _) = partitionQualified loc (map omQualifiedId (toList (F.rcNonCreatorMembers rc))) addedUserIds <- addLocalUsersToRemoteConv - (rcCnvId qrc) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrc)) + (F.rcCnvId qrc) + (qUntagged (F.rcRemoteOrigUserId qrc)) localUserIds let connectedMembers = @@ -109,30 +100,32 @@ onConversationCreated domain rc = do (const True) . omQualifiedId ) - (rcNonCreatorMembers rc) + (F.rcNonCreatorMembers rc) -- Make sure to notify only about local users connected to the adder - let qrcConnected = qrc {rcNonCreatorMembers = connectedMembers} + let qrcConnected = qrc {F.rcNonCreatorMembers = connectedMembers} forM_ (fromNewRemoteConversation loc qrcConnected) $ \(mem, c) -> do let event = Event ConvCreate - (qUntagged (rcCnvId qrcConnected)) - (qUntagged (FederationAPIGalley.rcRemoteOrigUserId qrcConnected)) - (rcTime qrcConnected) + (qUntagged (F.rcCnvId qrcConnected)) + (qUntagged (F.rcRemoteOrigUserId qrcConnected)) + (F.rcTime qrcConnected) (EdConversation c) pushConversationEvent Nothing event [qUnqualified . Public.memId $ mem] [] getConversations :: + Member ConversationStore r => Domain -> - GetConversationsRequest -> - Galley r GetConversationsResponse -getConversations domain (GetConversationsRequest uid cids) = do + F.GetConversationsRequest -> + Galley r F.GetConversationsResponse +getConversations domain (F.GetConversationsRequest uid cids) = do let ruid = toRemoteUnsafe domain uid localDomain <- viewFederationDomain - GetConversationsResponse - . mapMaybe (Mapping.conversationToRemote localDomain ruid) - <$> Data.localConversations cids + liftSem $ + F.GetConversationsResponse + . mapMaybe (Mapping.conversationToRemote localDomain ruid) + <$> E.getConversations cids getLocalUsers :: Domain -> NonEmpty (Qualified UserId) -> [UserId] getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomain) . toList @@ -140,20 +133,22 @@ getLocalUsers localDomain = map qUnqualified . filter ((== localDomain) . qDomai -- | Update the local database with information on conversation members joining -- or leaving. Finally, push out notifications to local users. onConversationUpdated :: - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members '[BrigAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - ConversationUpdate -> + F.ConversationUpdate -> Galley r () onConversationUpdated requestingDomain cu = do localDomain <- viewFederationDomain loc <- qualifyLocal () - let rconvId = toRemoteUnsafe requestingDomain (cuConvId cu) + let rconvId = toRemoteUnsafe requestingDomain (F.cuConvId cu) qconvId = qUntagged rconvId -- Note: we generally do not send notifications to users that are not part of -- the conversation (from our point of view), to prevent spam from the remote -- backend. See also the comment below. - (presentUsers, allUsersArePresent) <- Data.filterRemoteConvMembers (cuAlreadyPresentUsers cu) qconvId + (presentUsers, allUsersArePresent) <- + liftSem $ + E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId -- Perform action, and determine extra notification targets. -- @@ -163,30 +158,30 @@ onConversationUpdated requestingDomain cu = do -- are not in the conversations are being removed or have their membership state -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - (mActualAction, extraTargets) <- case cuAction cu of + (mActualAction, extraTargets) <- case F.cuAction cu of ConversationActionAddMembers toAdd role -> do let (localUsers, remoteUsers) = partitionQualified loc toAdd - addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (cuOrigUserId cu) localUsers + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers let allAddedUsers = map (qUntagged . qualifyAs loc) addedLocalUsers <> map qUntagged remoteUsers case allAddedUsers of [] -> pure (Nothing, []) -- If no users get added, its like no action was performed. (u : us) -> pure (Just $ ConversationActionAddMembers (u :| us) role, addedLocalUsers) - ConversationActionRemoveMembers toRemove -> do + ConversationActionRemoveMembers toRemove -> liftSem $ do let localUsers = getLocalUsers localDomain toRemove - Data.removeLocalMembersFromRemoteConv rconvId localUsers - pure (Just $ cuAction cu, []) - ConversationActionRename _ -> pure (Just $ cuAction cu, []) - ConversationActionMessageTimerUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionMemberUpdate _ _ -> pure (Just $ cuAction cu, []) - ConversationActionReceiptModeUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionAccessUpdate _ -> pure (Just $ cuAction cu, []) - ConversationActionDelete -> do - Data.removeLocalMembersFromRemoteConv rconvId presentUsers - pure (Just $ cuAction cu, []) + E.deleteMembersInRemoteConversation rconvId localUsers + pure (Just $ F.cuAction cu, []) + ConversationActionRename _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMessageTimerUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionMemberUpdate _ _ -> pure (Just $ F.cuAction cu, []) + ConversationActionReceiptModeUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionAccessUpdate _ -> pure (Just $ F.cuAction cu, []) + ConversationActionDelete -> liftSem $ do + E.deleteMembersInRemoteConversation rconvId presentUsers + pure (Just $ F.cuAction cu, []) unless allUsersArePresent $ Log.warn $ - Log.field "conversation" (toByteString' (cuConvId cu)) + Log.field "conversation" (toByteString' (F.cuConvId cu)) . Log.field "domain" (toByteString' requestingDomain) . Log.msg ( "Attempt to send notification about conversation update \ @@ -196,20 +191,20 @@ onConversationUpdated requestingDomain cu = do -- Send notifications for_ mActualAction $ \action -> do - let event = conversationActionToEvent (cuTime cu) (cuOrigUserId cu) qconvId action + let event = conversationActionToEvent (F.cuTime cu) (F.cuOrigUserId cu) qconvId action targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? pushConversationEvent Nothing event targets [] addLocalUsersToRemoteConv :: - Member BrigAccess r => + Members '[BrigAccess, MemberStore] r => Remote ConvId -> Qualified UserId -> [UserId] -> Galley r (Set UserId) addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do - connStatus <- getConnections localUsers (Just [qAdder]) (Just Accepted) + connStatus <- liftSem $ E.getConnections localUsers (Just [qAdder]) (Just Accepted) let localUserIdsSet = Set.fromList localUsers connected = Set.fromList $ fmap csv2From connStatus unconnected = Set.difference localUserIdsSet connected @@ -225,49 +220,69 @@ addLocalUsersToRemoteConv remoteConvId qAdder localUsers = do -- Update the local view of the remote conversation by adding only those local -- users that are connected to the adder - Data.addLocalMembersToRemoteConv remoteConvId connectedList + liftSem $ E.createMembersInRemoteConversation remoteConvId connectedList pure connected -- FUTUREWORK: actually return errors as part of the response instead of throwing leaveConversation :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => Domain -> - LeaveConversationRequest -> - Galley r LeaveConversationResponse + F.LeaveConversationRequest -> + Galley r F.LeaveConversationResponse leaveConversation requestingDomain lc = do - let leaver = Qualified (lcLeaver lc) requestingDomain - lcnv <- qualifyLocal (lcConvId lc) + let leaver = Qualified (F.lcLeaver lc) requestingDomain + lcnv <- qualifyLocal (F.lcConvId lc) fmap - ( LeaveConversationResponse + ( F.LeaveConversationResponse . maybe (Left RemoveFromConversationErrorUnchanged) Right ) . runMaybeT . void - . API.updateLocalConversation lcnv leaver Nothing - . ConversationActionRemoveMembers + . updateLocalConversation lcnv leaver Nothing + . ConversationLeave . pure $ leaver -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients onMessageSent :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[BotAccess, GundeckAccess, ExternalAccess, MemberStore] r => Domain -> - RemoteMessage ConvId -> + F.RemoteMessage ConvId -> Galley r () onMessageSent domain rmUnqualified = do let rm = fmap (toRemoteUnsafe domain) rmUnqualified - convId = qUntagged $ rmConversation rm + convId = qUntagged $ F.rmConversation rm msgMetadata = MessageMetadata - { mmNativePush = rmPush rm, - mmTransient = rmTransient rm, - mmNativePriority = rmPriority rm, - mmData = rmData rm + { mmNativePush = F.rmPush rm, + mmTransient = F.rmTransient rm, + mmNativePriority = F.rmPriority rm, + mmData = F.rmData rm } - recipientMap = userClientMap $ rmRecipients rm + recipientMap = userClientMap $ F.rmRecipients rm msgs = toMapOf (itraversed <.> itraversed) recipientMap - (members, allMembers) <- Data.filterRemoteConvMembers (Map.keys recipientMap) convId + (members, allMembers) <- + liftSem $ + E.selectRemoteMembers (Map.keys recipientMap) (F.rmConversation rm) unless allMembers $ Log.warn $ Log.field "conversation" (toByteString' (qUnqualified convId)) @@ -278,7 +293,16 @@ onMessageSent domain rmUnqualified = do ByteString ) localMembers <- sequence $ Map.fromSet mkLocalMember (Set.fromList members) - void $ sendLocalMessages (rmTime rm) (rmSender rm) (rmSenderClient rm) Nothing convId localMembers msgMetadata msgs + void $ + sendLocalMessages + (F.rmTime rm) + (F.rmSender rm) + (F.rmSenderClient rm) + Nothing + convId + localMembers + msgMetadata + msgs where -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-875 mkLocalMember :: UserId -> Galley r LocalMember @@ -292,32 +316,52 @@ onMessageSent domain rmUnqualified = do } sendMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + Error InvalidInput, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => Domain -> - MessageSendRequest -> - Galley r MessageSendResponse + F.MessageSendRequest -> + Galley r F.MessageSendResponse sendMessage originDomain msr = do - let sender = Qualified (msrSender msr) originDomain - msg <- either err pure (fromProto (fromBase64ByteString (msrRawMessage msr))) - MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (msrConvId msr) msg + let sender = Qualified (F.msrSender msr) originDomain + msg <- either err pure (fromProto (fromBase64ByteString (F.msrRawMessage msr))) + F.MessageSendResponse <$> postQualifiedOtrMessage User sender Nothing (F.msrConvId msr) msg where - err = throwM . invalidPayload . LT.pack + err = liftSem . throw . InvalidPayload . LT.pack onUserDeleted :: - Members '[FederatorAccess, FireAndForget, ExternalAccess, GundeckAccess] r => + Members + '[ ConversationStore, + FederatorAccess, + FireAndForget, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => Domain -> - UserDeletedConversationsNotification -> + F.UserDeletedConversationsNotification -> Galley r EmptyResponse onUserDeleted origDomain udcn = do - let deletedUser = toRemoteUnsafe origDomain (FederationAPIGalley.udcnUser udcn) + let deletedUser = toRemoteUnsafe origDomain (F.udcnUser udcn) untaggedDeletedUser = qUntagged deletedUser - convIds = FederationAPIGalley.udcnConversations udcn + convIds = F.udcnConversations udcn spawnMany $ fromRange convIds <&> \c -> do lc <- qualifyLocal c - mconv <- Data.conversation c - Data.removeRemoteMembersFromLocalConv c (pure deletedUser) + mconv <- liftSem $ E.getConversation c + liftSem $ E.deleteMembers c (UserList [] [deletedUser]) for_ mconv $ \conv -> do when (isRemoteMember deletedUser (Data.convRemoteMembers conv)) $ case Data.convType conv of @@ -331,6 +375,7 @@ onUserDeleted origDomain udcn = do Public.SelfConv -> pure () Public.RegularConv -> do let action = ConversationActionRemoveMembers (pure untaggedDeletedUser) + botsAndMembers = convBotsAndMembers conv - void $ notifyConversationMetadataUpdate untaggedDeletedUser Nothing lc botsAndMembers action + void $ notifyConversationAction untaggedDeletedUser Nothing lc botsAndMembers action pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5cc940a4579..e37590085ea 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -25,23 +25,20 @@ module Galley.API.Internal ) where -import qualified Cassandra as Cql import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Except (runExceptT) import Data.Data (Proxy (Proxy)) import Data.Id as Id import Data.List1 (maybeList1) import Data.Qualified import Data.Range import Data.String.Conversions (cs) -import qualified Data.Text as T import Data.Time import GHC.TypeLits (AppendSymbol) import qualified Galley.API.Clients as Clients import qualified Galley.API.Create as Create import qualified Galley.API.CustomBackend as CustomBackend -import Galley.API.Error (throwErrorDescriptionType) +import Galley.API.Error import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import qualified Galley.API.One2One as One2One @@ -51,10 +48,18 @@ import qualified Galley.API.Teams as Teams import Galley.API.Teams.Features (DoAuth (..)) import qualified Galley.API.Teams.Features as Features import qualified Galley.API.Update as Update -import Galley.API.Util (JSON, isMember, qualifyLocal, viewFederationDomain) +import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import Galley.Effects +import Galley.Effects.ClientStore +import Galley.Effects.ConversationStore +import Galley.Effects.FederatorAccess +import Galley.Effects.GundeckAccess +import Galley.Effects.MemberStore +import Galley.Effects.Paging +import Galley.Effects.TeamStore import qualified Galley.Intra.Push as Intra import qualified Galley.Queue as Q import Galley.Types @@ -64,14 +69,16 @@ import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..), import Galley.Types.Teams hiding (MemberLeave) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility +import Galley.Types.UserList import Imports hiding (head) import Network.HTTP.Types (status200) import Network.Wai -import Network.Wai.Predicate hiding (err) +import Network.Wai.Predicate hiding (Error, err) import qualified Network.Wai.Predicate as P import Network.Wai.Routing hiding (route, toList) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) import Network.Wai.Utilities.ZAuth +import Polysemy.Error import Servant.API hiding (JSON) import qualified Servant.API as Servant import Servant.API.Generic @@ -80,10 +87,11 @@ import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) -import Wire.API.ErrorDescription (MissingLegalholdConsent) -import Wire.API.Federation.API.Galley (UserDeletedConversationsNotification (UserDeletedConversationsNotification)) +import Wire.API.Conversation.Action (ConversationAction (ConversationActionRemoveMembers)) +import Wire.API.ErrorDescription +import Wire.API.Federation.API.Galley (ConversationUpdate (..), UserDeletedConversationsNotification (UserDeletedConversationsNotification)) import qualified Wire.API.Federation.API.Galley as FedGalley -import Wire.API.Federation.Client (executeFederated) +import Wire.API.Federation.Client (FederationError) import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) import Wire.API.Routes.Public (ZOptConn, ZUser) @@ -174,6 +182,12 @@ data InternalApi routes = InternalApi iTeamFeatureStatusConferenceCallingGet :: routes :- IFeatureStatusGet 'Public.TeamFeatureConferenceCalling, + iTeamFeatureStatusSelfDeletingMessagesPut :: + routes + :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, + iTeamFeatureStatusSelfDeletingMessagesGet :: + routes + :- IFeatureStatusGet 'Public.TeamFeatureSelfDeletingMessages, -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members for all conversations the user was in iDeleteUser :: @@ -281,6 +295,8 @@ servantSitemap = iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, + iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, iDeleteUser = rmUser, iConnect = Create.createConnectConversation, iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation @@ -288,7 +304,15 @@ servantSitemap = iGetTeamFeature :: forall a r. - Public.KnownTeamFeatureName a => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (Features.GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -296,7 +320,15 @@ iGetTeamFeature getter = Features.getFeatureStatus @a getter DontDoAuth iPutTeamFeature :: forall a r. - Public.KnownTeamFeatureName a => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> TeamId -> Public.TeamFeatureStatus a -> @@ -466,20 +498,36 @@ sitemap = do capture "tid" rmUser :: - forall r. - Members '[BrigAccess, ExternalAccess, FederatorAccess, GundeckAccess] r => + forall p1 p2 r. + ( p1 ~ CassandraPaging, + p2 ~ InternalPaging, + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + ExternalAccess, + FederatorAccess, + GundeckAccess, + ListItems p1 ConvId, + ListItems p1 (Remote ConvId), + ListItems p2 TeamId, + MemberStore, + TeamStore + ] + r + ) => UserId -> Maybe ConnId -> Galley r () rmUser user conn = do - let n = toRange (Proxy @100) :: Range 1 100 Int32 - nRange1000 = rcast n :: Range 1 1000 Int32 - tids <- Data.teamIdsForPagination user Nothing n + let nRange1000 = toRange (Proxy @1000) :: Range 1 1000 Int32 + tids <- liftSem $ listTeams user Nothing maxBound leaveTeams tids allConvIds <- Query.conversationIdsPageFrom user (GetPaginatedConversationIds Nothing nRange1000) lusr <- qualifyLocal user goConvPages lusr nRange1000 allConvIds - Data.eraseClients user + + liftSem $ deleteClients user where goConvPages :: Local UserId -> Range 1 1000 Int32 -> ConvIdsPage -> Galley r () goConvPages lusr range page = do @@ -493,59 +541,86 @@ rmUser user conn = do newCids <- Query.conversationIdsPageFrom usr nextQuery goConvPages lusr range newCids - leaveTeams tids = for_ (Cql.result tids) $ \tid -> do - mems <- Data.teamMembersForFanout tid + leaveTeams page = for_ (pageItems page) $ \tid -> do + mems <- getTeamMembersForFanout tid uncheckedDeleteTeamMember user conn tid user mems - leaveTeams =<< Cql.liftClient (Cql.nextPage tids) + page' <- liftSem $ listTeams user (Just (pageState page)) maxBound + leaveTeams page' - -- FUTUREWORK: Ensure that remote members of local convs get notified of this activity - leaveLocalConversations :: [ConvId] -> Galley r () + leaveLocalConversations :: Member MemberStore r => [ConvId] -> Galley r () leaveLocalConversations ids = do localDomain <- viewFederationDomain - cc <- Data.localConversations ids + let qUser = Qualified user localDomain + cc <- liftSem $ getConversations ids + now <- liftIO getCurrentTime pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing - One2OneConv -> Data.removeMember user (Data.convId c) >> return Nothing - ConnectConv -> Data.removeMember user (Data.convId c) >> return Nothing + One2OneConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing + ConnectConv -> liftSem $ deleteMembers (Data.convId c) (UserList [user] []) $> Nothing RegularConv | user `isMember` Data.convLocalMembers c -> do - Data.removeLocalMembersFromLocalConv (Data.convId c) (pure user) - now <- liftIO getCurrentTime + liftSem $ deleteMembers (Data.convId c) (UserList [user] []) let e = Event MemberLeave (Qualified (Data.convId c) localDomain) (Qualified user localDomain) now - (EdMembersLeave (QualifiedUserIdList [Qualified user localDomain])) - return $ + (EdMembersLeave (QualifiedUserIdList [qUser])) + for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) + pure $ Intra.newPushLocal ListComplete user (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect | otherwise -> return Nothing + for_ (maybeList1 (catMaybes pp)) - Intra.push + (liftSem . push) + + -- FUTUREWORK: This could be optimized to reduce the number of RPCs + -- made. When a team is deleted the burst of RPCs created here could + -- lead to performance issues. We should cover this in a performance + -- test. + notifyRemoteMembers :: UTCTime -> Qualified UserId -> ConvId -> Remote [UserId] -> Galley r () + notifyRemoteMembers now qUser cid remotes = do + localDomain <- viewFederationDomain + let convUpdate = + ConversationUpdate + { cuTime = now, + cuOrigUserId = qUser, + cuConvId = cid, + cuAlreadyPresentUsers = tUnqualified remotes, + cuAction = ConversationActionRemoveMembers (pure qUser) + } + let rpc = FedGalley.onConversationUpdated FedGalley.clientRoutes localDomain convUpdate + liftSem (runFederatedEither remotes rpc) + >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) leaveRemoteConversations :: Local UserId -> Range 1 FedGalley.UserDeletedNotificationMaxConvs [Remote ConvId] -> Galley r () leaveRemoteConversations lusr cids = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = FedGalley.onUserDeleted FedGalley.clientRoutes (tDomain lusr) userDelete - res <- runExceptT (executeFederated (tDomain remoteConvs) rpc) - case res of - -- FUTUREWORK: Add a retry mechanism if there are federation errrors. - -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 - Left federationError -> do - Log.err $ - Log.msg $ - T.unwords - [ "Federation error while notifying remote backends of a user deletion (Galley).", - "user_id: " <> (cs . show) lusr, - "details: " <> (cs . show) federationError - ] - pure () - Right _ -> pure () + liftSem (runFederatedEither remoteConvs rpc) + >>= logAndIgnoreError "Error in onUserDeleted call" (tUnqualified lusr) + + -- FUTUREWORK: Add a retry mechanism if there are federation errrors. + -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 + logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Galley r () + logAndIgnoreError message usr res = do + case res of + Left federationError -> do + Log.err + ( Log.msg + ( "Federation error while notifying remote backends of a user deletion (Galley). " + <> message + <> " " + <> (cs . show $ federationError) + ) + . Log.field "user" (show usr) + ) + Right _ -> pure () deleteLoop :: Galley r () deleteLoop = liftGalley0 $ do @@ -570,11 +645,17 @@ safeForever funName action = threadDelay 60000000 -- pause to keep worst-case noise in logs manageable guardLegalholdPolicyConflictsH :: - Member BrigAccess r => + Members + '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + TeamStore + ] + r => (JsonRequest GuardLegalholdPolicyConflicts ::: JSON) -> Galley r Response guardLegalholdPolicyConflictsH (req ::: _) = do glh <- fromJsonBody req guardLegalholdPolicyConflicts (glhProtectee glh) (glhUserClients glh) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem (throw MissingLegalholdConsent))) pure pure $ Network.Wai.Utilities.setStatus status200 empty diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 48d9eed39a9..998ea8ed751 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -38,7 +38,6 @@ import Brig.Types.Provider import Brig.Types.Team.LegalHold hiding (userId) import Control.Exception (assert) import Control.Lens (view, (^.)) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) @@ -52,14 +51,16 @@ import Galley.API.Query (iterateConversations) import Galley.API.Update (removeMemberFromLocalConv) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) -import qualified Galley.Data.LegalHold as LegalHoldData -import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import Galley.Effects +import Galley.Effects.BrigAccess +import qualified Galley.Effects.LegalHoldStore as LegalHoldData +import Galley.Effects.Paging +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamStore import qualified Galley.External.LegalHoldService as LHService -import qualified Galley.Intra.Client as Client -import Galley.Intra.User (getConnectionsUnqualified, putConnectionInternal) import qualified Galley.Options as Opts import Galley.Types (LocalMember, lmConvRoleName, lmId) import Galley.Types.Teams as Team @@ -67,42 +68,83 @@ import Imports import Network.HTTP.Types (status200, status404) import Network.HTTP.Types.Status (status201, status204) import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus, _3) -import Network.Wai.Utilities as Wai +import Network.Wai.Predicate hiding (Error, or, result, setStatus, _3) +import Network.Wai.Utilities as Wai hiding (Error) +import Polysemy.Error import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvType (..)) import Wire.API.Conversation.Role (roleNameWireAdmin) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import Wire.API.Routes.Internal.Brig.Connection import qualified Wire.API.Team.Feature as Public import Wire.API.Team.LegalHold (LegalholdProtectee (LegalholdPlusFederationNotImplemented)) import qualified Wire.API.Team.LegalHold as Public -assertLegalHoldEnabledForTeam :: TeamId -> Galley r () -assertLegalHoldEnabledForTeam tid = unlessM (isLegalHoldEnabledForTeam tid) $ throwM legalHoldNotEnabled +assertLegalHoldEnabledForTeam :: + Members '[Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r () +assertLegalHoldEnabledForTeam tid = + unlessM (isLegalHoldEnabledForTeam tid) $ + liftSem $ throw LegalHoldNotEnabled -isLegalHoldEnabledForTeam :: TeamId -> Galley r Bool +isLegalHoldEnabledForTeam :: + Members '[LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r Bool isLegalHoldEnabledForTeam tid = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> do pure False FeatureLegalHoldDisabledByDefault -> do - statusValue <- Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid + statusValue <- + liftSem $ + Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid return $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - isTeamLegalholdWhitelisted tid - -createSettingsH :: UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> Galley r Response + liftSem $ LegalHoldData.isTeamLegalholdWhitelisted tid + +createSettingsH :: + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId ::: TeamId ::: JsonRequest Public.NewLegalHoldService ::: JSON -> + Galley r Response createSettingsH (zusr ::: tid ::: req ::: _) = do newService <- fromJsonBody req setStatus status201 . json <$> createSettings zusr tid newService -createSettings :: UserId -> TeamId -> Public.NewLegalHoldService -> Galley r Public.ViewLegalHoldService +createSettings :: + Members + '[ Error ActionError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId -> + TeamId -> + Public.NewLegalHoldService -> + Galley r Public.ViewLegalHoldService createSettings zusr tid newService = do assertLegalHoldEnabledForTeam tid - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) @@ -110,29 +152,78 @@ createSettings zusr tid newService = do void $ permissionCheck ChangeLegalHoldTeamSettings zusrMembership (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LHService.validateServiceKey (newLegalHoldServiceKey newService) - >>= maybe (throwM legalHoldServiceInvalidKey) pure + >>= liftSem . note LegalHoldServiceInvalidKey LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key - LegalHoldData.createSettings service + liftSem $ LegalHoldData.createSettings service pure . viewLegalHoldService $ service -getSettingsH :: UserId ::: TeamId ::: JSON -> Galley r Response +getSettingsH :: + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId ::: TeamId ::: JSON -> + Galley r Response getSettingsH (zusr ::: tid ::: _) = do json <$> getSettings zusr tid -getSettings :: UserId -> TeamId -> Galley r Public.ViewLegalHoldService +getSettings :: + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId -> + TeamId -> + Galley r Public.ViewLegalHoldService getSettings zusr tid = do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature Public.TeamFeatureLegalHold) zusrMembership isenabled <- isLegalHoldEnabledForTeam tid - mresult <- LegalHoldData.getSettings tid + mresult <- liftSem $ LegalHoldData.getSettings tid pure $ case (isenabled, mresult) of (False, _) -> Public.ViewLegalHoldServiceDisabled (True, Nothing) -> Public.ViewLegalHoldServiceNotConfigured (True, Just result) -> viewLegalHoldService result removeSettingsH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamFeatureStore, + TeamMemberStore InternalPaging + ] + r => UserId ::: TeamId ::: JsonRequest Public.RemoveLegalHoldSettingsRequest ::: JSON -> Galley r Response removeSettingsH (zusr ::: tid ::: req ::: _) = do @@ -141,7 +232,34 @@ removeSettingsH (zusr ::: tid ::: req ::: _) = do pure noContent removeSettings :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore, + TeamMemberStore p + ] + r + ) => UserId -> TeamId -> Public.RemoveLegalHoldSettingsRequest -> @@ -149,7 +267,7 @@ removeSettings :: removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do assertNotWhitelisting assertLegalHoldEnabledForTeam tid - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) @@ -158,24 +276,50 @@ removeSettings zusr tid (Public.RemoveLegalHoldSettingsRequest mPassword) = do ensureReAuthorised zusr mPassword removeSettings' tid where - assertNotWhitelisting :: Galley r () + assertNotWhitelisting :: Member (Error LegalHoldError) r => Galley r () assertNotWhitelisting = do view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure () FeatureLegalHoldDisabledByDefault -> pure () FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldDisableUnimplemented + liftSem $ throw LegalHoldDisableUnimplemented -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: - forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + forall p r. + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore, + TeamMemberStore p + ] + r + ) => TeamId -> Galley r () -removeSettings' tid = do - -- Loop through team members and run this action. - Data.withTeamMembersWithChunks tid action - LegalHoldData.removeSettings tid +removeSettings' tid = + withChunks + (\mps -> liftSem (listTeamMembers tid mps maxBound)) + action where action :: [TeamMember] -> Galley r () action membs = do @@ -188,20 +332,27 @@ removeSettings' tid = do removeLHForUser :: TeamMember -> Galley r () removeLHForUser member = do let uid = member ^. Team.userId - Client.removeLegalHoldClientFromUser uid + liftSem $ removeLegalHoldClientFromUser uid LHService.removeLegalHold tid uid changeLegalholdStatus tid uid (member ^. legalHoldStatus) UserLegalHoldDisabled -- (support for withdrawing consent is not planned yet.) -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response +getUserStatusH :: + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response getUserStatusH (_zusr ::: tid ::: uid ::: _) = do json <$> getUserStatus tid uid -getUserStatus :: TeamId -> UserId -> Galley r Public.UserLegalHoldStatusResponse +getUserStatus :: + forall r. + Members '[Error InternalError, Error TeamError, LegalHoldStore, TeamStore] r => + TeamId -> + UserId -> + Galley r Public.UserLegalHoldStatusResponse getUserStatus tid uid = do - mTeamMember <- Data.teamMember tid uid - teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember + teamMember <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid let status = view legalHoldStatus teamMember (mlk, lcid) <- case status of UserLegalHoldNoConsent -> pure (Nothing, Nothing) @@ -212,14 +363,14 @@ getUserStatus tid uid = do where makeResponseDetails :: Galley r (Maybe LastPrekey, Maybe ClientId) makeResponseDetails = do - mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid + mLastKey <- liftSem $ fmap snd <$> LegalHoldData.selectPendingPrekeys uid lastKey <- case mLastKey of Nothing -> do Log.err . Log.msg $ "expected to find a prekey for user: " <> toByteString' uid <> " but none was found" - throwM internalError + liftSem $ throw NoPrekeyForUser Just lstKey -> pure lstKey let clientId = clientIdFromPrekey . unpackLastPrekey $ lastKey pure (Just lastKey, Just clientId) @@ -228,7 +379,28 @@ getUserStatus tid uid = do -- @withdrawExplicitConsentH@ (lots of corner cases we'd have to implement for that to pan -- out). grantConsentH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: JSON -> Galley r Response grantConsentH (zusr ::: tid ::: _) = do @@ -241,24 +413,68 @@ data GrantConsentResult | GrantConsentAlreadyGranted grantConsent :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> Galley r GrantConsentResult grantConsent zusr tid = do - userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid zusr + userLHStatus <- + liftSem $ + note TeamMemberNotFound + =<< fmap (view legalHoldStatus) <$> getTeamMember tid zusr case userLHStatus of - Nothing -> - throwM teamMemberNotFound - Just lhs@UserLegalHoldNoConsent -> + lhs@UserLegalHoldNoConsent -> changeLegalholdStatus tid zusr lhs UserLegalHoldDisabled $> GrantConsentSuccess - Just UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted - Just UserLegalHoldPending -> pure GrantConsentAlreadyGranted - Just UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted + UserLegalHoldEnabled -> pure GrantConsentAlreadyGranted + UserLegalHoldPending -> pure GrantConsentAlreadyGranted + UserLegalHoldDisabled -> pure GrantConsentAlreadyGranted -- | Request to provision a device on the legal hold service for a user requestDeviceH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response requestDeviceH (zusr ::: tid ::: uid ::: _) = do @@ -272,7 +488,29 @@ data RequestDeviceResult requestDevice :: forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -282,14 +520,14 @@ requestDevice zusr tid uid = do Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.requestDevice") - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - member <- maybe (throwM teamMemberNotFound) pure =<< Data.teamMember tid uid + member <- liftSem $ note TeamMemberNotFound =<< getTeamMember tid uid case member ^. legalHoldStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> liftSem $ throw UserLegalHoldAlreadyEnabled lhs@UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice lhs lhs@UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice lhs - UserLegalHoldNoConsent -> throwM userLegalHoldNoConsent + UserLegalHoldNoConsent -> liftSem $ throw NoUserLegalHoldConsent where -- Wire's LH service that galley is usually calling here is idempotent in device creation, -- ie. it returns the existing device on multiple calls to `/init`, like here: @@ -302,13 +540,13 @@ requestDevice zusr tid uid = do provisionLHDevice userLHStatus = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added - LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) + liftSem $ LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) changeLegalholdStatus tid uid userLHStatus UserLegalHoldPending - Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' + liftSem $ notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' requestDeviceFromService :: Galley r (LastPrekey, [Prekey]) requestDeviceFromService = do - LegalHoldData.dropPendingPrekeys uid + liftSem $ LegalHoldData.dropPendingPrekeys uid lhDevice <- LHService.requestNewDevice tid uid let NewLegalHoldClient prekeys lastKey = lhDevice return (lastKey, prekeys) @@ -319,7 +557,30 @@ requestDevice zusr tid uid = do -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. approveDeviceH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest Public.ApproveLegalHoldForUserRequest ::: JSON -> Galley r Response approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do @@ -328,7 +589,30 @@ approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do pure empty approveDevice :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -340,39 +624,63 @@ approveDevice zusr tid uid connId (Public.ApproveLegalHoldForUserRequest mPasswo Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.approveDevice") - unless (zusr == uid) (throwM accessDenied) + liftSem . unless (zusr == uid) $ throw AccessDenied assertOnTeam uid tid ensureReAuthorised zusr mPassword - userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> Data.teamMember tid uid + userLHStatus <- + liftSem $ + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid assertUserLHPending userLHStatus - mPreKeys <- LegalHoldData.selectPendingPrekeys uid + mPreKeys <- liftSem $ LegalHoldData.selectPendingPrekeys uid (prekeys, lastPrekey') <- case mPreKeys of Nothing -> do Log.info $ Log.msg @Text "No prekeys found" - throwM noLegalHoldDeviceAllocated + liftSem $ throw NoLegalHoldDeviceAllocated Just keys -> pure keys - clientId <- Client.addLegalHoldClientToUser uid connId prekeys lastPrekey' + clientId <- liftSem $ addLegalHoldClientToUser uid connId prekeys lastPrekey' -- Note: teamId could be passed in the getLegalHoldAuthToken request instead of lookup up again - -- Note: both 'Client.getLegalHoldToken' and 'ensureReAuthorized' check the password - -- Note: both 'Client.getLegalHoldToken' and this function in 'assertOnTeam' above + -- Note: both 'getLegalHoldToken' and 'ensureReAuthorized' check the password + -- Note: both 'getLegalHoldToken' and this function in 'assertOnTeam' above -- checks that the user is part of a binding team -- FUTUREWORK: reduce double checks - legalHoldAuthToken <- Client.getLegalHoldAuthToken uid mPassword + legalHoldAuthToken <- liftSem $ getLegalHoldAuthToken uid mPassword LHService.confirmLegalHold clientId tid uid legalHoldAuthToken -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) changeLegalholdStatus tid uid userLHStatus UserLegalHoldEnabled where - assertUserLHPending :: UserLegalHoldStatus -> Galley r () - assertUserLHPending userLHStatus = do + assertUserLHPending :: Member (Error LegalHoldError) r => UserLegalHoldStatus -> Galley r () + assertUserLHPending userLHStatus = liftSem $ do case userLHStatus of - UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled + UserLegalHoldEnabled -> throw UserLegalHoldAlreadyEnabled UserLegalHoldPending -> pure () - UserLegalHoldDisabled -> throwM userLegalHoldNotPending - UserLegalHoldNoConsent -> throwM userLegalHoldNotPending + UserLegalHoldDisabled -> throw UserLegalHoldNotPending + UserLegalHoldNoConsent -> throw UserLegalHoldNotPending disableForUserH :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId ::: TeamId ::: UserId ::: JsonRequest Public.DisableLegalHoldForUserRequest ::: JSON -> Galley r Response disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do @@ -387,7 +695,29 @@ data DisableLegalHoldForUserResponse disableForUser :: forall r. - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> TeamId -> UserId -> @@ -397,10 +727,12 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.disableForUser") - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck ChangeLegalHoldUserSettings zusrMembership - userLHStatus <- maybe defUserLegalHoldStatus (view legalHoldStatus) <$> Data.teamMember tid uid + userLHStatus <- + liftSem $ + maybe defUserLegalHoldStatus (view legalHoldStatus) <$> getTeamMember tid uid if not $ userLHEnabled userLHStatus then pure DisableLegalHoldWasNotEnabled else disableLH userLHStatus $> DisableLegalHoldSuccess @@ -408,7 +740,7 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = disableLH :: UserLegalHoldStatus -> Galley r () disableLH userLHStatus = do ensureReAuthorised zusr mPassword - Client.removeLegalHoldClientFromUser uid + liftSem $ removeLegalHoldClientFromUser uid LHService.removeLegalHold tid uid -- TODO: send event at this point (see also: related TODO in this module in -- 'approveDevice' and @@ -419,7 +751,28 @@ disableForUser zusr tid uid (Public.DisableLegalHoldForUserRequest mPassword) = -- or disabled, make sure the affected connections are screened for policy conflict (anybody -- with no-consent), and put those connections in the appropriate blocked state. changeLegalholdStatus :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => TeamId -> UserId -> UserLegalHoldStatus -> @@ -430,39 +783,43 @@ changeLegalholdStatus tid uid old new = do UserLegalHoldEnabled -> case new of UserLegalHoldEnabled -> noop UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> liftSem update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldPending -> case new of - UserLegalHoldEnabled -> update + UserLegalHoldEnabled -> liftSem update UserLegalHoldPending -> noop - UserLegalHoldDisabled -> update >> removeblocks + UserLegalHoldDisabled -> liftSem update >> removeblocks UserLegalHoldNoConsent -> illegal -- UserLegalHoldDisabled -> case new of UserLegalHoldEnabled -> illegal - UserLegalHoldPending -> addblocks >> update + UserLegalHoldPending -> addblocks >> liftSem update UserLegalHoldDisabled -> {- in case the last attempt crashed -} removeblocks UserLegalHoldNoConsent -> {- withdrawing consent is not (yet?) implemented -} illegal -- UserLegalHoldNoConsent -> case new of UserLegalHoldEnabled -> illegal UserLegalHoldPending -> illegal - UserLegalHoldDisabled -> update + UserLegalHoldDisabled -> liftSem update UserLegalHoldNoConsent -> noop where update = LegalHoldData.setUserLegalHoldStatus tid uid new - removeblocks = void $ putConnectionInternal (RemoveLHBlocksInvolving uid) + removeblocks = void . liftSem $ putConnectionInternal (RemoveLHBlocksInvolving uid) addblocks = do blockNonConsentingConnections uid handleGroupConvPolicyConflicts uid new noop = pure () - illegal = throwM userLegalHoldIllegalOperation + illegal = liftSem $ throw UserLegalHoldIllegalOperation -- FUTUREWORK: make this async? -blockNonConsentingConnections :: forall r. Member BrigAccess r => UserId -> Galley r () +blockNonConsentingConnections :: + forall r. + Members '[BrigAccess, Error LegalHoldError, Error NotATeamMember, LegalHoldStore, TeamStore] r => + UserId -> + Galley r () blockNonConsentingConnections uid = do - conns <- getConnectionsUnqualified [uid] Nothing Nothing + conns <- liftSem $ getConnectionsUnqualified [uid] Nothing Nothing errmsgs <- do conflicts <- mconcat <$> findConflicts conns blockConflicts uid conflicts @@ -470,35 +827,37 @@ blockNonConsentingConnections uid = do [] -> pure () msgs@(_ : _) -> do Log.warn $ Log.msg @String msgs - throwM legalHoldCouldNotBlockConnections + liftSem $ throw LegalHoldCouldNotBlockConnections where findConflicts :: [ConnectionStatus] -> Galley r [[UserId]] findConflicts conns = do let (FutureWork @'Public.LegalholdPlusFederationNotImplemented -> _remoteUids, localUids) = (undefined, csTo <$> conns) -- FUTUREWORK: Handle remoteUsers here when federation is implemented for (chunksOf 32 localUids) $ \others -> do - teamsOfUsers <- Data.usersTeams others + teamsOfUsers <- liftSem $ getUsersTeams others filterM (fmap (== ConsentNotGiven) . checkConsent teamsOfUsers) others blockConflicts :: UserId -> [UserId] -> Galley r [String] blockConflicts _ [] = pure [] blockConflicts userLegalhold othersToBlock@(_ : _) = do - status <- putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) + status <- liftSem $ putConnectionInternal (BlockForMissingLHConsent userLegalhold othersToBlock) pure $ ["blocking users failed: " <> show (status, othersToBlock) | status /= status200] -setTeamLegalholdWhitelisted :: TeamId -> Galley r () -setTeamLegalholdWhitelisted tid = do - LegalHoldData.setTeamLegalholdWhitelisted tid +setTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () +setTeamLegalholdWhitelisted tid = + liftSem $ + LegalHoldData.setTeamLegalholdWhitelisted tid -setTeamLegalholdWhitelistedH :: TeamId -> Galley r Response +setTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response setTeamLegalholdWhitelistedH tid = do empty <$ setTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelisted :: TeamId -> Galley r () -unsetTeamLegalholdWhitelisted tid = do - LegalHoldData.unsetTeamLegalholdWhitelisted tid +unsetTeamLegalholdWhitelisted :: Member LegalHoldStore r => TeamId -> Galley r () +unsetTeamLegalholdWhitelisted tid = + liftSem $ + LegalHoldData.unsetTeamLegalholdWhitelisted tid -unsetTeamLegalholdWhitelistedH :: TeamId -> Galley r Response +unsetTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response unsetTeamLegalholdWhitelistedH tid = do () <- error @@ -507,9 +866,9 @@ unsetTeamLegalholdWhitelistedH tid = do \before you enable the end-point." setStatus status204 empty <$ unsetTeamLegalholdWhitelisted tid -getTeamLegalholdWhitelistedH :: TeamId -> Galley r Response -getTeamLegalholdWhitelistedH tid = do - lhEnabled <- isTeamLegalholdWhitelisted tid +getTeamLegalholdWhitelistedH :: Member LegalHoldStore r => TeamId -> Galley r Response +getTeamLegalholdWhitelistedH tid = liftSem $ do + lhEnabled <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if lhEnabled then setStatus status200 empty @@ -530,7 +889,26 @@ getTeamLegalholdWhitelistedH tid = do -- contains the hypothetical new LH status of `uid`'s so it can be consulted instead of the -- one from the database. handleGroupConvPolicyConflicts :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + Error FederationError, + Error TeamError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamStore + ] + r => UserId -> UserLegalHoldStatus -> Galley r () diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 42bebf1fe3b..11995a36faf 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -29,10 +29,9 @@ import Data.Misc import qualified Data.Set as Set import Galley.API.Util import Galley.App -import qualified Galley.Data as Data import Galley.Effects -import qualified Galley.Intra.Client as Intra -import Galley.Intra.User (getUser) +import Galley.Effects.BrigAccess +import Galley.Effects.TeamStore import Galley.Options import Galley.Types.Teams hiding (self) import Imports @@ -44,7 +43,7 @@ import Wire.API.User.Client as Client data LegalholdConflicts = LegalholdConflicts guardQualifiedLegalholdPolicyConflicts :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => LegalholdProtectee -> QualifiedUserClients -> Galley r (Either LegalholdConflicts ()) @@ -63,7 +62,7 @@ guardQualifiedLegalholdPolicyConflicts protectee qclients = do -- This is a fallback safeguard that shouldn't get triggered if backend and clients work as -- intended. guardLegalholdPolicyConflicts :: - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => LegalholdProtectee -> UserClients -> Galley r (Either LegalholdConflicts ()) @@ -78,7 +77,7 @@ guardLegalholdPolicyConflicts (ProtectedUser self) otherClients = do guardLegalholdPolicyConflictsUid :: forall r. - Member BrigAccess r => + Members '[BrigAccess, TeamStore] r => UserId -> UserClients -> Galley r (Either LegalholdConflicts ()) @@ -90,7 +89,7 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do otherUids = nub $ Map.keys . userClients $ otherClients when (nub otherUids /= [self {- if all other clients belong to us, there can be no conflict -}]) $ do - allClients :: UserClientsFull <- lift $ Intra.lookupClientsFull (nub $ self : otherUids) + allClients :: UserClientsFull <- lift . liftSem $ lookupClientsFull (nub $ self : otherUids) let selfClients :: [Client.Client] = allClients @@ -126,11 +125,11 @@ guardLegalholdPolicyConflictsUid self otherClients = runExceptT $ do . Client.clientCapabilities checkConsentMissing :: Galley r Bool - checkConsentMissing = do + checkConsentMissing = liftSem $ do -- (we could also get the profile from brig. would make the code slightly more -- concise, but not really help with the rpc back-and-forth, so, like, why?) mbUser <- accountUser <$$> getUser self - mbTeamMember <- join <$> for (mbUser >>= userTeam) (`Data.teamMember` self) + mbTeamMember <- join <$> for (mbUser >>= userTeam) (`getTeamMember` self) let lhStatus = maybe defUserLegalHoldStatus (view legalHoldStatus) mbTeamMember pure (lhStatus == UserLegalHoldNoConsent) diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index 9ee604c32b2..3d193b2f6c8 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -26,27 +26,32 @@ module Galley.API.Mapping ) where -import Control.Monad.Catch import Data.Domain (Domain) import Data.Id (UserId, idToText) import Data.Qualified +import Galley.API.Error import Galley.API.Util (qualifyLocal) import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Data.Types (convId) import Galley.Types.Conversations.Members import Imports -import Network.HTTP.Types.Status -import Network.Wai.Utilities.Error +import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Log import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member (..)) +import qualified Wire.API.Conversation as Conversation import Wire.API.Federation.API.Galley -- | View for a given user of a stored conversation. -- -- Throws "bad-state" when the user is not part of the conversation. -conversationView :: UserId -> Data.Conversation -> Galley r Conversation +conversationView :: + Member (Error InternalError) r => + UserId -> + Data.Conversation -> + Galley r Conversation conversationView uid conv = do luid <- qualifyLocal uid let mbConv = conversationViewMaybe luid conv @@ -58,8 +63,7 @@ conversationView uid conv = do +++ idToText uid +++ val " is not a member of conv " +++ idToText (convId conv) - throwM badState - badState = mkError status500 "bad-state" "Bad internal member state." + liftSem $ throw BadMemberState -- | View for a given user of a stored conversation. -- @@ -131,9 +135,9 @@ conversationToRemote localDomain ruid conv = do -- | Convert a local conversation member (as stored in the DB) to a publicly -- facing 'Member' structure. -localMemberToSelf :: Local x -> LocalMember -> Member +localMemberToSelf :: Local x -> LocalMember -> Conversation.Member localMemberToSelf loc lm = - Member + Conversation.Member { memId = qUntagged . qualifyAs loc . lmId $ lm, memService = lmService lm, memOtrMutedStatus = msOtrMutedStatus st, diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 5f03241147f..4bd82de30d7 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -24,11 +24,15 @@ import Data.Time.Clock (UTCTime, getCurrentTime) import Galley.API.LegalHold.Conflicts (guardQualifiedLegalholdPolicyConflicts) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data import Galley.Data.Services as Data import Galley.Effects -import qualified Galley.External as External -import qualified Galley.Intra.Client as Intra +import Galley.Effects.BrigAccess +import Galley.Effects.ClientStore +import Galley.Effects.ConversationStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess +import Galley.Effects.GundeckAccess hiding (Push) +import Galley.Effects.MemberStore import Galley.Intra.Push import Galley.Options (optSettings, setIntraListing) import qualified Galley.Types.Clients as Clients @@ -39,7 +43,7 @@ import qualified System.Logger.Class as Log import Wire.API.Event.Conversation import qualified Wire.API.Federation.API.Brig as FederatedBrig import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError, executeFederated) +import Wire.API.Federation.Client (FederationError) import Wire.API.Federation.Error (federationErrorToWai) import Wire.API.Message import Wire.API.Team.LegalHold @@ -180,31 +184,43 @@ getRemoteClients :: Galley r (Map (Domain, UserId) (Set ClientId)) getRemoteClients remoteMembers = -- concatenating maps is correct here, because their sets of keys are disjoint - mconcat . map tUnqualified - <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain + liftSem $ + mconcat . map tUnqualified + <$> runFederatedConcurrently (map rmId remoteMembers) getRemoteClientsFromDomain where getRemoteClientsFromDomain (qUntagged -> Qualified uids domain) = Map.mapKeys (domain,) . fmap (Set.map pubClientId) . userMap <$> FederatedBrig.getUserClients FederatedBrig.clientRoutes (FederatedBrig.GetUserClients uids) postRemoteOtrMessage :: - Member FederatorAccess r => + Members '[ConversationStore, FederatorAccess] r => Qualified UserId -> - Qualified ConvId -> + Remote ConvId -> LByteString -> Galley r (PostOtrResponse MessageSendingStatus) postRemoteOtrMessage sender conv rawMsg = do let msr = FederatedGalley.MessageSendRequest - { FederatedGalley.msrConvId = qUnqualified conv, + { FederatedGalley.msrConvId = tUnqualified conv, FederatedGalley.msrSender = qUnqualified sender, FederatedGalley.msrRawMessage = Base64ByteString rawMsg } rpc = FederatedGalley.sendMessage FederatedGalley.clientRoutes (qDomain sender) msr - FederatedGalley.msResponse <$> runFederatedGalley (qDomain conv) rpc + liftSem $ FederatedGalley.msResponse <$> runFederated conv rpc postQualifiedOtrMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserType -> Qualified UserId -> Maybe ConnId -> @@ -212,7 +228,7 @@ postQualifiedOtrMessage :: QualifiedNewOtrMessage -> Galley r (PostOtrResponse MessageSendingStatus) postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do - alive <- lift $ Data.isConvAlive convId + alive <- lift . liftSem $ isConversationAlive convId localDomain <- viewFederationDomain now <- liftIO getCurrentTime let nowMillis = toUTCTimeMillis now @@ -220,12 +236,12 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do senderUser = qUnqualified sender let senderClient = qualifiedNewOtrSender msg unless alive $ do - lift $ Data.deleteConversation convId + lift . liftSem $ deleteConversation convId throwError MessageNotSentConversationNotFound -- conversation members - localMembers <- lift $ Data.members convId - remoteMembers <- lift $ Data.lookupRemoteMembers convId + localMembers <- lift . liftSem $ getLocalMembers convId + remoteMembers <- lift . liftSem $ getRemoteMembers convId let localMemberIds = lmId <$> localMembers localMemberMap :: Map UserId LocalMember @@ -242,10 +258,10 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- get local clients localClients <- - lift $ + lift . liftSem $ if isInternal - then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else Data.lookupClients localMemberIds + then Clients.fromUserClients <$> lookupClients localMemberIds + else getClients localMemberIds let qualifiedLocalClients = Map.mapKeys (localDomain,) . makeUserMap (Set.fromList (map lmId localMembers)) @@ -300,7 +316,7 @@ postQualifiedOtrMessage senderType sender mconn convId msg = runExceptT $ do -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: - Members '[BotAccess, GundeckAccess, ExternalAccess] r => + Members '[BotAccess, GundeckAccess, ExternalAccess, FederatorAccess] r => UTCTime -> Qualified UserId -> ClientId -> @@ -317,7 +333,8 @@ sendMessages now sender senderClient mconn conv localMemberMap metadata messages | localDomain == dom = sendLocalMessages now sender senderClient mconn (Qualified conv localDomain) localMemberMap metadata | otherwise = - sendRemoteMessages dom now sender senderClient conv metadata + sendRemoteMessages (toRemoteUnsafe dom ()) now sender senderClient conv metadata + mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap where byDomain :: Map (Domain, UserId, ClientId) a -> Map Domain (Map (UserId, ClientId) a) @@ -354,7 +371,9 @@ sendLocalMessages now sender senderClient mconn conv localMemberMap metadata loc pure mempty sendRemoteMessages :: - Domain -> + forall r x. + Member FederatorAccess r => + Remote x -> UTCTime -> Qualified UserId -> ClientId -> @@ -362,7 +381,7 @@ sendRemoteMessages :: MessageMetadata -> Map (UserId, ClientId) Text -> Galley r (Set (UserId, ClientId)) -sendRemoteMessages domain now sender senderClient conv metadata messages = handle <=< runExceptT $ do +sendRemoteMessages domain now sender senderClient conv metadata messages = (handle =<<) $ do let rcpts = foldr (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) @@ -384,14 +403,14 @@ sendRemoteMessages domain now sender senderClient conv metadata messages = handl -- backend has only one domain so we just pick it from the environment. originDomain <- viewFederationDomain let rpc = FederatedGalley.onMessageSent FederatedGalley.clientRoutes originDomain rm - executeFederated domain rpc + liftSem $ runFederatedEither domain rpc where handle :: Either FederationError a -> Galley r (Set (UserId, ClientId)) handle (Right _) = pure mempty handle (Left e) = do Log.warn $ Log.field "conversation" (toByteString' conv) - Log.~~ Log.field "domain" (toByteString' domain) + Log.~~ Log.field "domain" (toByteString' (tDomain domain)) Log.~~ Log.field "exception" (encode (federationErrorToWai e)) Log.~~ Log.msg ("Remote message sending failed" :: Text) pure (Map.keysSet messages) @@ -431,7 +450,7 @@ runMessagePush :: MessagePush -> Galley r () runMessagePush cnv mp = do - pushSome (userPushes mp) + liftSem $ push (userPushes mp) pushToBots (botPushes mp) where pushToBots :: [(BotMember, Event)] -> Galley r () @@ -440,7 +459,7 @@ runMessagePush cnv mp = do if localDomain /= qDomain cnv then unless (null pushes) $ do Log.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show cnv) - else External.deliverAndDeleteAsync (qUnqualified cnv) pushes + else liftSem $ deliverAndDeleteAsync (qUnqualified cnv) pushes newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event newMessageEvent convId sender senderClient dat time receiverClient cipherText = diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index d9978a18b2d..1458e9c464c 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -24,20 +24,27 @@ where import Data.Id import Data.Qualified -import Galley.App (Galley) -import qualified Galley.Data as Data +import Galley.App (Galley, liftSem) +import Galley.Data.Conversation +import Galley.Effects.ConversationStore +import Galley.Effects.MemberStore import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (..)) import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.UserList (UserList (..)) import Imports +import Polysemy -iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> Galley r UpsertOne2OneConversationResponse -iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do +iUpsertOne2OneConversation :: + forall r. + Members '[ConversationStore, MemberStore] r => + UpsertOne2OneConversationRequest -> + Galley r UpsertOne2OneConversationResponse +iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = liftSem $ do let convId = fromMaybe (one2OneConvId (qUntagged uooLocalUser) (qUntagged uooRemoteUser)) uooConvId - let dolocal :: Local ConvId -> Galley r () + let dolocal :: Local ConvId -> Sem r () dolocal lconvId = do - mbConv <- Data.conversation (tUnqualified lconvId) + mbConv <- getConversation (tUnqualified lconvId) case mbConv of Nothing -> do let members = @@ -46,27 +53,36 @@ iUpsertOne2OneConversation UpsertOne2OneConversationRequest {..} = do (LocalActor, Excluded) -> UserList [] [] (RemoteActor, Included) -> UserList [] [uooRemoteUser] (RemoteActor, Excluded) -> UserList [] [] - unless (null members) $ - Data.createConnectConversationWithRemote lconvId uooLocalUser members + unless (null members) . void $ + createConnectConversationWithRemote + (tUnqualified lconvId) + (tUnqualified uooLocalUser) + members Just conv -> do case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do - void $ Data.addMember lconvId uooLocalUser - unless (null (Data.convRemoteMembers conv)) $ - Data.acceptConnect (tUnqualified lconvId) - (LocalActor, Excluded) -> Data.removeMember (tUnqualified uooLocalUser) (tUnqualified lconvId) + void $ createMember lconvId uooLocalUser + unless (null (convRemoteMembers conv)) $ + acceptConnectConversation (tUnqualified lconvId) + (LocalActor, Excluded) -> + deleteMembers + (tUnqualified lconvId) + (UserList [tUnqualified uooLocalUser] []) (RemoteActor, Included) -> do - void $ Data.addMembers lconvId (UserList [] [uooRemoteUser]) - unless (null (Data.convLocalMembers conv)) $ - Data.acceptConnect (tUnqualified lconvId) - (RemoteActor, Excluded) -> Data.removeRemoteMembersFromLocalConv (tUnqualified lconvId) (pure uooRemoteUser) - doremote :: Remote ConvId -> Galley r () + void $ createMembers (tUnqualified lconvId) (UserList [] [uooRemoteUser]) + unless (null (convLocalMembers conv)) $ + acceptConnectConversation (tUnqualified lconvId) + (RemoteActor, Excluded) -> + deleteMembers + (tUnqualified lconvId) + (UserList [] [uooRemoteUser]) + doremote :: Remote ConvId -> Sem r () doremote rconvId = case (uooActor, uooActorDesiredMembership) of (LocalActor, Included) -> do - Data.addLocalMembersToRemoteConv rconvId [tUnqualified uooLocalUser] + createMembersInRemoteConversation rconvId [tUnqualified uooLocalUser] (LocalActor, Excluded) -> do - Data.removeLocalMembersFromRemoteConv rconvId [tUnqualified uooLocalUser] + deleteMembersInRemoteConversation rconvId [tUnqualified uooLocalUser] (RemoteActor, _) -> pure () foldQualified uooLocalUser dolocal doremote convId diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 900e4b052ff..e4213142718 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -162,6 +162,12 @@ servantSitemap = GalleyAPI.teamFeatureStatusConferenceCallingGet = getFeatureStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal . DoAuth, + GalleyAPI.teamFeatureStatusSelfDeletingMessagesGet = + getFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal + . DoAuth, + GalleyAPI.teamFeatureStatusSelfDeletingMessagesPut = + setFeatureStatus @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal + . DoAuth, GalleyAPI.featureAllFeatureConfigsGet = Features.getAllFeatureConfigs, GalleyAPI.featureConfigLegalHoldGet = Features.getFeatureConfig @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, GalleyAPI.featureConfigSSOGet = Features.getFeatureConfig @'Public.TeamFeatureSSO Features.getSSOStatusInternal, @@ -171,7 +177,8 @@ servantSitemap = GalleyAPI.featureConfigAppLockGet = Features.getFeatureConfig @'Public.TeamFeatureAppLock Features.getAppLockInternal, GalleyAPI.featureConfigFileSharingGet = Features.getFeatureConfig @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, GalleyAPI.featureConfigClassifiedDomainsGet = Features.getFeatureConfig @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal + GalleyAPI.featureConfigConferenceCallingGet = Features.getFeatureConfig @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, + GalleyAPI.featureConfigSelfDeletingMessagesGet = Features.getFeatureConfig @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal } sitemap :: Routes ApiBuilder (Galley GalleyEffects) () diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 0666e32b506..e8983fc1ff3 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -35,7 +35,6 @@ where import qualified Cassandra as C import Control.Lens (sequenceAOf) -import Control.Monad.Catch (throwM) import Control.Monad.Trans.Except import qualified Data.ByteString.Lazy as LBS import Data.Code @@ -51,38 +50,48 @@ import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import Galley.Cassandra.Paging import qualified Galley.Data.Types as Data import Galley.Effects +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ListItems as E +import qualified Galley.Effects.MemberStore as E import Galley.Types import Galley.Types.Conversations.Members import Galley.Types.Conversations.Roles import Imports import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (result, setStatus) -import Network.Wai.Utilities -import qualified Network.Wai.Utilities.Error as Wai +import Network.Wai.Predicate hiding (Error, result, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import qualified System.Logger.Class as Logger import UnliftIO (pooledForConcurrentlyN) import Wire.API.Conversation (ConversationCoverView (..)) import qualified Wire.API.Conversation as Public import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound) +import Wire.API.ErrorDescription import Wire.API.Federation.API.Galley (gcresConvs) import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationError, executeFederated) -import Wire.API.Federation.Error +import Wire.API.Federation.Client (FederationError (FederationUnexpectedBody), executeFederated) import qualified Wire.API.Provider.Bot as Public import qualified Wire.API.Routes.MultiTablePaging as Public -getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley r Response +getBotConversationH :: + Members '[ConversationStore, Error ConversationError] r => + BotId ::: ConvId ::: JSON -> + Galley r Response getBotConversationH (zbot ::: zcnv ::: _) = do json <$> getBotConversation zbot zcnv -getBotConversation :: BotId -> ConvId -> Galley r Public.BotConvView +getBotConversation :: + Members '[ConversationStore, Error ConversationError] r => + BotId -> + ConvId -> + Galley r Public.BotConvView getBotConversation zbot zcnv = do - (c, _) <- getConversationAndMemberWithError (errorDescriptionTypeToWai @ConvNotFound) (botUserId zbot) zcnv + (c, _) <- getConversationAndMemberWithError ConvNotFound (botUserId zbot) zcnv domain <- viewFederationDomain let cmems = mapMaybe (mkMember domain) (toList (Data.convLocalMembers c)) pure $ Public.botConvView zcnv (Data.convName c) cmems @@ -94,12 +103,27 @@ getBotConversation zbot zcnv = do | otherwise = Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) -getUnqualifiedConversation :: UserId -> ConvId -> Galley r Public.Conversation +getUnqualifiedConversation :: + Members '[ConversationStore, Error ConversationError, Error InternalError] r => + UserId -> + ConvId -> + Galley r Public.Conversation getUnqualifiedConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv Mapping.conversationView zusr c -getConversation :: UserId -> Qualified ConvId -> Galley r Public.Conversation +getConversation :: + forall r. + Members + '[ ConversationStore, + Error ConversationError, + Error FederationError, + Error InternalError + ] + r => + UserId -> + Qualified ConvId -> + Galley r Public.Conversation getConversation zusr cnv = do lusr <- qualifyLocal zusr foldQualified @@ -111,33 +135,40 @@ getConversation zusr cnv = do getRemoteConversation :: Remote ConvId -> Galley r Public.Conversation getRemoteConversation remoteConvId = do conversations <- getRemoteConversations zusr [remoteConvId] - case conversations of - [] -> throwErrorDescriptionType @ConvNotFound + liftSem $ case conversations of + [] -> throw ConvNotFound [conv] -> pure conv - _convs -> throwM (federationUnexpectedBody "expected one conversation, got multiple") + -- _convs -> throw (federationUnexpectedBody "expected one conversation, got multiple") + _convs -> throw $ FederationUnexpectedBody "expected one conversation, got multiple" -getRemoteConversations :: UserId -> [Remote ConvId] -> Galley r [Public.Conversation] +getRemoteConversations :: + Members '[ConversationStore, Error ConversationError, Error FederationError] r => + UserId -> + [Remote ConvId] -> + Galley r [Public.Conversation] getRemoteConversations zusr remoteConvs = getRemoteConversationsWithFailures zusr remoteConvs >>= \case -- throw first error - (failed : _, _) -> throwM (fgcError failed) + (failed : _, _) -> liftSem . throwFgcError $ failed ([], result) -> pure result data FailedGetConversationReason = FailedGetConversationLocally | FailedGetConversationRemotely FederationError -fgcrError :: FailedGetConversationReason -> Wai.Error -fgcrError FailedGetConversationLocally = errorDescriptionTypeToWai @ConvNotFound -fgcrError (FailedGetConversationRemotely e) = federationErrorToWai e +throwFgcrError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversationReason -> Sem r a +throwFgcrError FailedGetConversationLocally = throw ConvNotFound +throwFgcrError (FailedGetConversationRemotely e) = throw e data FailedGetConversation = FailedGetConversation [Qualified ConvId] FailedGetConversationReason -fgcError :: FailedGetConversation -> Wai.Error -fgcError (FailedGetConversation _ r) = fgcrError r +throwFgcError :: + Members '[Error ConversationError, Error FederationError] r => FailedGetConversation -> Sem r a +throwFgcError (FailedGetConversation _ r) = throwFgcrError r failedGetConversationRemotely :: [Remote ConvId] -> FederationError -> FailedGetConversation @@ -157,6 +188,7 @@ partitionGetConversationFailures = bimap concat concat . partitionEithers . map split (FailedGetConversation convs (FailedGetConversationRemotely _)) = Right convs getRemoteConversationsWithFailures :: + Member ConversationStore r => UserId -> [Remote ConvId] -> Galley r ([FailedGetConversation], [Public.Conversation]) @@ -165,7 +197,7 @@ getRemoteConversationsWithFailures zusr convs = do lusr <- qualifyLocal zusr -- get self member statuses from the database - statusMap <- Data.remoteConversationStatus zusr convs + statusMap <- liftSem $ E.getRemoteConversationStatus zusr convs let remoteView :: Remote FederatedGalley.RemoteConversation -> Maybe Conversation remoteView rconv = Mapping.remoteConversationView @@ -205,21 +237,30 @@ getRemoteConversationsWithFailures zusr convs = do . Logger.field "error" (show e) throwE e -getConversationRoles :: UserId -> ConvId -> Galley r Public.ConversationRolesList +getConversationRoles :: + Members '[ConversationStore, Error ConversationError] r => + UserId -> + ConvId -> + Galley r Public.ConversationRolesList getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr cnv -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) pure $ Public.ConversationRolesList wireConvRoles -conversationIdsPageFromUnqualified :: UserId -> Maybe ConvId -> Maybe (Range 1 1000 Int32) -> Galley r (Public.ConversationList ConvId) -conversationIdsPageFromUnqualified zusr start msize = do +conversationIdsPageFromUnqualified :: + Member (ListItems LegacyPaging ConvId) r => + UserId -> + Maybe ConvId -> + Maybe (Range 1 1000 Int32) -> + Galley r (Public.ConversationList ConvId) +conversationIdsPageFromUnqualified zusr start msize = liftSem $ do let size = fromMaybe (toRange (Proxy @1000)) msize - ids <- Data.conversationIdsFrom zusr start size + ids <- E.listItems zusr start size pure $ Public.ConversationList - (Data.resultSetResult ids) - (Data.resultSetType ids == Data.ResultSetTruncated) + (resultSetResult ids) + (resultSetType ids == ResultSetTruncated) -- | Lists conversation ids for the logged in user in a paginated way. -- @@ -229,32 +270,52 @@ conversationIdsPageFromUnqualified zusr start msize = do -- -- - After local conversations, remote conversations are listed ordered -- - lexicographically by their domain and then by their id. -conversationIdsPageFrom :: UserId -> Public.GetPaginatedConversationIds -> Galley r Public.ConvIdsPage +conversationIdsPageFrom :: + forall p r. + ( p ~ CassandraPaging, + Members '[ListItems p ConvId, ListItems p (Remote ConvId)] r + ) => + UserId -> + Public.GetPaginatedConversationIds -> + Galley r Public.ConvIdsPage conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do localDomain <- viewFederationDomain - case gmtprState of - Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> remotesOnly (mkState <$> stateBS) (fromRange gmtprSize) + liftSem $ case gmtprState of + Just (Public.ConversationPagingState Public.PagingRemotes stateBS) -> + remotesOnly (mkState <$> stateBS) gmtprSize _ -> localsAndRemotes localDomain (fmap mkState . Public.mtpsState =<< gmtprState) gmtprSize where mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Domain -> Maybe C.PagingState -> Range 1 1000 Int32 -> Galley r Public.ConvIdsPage + localsAndRemotes :: + Domain -> + Maybe C.PagingState -> + Range 1 1000 Int32 -> + Sem r Public.ConvIdsPage localsAndRemotes localDomain pagingState size = do - localPage <- pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) <$> Data.localConversationIdsPageFrom zusr pagingState size + localPage <- + pageToConvIdPage Public.PagingLocals . fmap (`Qualified` localDomain) + <$> E.listItems zusr pagingState size let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) if Public.mtpHasMore localPage || remainingSize <= 0 then pure localPage {Public.mtpHasMore = True} -- We haven't checked the remotes yet, so has_more must always be True here. else do - remotePage <- remotesOnly Nothing remainingSize + -- remainingSize <= size and remainingSize >= 1, so it is safe to convert to Range + remotePage <- remotesOnly Nothing (unsafeRange remainingSize) pure $ remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Maybe C.PagingState -> Int32 -> Galley r Public.ConvIdsPage + remotesOnly :: + Maybe C.PagingState -> + Range 1 1000 Int32 -> + Sem r Public.ConvIdsPage remotesOnly pagingState size = - pageToConvIdPage Public.PagingRemotes <$> Data.remoteConversationIdsPageFrom zusr pagingState size + pageToConvIdPage Public.PagingRemotes + . fmap (qUntagged @'QRemote) + <$> E.listItems zusr pagingState size - pageToConvIdPage :: Public.LocalOrRemoteTable -> Data.PageWithState (Qualified ConvId) -> Public.ConvIdsPage - pageToConvIdPage table page@Data.PageWithState {..} = + pageToConvIdPage :: Public.LocalOrRemoteTable -> C.PageWithState (Qualified ConvId) -> Public.ConvIdsPage + pageToConvIdPage table page@C.PageWithState {..} = Public.MultiTablePage { mtpResults = pwsResults, mtpHasMore = C.pwsHasMore page, @@ -262,6 +323,7 @@ conversationIdsPageFrom zusr Public.GetMultiTablePageRequest {..} = do } getConversations :: + Members '[Error InternalError, ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> @@ -272,38 +334,48 @@ getConversations user mids mstart msize = do flip ConversationList more <$> mapM (Mapping.conversationView user) cs getConversationsInternal :: + Members '[ConversationStore, ListItems LegacyPaging ConvId] r => UserId -> Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> Maybe ConvId -> Maybe (Range 1 500 Int32) -> Galley r (Public.ConversationList Data.Conversation) getConversationsInternal user mids mstart msize = do - (more, ids) <- getIds mids + (more, ids) <- liftSem $ getIds mids let localConvIds = ids cs <- - Data.localConversations localConvIds - >>= filterM removeDeleted + liftSem (E.getConversations localConvIds) + >>= filterM (liftSem . removeDeleted) >>= filterM (pure . isMember user . Data.convLocalMembers) pure $ Public.ConversationList cs more where size = fromMaybe (toRange (Proxy @32)) msize -- get ids and has_more flag + getIds :: + Members '[ConversationStore, ListItems LegacyPaging ConvId] r => + Maybe (Range 1 32 (CommaSeparatedList ConvId)) -> + Sem r (Bool, [ConvId]) getIds (Just ids) = (False,) - <$> Data.localConversationIdsOf + <$> E.selectConversations user (fromCommaSeparatedList (fromRange ids)) getIds Nothing = do - r <- Data.conversationIdsFrom user mstart (rcast size) - let hasMore = Data.resultSetType r == Data.ResultSetTruncated - pure (hasMore, Data.resultSetResult r) - + r <- E.listItems user mstart (rcast size) + let hasMore = resultSetType r == ResultSetTruncated + pure (hasMore, resultSetResult r) + + removeDeleted :: + Member ConversationStore r => + Data.Conversation -> + Sem r Bool removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True listConversations :: + Members '[ConversationStore, Error InternalError] r => UserId -> Public.ListConversations -> Galley r Public.ConversationsResponse @@ -311,10 +383,12 @@ listConversations user (Public.ListConversations ids) = do luser <- qualifyLocal user let (localIds, remoteIds) = partitionQualified luser (fromRange ids) - (foundLocalIds, notFoundLocalIds) <- foundsAndNotFounds (Data.localConversationIdsOf user) localIds + (foundLocalIds, notFoundLocalIds) <- + liftSem $ + foundsAndNotFounds (E.selectConversations user) localIds localInternalConversations <- - Data.localConversations foundLocalIds + liftSem (E.getConversations foundLocalIds) >>= filterM removeDeleted >>= filterM (pure . isMember user . Data.convLocalMembers) localConversations <- mapM (Mapping.conversationView user) localInternalConversations @@ -343,9 +417,12 @@ listConversations user (Public.ListConversations ids) = do crFailed = failedConvsRemotely } where - removeDeleted :: Data.Conversation -> Galley r Bool + removeDeleted :: + Member ConversationStore r => + Data.Conversation -> + Galley r Bool removeDeleted c - | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False + | Data.isConvDeleted c = liftSem $ E.deleteConversation (Data.convId c) >> pure False | otherwise = pure True foundsAndNotFounds :: (Monad m, Eq a) => ([a] -> m [a]) -> [a] -> m ([a], [a]) foundsAndNotFounds f xs = do @@ -354,6 +431,7 @@ listConversations user (Public.ListConversations ids) = do pure (founds, notFounds) iterateConversations :: + Members '[ListItems LegacyPaging ConvId, ConversationStore] r => UserId -> Range 1 500 Int32 -> ([Data.Conversation] -> Galley r a) -> @@ -371,36 +449,60 @@ iterateConversations uid pageSize handleConvs = go Nothing _ -> pure [] pure $ resultHead : resultTail -internalGetMemberH :: ConvId ::: UserId -> Galley r Response +internalGetMemberH :: + Members '[ConversationStore, MemberStore] r => + ConvId ::: UserId -> + Galley r Response internalGetMemberH (cnv ::: usr) = do json <$> getLocalSelf usr cnv -getLocalSelf :: UserId -> ConvId -> Galley r (Maybe Public.Member) +getLocalSelf :: + Members '[ConversationStore, MemberStore] r => + UserId -> + ConvId -> + Galley r (Maybe Public.Member) getLocalSelf usr cnv = do lusr <- qualifyLocal usr - alive <- Data.isConvAlive cnv - if alive - then Mapping.localMemberToSelf lusr <$$> Data.member cnv usr - else Nothing <$ Data.deleteConversation cnv - -getConversationMetaH :: ConvId -> Galley r Response + liftSem $ do + alive <- E.isConversationAlive cnv + if alive + then Mapping.localMemberToSelf lusr <$$> E.getLocalMember cnv usr + else Nothing <$ E.deleteConversation cnv + +getConversationMetaH :: + Member ConversationStore r => + ConvId -> + Galley r Response getConversationMetaH cnv = do getConversationMeta cnv <&> \case Nothing -> setStatus status404 empty Just meta -> json meta -getConversationMeta :: ConvId -> Galley r (Maybe ConversationMetadata) -getConversationMeta cnv = do - alive <- Data.isConvAlive cnv - localDomain <- viewFederationDomain +getConversationMeta :: + Member ConversationStore r => + ConvId -> + Galley r (Maybe ConversationMetadata) +getConversationMeta cnv = liftSem $ do + alive <- E.isConversationAlive cnv if alive - then Data.conversationMeta localDomain cnv + then E.getConversationMetadata cnv else do - Data.deleteConversation cnv + E.deleteConversation cnv pure Nothing getConversationByReusableCode :: - Member BrigAccess r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> Key -> Value -> diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index b2d8f0681da..f73b5e2ebe2 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -60,8 +60,8 @@ where import Brig.Types.Intra (accountUser) import Brig.Types.Team (TeamSize (..)) import Control.Lens -import Control.Monad.Catch -import Data.ByteString.Conversion hiding (fromList) +import Data.ByteString.Conversion (List, toByteString) +import qualified Data.ByteString.Conversion import Data.ByteString.Lazy.Builder (lazyByteString) import qualified Data.CaseInsensitive as CI import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith) @@ -70,11 +70,11 @@ import Data.Id import qualified Data.LegalHold as LH import qualified Data.List.Extra as List import Data.List1 (list1) +import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Qualified import Data.Range as Range -import Data.Set (fromList) import qualified Data.Set as Set import Data.Time.Clock (UTCTime (..), getCurrentTime) import qualified Data.UUID as UUID @@ -85,18 +85,25 @@ import qualified Galley.API.Teams.Notifications as APITeamQueue import qualified Galley.API.Update as API import Galley.API.Util import Galley.App -import qualified Galley.Data as Data -import qualified Galley.Data.LegalHold as Data -import qualified Galley.Data.SearchVisibility as SearchVisibilityData +import Galley.Cassandra.Paging +import qualified Galley.Data.Conversation as Data import Galley.Data.Services (BotMember) -import qualified Galley.Data.TeamFeatures as TeamFeatures import Galley.Effects -import qualified Galley.External as External +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ExternalAccess as E +import qualified Galley.Effects.GundeckAccess as E +import qualified Galley.Effects.LegalHoldStore as Data +import qualified Galley.Effects.ListItems as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.Paging as E +import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData +import qualified Galley.Effects.SparAccess as Spar +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import qualified Galley.Effects.TeamMemberStore as E +import qualified Galley.Effects.TeamStore as E import qualified Galley.Intra.Journal as Journal import Galley.Intra.Push -import qualified Galley.Intra.Spar as Spar -import qualified Galley.Intra.Team as BrigTeam -import Galley.Intra.User import Galley.Options import qualified Galley.Options as Opts import qualified Galley.Queue as Q @@ -106,16 +113,19 @@ import Galley.Types.Conversations.Roles as Roles import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SearchVisibility +import Galley.Types.UserList import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, or, result, setStatus) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import qualified System.Logger.Class as Log -import UnliftIO.Async (mapConcurrently) import qualified Wire.API.Conversation.Role as Public -import Wire.API.ErrorDescription (ConvNotFound, NotATeamMember, operationDenied) +import Wire.API.ErrorDescription +import Wire.API.Federation.Client import qualified Wire.API.Notification as Public import qualified Wire.API.Team as Public import qualified Wire.API.Team.Conversation as Public @@ -129,40 +139,56 @@ import qualified Wire.API.User as U import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) -getTeamH :: UserId ::: TeamId ::: JSON -> Galley r Response +getTeamH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId ::: TeamId ::: JSON -> + Galley r Response getTeamH (zusr ::: tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid + maybe (liftSem (throw TeamNotFound)) (pure . json) =<< lookupTeam zusr tid -getTeamInternalH :: TeamId ::: JSON -> Galley r Response +getTeamInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid + liftSem . fmap json $ + E.getTeam tid >>= note TeamNotFound -getTeamInternal :: TeamId -> Galley r (Maybe TeamData) -getTeamInternal = Data.team - -getTeamNameInternalH :: TeamId ::: JSON -> Galley r Response +getTeamNameInternalH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: JSON -> + Galley r Response getTeamNameInternalH (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid + liftSem . fmap json $ + getTeamNameInternal tid >>= note TeamNotFound -getTeamNameInternal :: TeamId -> Galley r (Maybe TeamName) -getTeamNameInternal = fmap (fmap TeamName) . Data.teamName +getTeamNameInternal :: Member TeamStore r => TeamId -> Sem r (Maybe TeamName) +getTeamNameInternal = fmap (fmap TeamName) . E.getTeamName -getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley r Response +getManyTeamsH :: + (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> + Galley r Response getManyTeamsH (zusr ::: range ::: size ::: _) = json <$> getManyTeams zusr range size -getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley r Public.TeamList +getManyTeams :: + (Members '[TeamStore, ListItems LegacyPaging TeamId] r) => + UserId -> + Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> + Range 1 100 Int32 -> + Galley r Public.TeamList getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids pure (Public.newTeamList (catMaybes teams) more) -lookupTeam :: UserId -> TeamId -> Galley r (Maybe Public.Team) +lookupTeam :: Member TeamStore r => UserId -> TeamId -> Galley r (Maybe Public.Team) lookupTeam zusr tid = do - tm <- Data.teamMember tid zusr + tm <- liftSem $ E.getTeamMember tid zusr if isJust tm then do - t <- Data.team tid + t <- liftSem $ E.getTeam tid when (Just PendingDelete == (tdStatus <$> t)) $ do q <- view deleteQueue void $ Q.tryPush q (TeamItem tid zusr Nothing) @@ -170,7 +196,16 @@ lookupTeam zusr tid = do else pure Nothing createNonBindingTeamH :: - Members '[GundeckAccess, BrigAccess] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.NonBindingNewTeam ::: JSON -> Galley r Response createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do @@ -179,7 +214,15 @@ createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createNonBindingTeam :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.NonBindingNewTeam -> @@ -196,12 +239,20 @@ createNonBindingTeam zusr zcon (Public.NonBindingNewTeam body) = do Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.createNonBindingTeam") - team <- Data.createTeam Nothing zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) NonBinding + team <- + liftSem $ + E.createTeam + Nothing + zusr + (body ^. newTeamName) + (body ^. newTeamIcon) + (body ^. newTeamIconKey) + NonBinding finishCreateTeam team owner others (Just zcon) pure (team ^. teamId) createBindingTeamH :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, Error InvalidInput, GundeckAccess, TeamStore] r => UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley r Response createBindingTeamH (zusr ::: tid ::: req ::: _) = do @@ -210,55 +261,80 @@ createBindingTeamH (zusr ::: tid ::: req ::: _) = do pure (empty & setStatus status201 . location newTeamId) createBindingTeam :: - Members '[BrigAccess, GundeckAccess] r => + Members '[BrigAccess, GundeckAccess, TeamStore] r => UserId -> TeamId -> BindingNewTeam -> Galley r TeamId createBindingTeam zusr tid (BindingNewTeam body) = do let owner = Public.TeamMember zusr fullPermissions Nothing LH.defUserLegalHoldStatus - team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding + team <- + liftSem $ + E.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing pure tid -updateTeamStatusH :: Member BrigAccess r => TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley r Response +updateTeamStatusH :: + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> + Galley r Response updateTeamStatusH (tid ::: req ::: _) = do teamStatusUpdate <- fromJsonBody req updateTeamStatus tid teamStatusUpdate return empty -updateTeamStatus :: Member BrigAccess r => TeamId -> TeamStatusUpdate -> Galley r () +updateTeamStatus :: + Members '[BrigAccess, Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + TeamStatusUpdate -> + Galley r () updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do - oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) + oldStatus <- tdStatus <$> liftSem (E.getTeam tid >>= note TeamNotFound) valid <- validateTransition (oldStatus, newStatus) when valid $ do journal newStatus cur - Data.updateTeamStatus tid newStatus + liftSem $ E.setTeamStatus tid newStatus where journal Suspended _ = Journal.teamSuspend tid journal Active c = do - teamCreationTime <- Data.teamCreationTime tid + teamCreationTime <- liftSem $ E.getTeamCreationTime tid -- When teams are created, they are activated immediately. In this situation, Brig will -- most likely report team size as 0 due to ES taking some time to index the team creator. -- This is also very difficult to test, so is not tested. - (TeamSize possiblyStaleSize) <- BrigTeam.getSize tid + (TeamSize possiblyStaleSize) <- liftSem $ E.getSize tid let size = if possiblyStaleSize == 0 then 1 else possiblyStaleSize Journal.teamActivate tid size c teamCreationTime - journal _ _ = throwM invalidTeamStatusUpdate - validateTransition :: (TeamStatus, TeamStatus) -> Galley r Bool + journal _ _ = liftSem $ throw InvalidTeamStatusUpdate + validateTransition :: Member (Error ActionError) r => (TeamStatus, TeamStatus) -> Galley r Bool validateTransition = \case (PendingActive, Active) -> return True (Active, Active) -> return False (Active, Suspended) -> return True (Suspended, Active) -> return True (Suspended, Suspended) -> return False - (_, _) -> throwM invalidTeamStatusUpdate + (_, _) -> liftSem $ throw InvalidTeamStatusUpdate updateTeamH :: - Member GundeckAccess r => + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.TeamUpdateData ::: JSON -> Galley r Response updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -267,28 +343,45 @@ updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty updateTeam :: - Member GundeckAccess r => + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> Public.TeamUpdateData -> Galley r () updateTeam zusr zcon tid updateData = do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ E.getTeamMember tid zusr -- let zothers = map (view userId) membs -- Log.debug $ -- Log.field "targets" (toByteString . show $ toByteString <$> zothers) -- . Log.field "action" (Log.val "Teams.updateTeam") void $ permissionCheck SetTeamData zusrMembership - Data.updateTeam tid updateData + liftSem $ E.setTeamData tid updateData now <- liftIO getCurrentTime - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + liftSem . E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon deleteTeamH :: - Member BrigAccess r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> Galley r Response deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -298,17 +391,26 @@ deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do -- | 'TeamDeleteData' is only required for binding teams deleteTeam :: - Member BrigAccess r => + Members + '[ BrigAccess, + Error ActionError, + Error AuthenticationError, + Error InternalError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> Maybe Public.TeamDeleteData -> Galley r () deleteTeam zusr zcon tid mBody = do - team <- Data.team tid >>= ifNothing teamNotFound + team <- liftSem $ E.getTeam tid >>= note TeamNotFound case tdStatus team of - Deleted -> - throwM teamNotFound + Deleted -> liftSem $ throw TeamNotFound PendingDelete -> queueTeamDeletion tid zusr (Just zcon) _ -> do @@ -316,54 +418,68 @@ deleteTeam zusr zcon tid mBody = do queueTeamDeletion tid zusr (Just zcon) where checkPermissions team = do - void $ permissionCheck DeleteTeam =<< Data.teamMember tid zusr + void $ permissionCheck DeleteTeam =<< liftSem (E.getTeamMember tid zusr) when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern -internalDeleteBindingTeamWithOneMember :: TeamId -> Galley r () +internalDeleteBindingTeamWithOneMember :: + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + Galley r () internalDeleteBindingTeamWithOneMember tid = do - team <- Data.team tid - unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ - throwM noBindingTeam - mems <- Data.teamMembersWithLimit tid (unsafeRange 2) + team <- liftSem (E.getTeam tid) + liftSem . unless ((view teamBinding . tdTeam <$> team) == Just Binding) $ + throw NoBindingTeam + mems <- liftSem $ E.getTeamMembersWithLimit tid (unsafeRange 2) case mems ^. teamMembers of (mem : []) -> queueTeamDeletion tid (mem ^. userId) Nothing - _ -> throwM notAOneMemberTeam + _ -> liftSem $ throw NotAOneMemberTeam -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. uncheckedDeleteTeam :: forall r. - Members '[BrigAccess, ExternalAccess, GundeckAccess, SparAccess] r => + Members + '[ BrigAccess, + ExternalAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + SparAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> TeamId -> Galley r () uncheckedDeleteTeam zusr zcon tid = do - team <- Data.team tid + team <- liftSem $ E.getTeam tid when (isJust team) $ do - Spar.deleteTeam tid + liftSem $ Spar.deleteTeam tid now <- liftIO getCurrentTime - convs <- filter (not . view managedConversation) <$> Data.teamConversations tid + convs <- + liftSem $ + filter (not . view managedConversation) <$> E.getTeamConversations tid -- Even for LARGE TEAMS, we _DO_ want to fetch all team members here because we -- want to generate conversation deletion events for non-team users. This should -- be fine as it is done once during the life team of a team and we still do not -- fanout this particular event to all team members anyway. And this is anyway -- done asynchronously - membs <- Data.teamMembersCollectedWithPagination tid + membs <- liftSem $ E.getTeamMembers tid (ue, be) <- foldrM (createConvDeleteEvents now membs) ([], []) convs let e = newEvent TeamDelete tid now pushDeleteEvents membs e ue - External.deliverAsync be + liftSem $ E.deliverAsync be -- TODO: we don't delete bots here, but we should do that, since -- every bot user can only be in a single conversation. Just -- deleting conversations from the database is not enough. when ((view teamBinding . tdTeam <$> team) == Just Binding) $ do - mapM_ (deleteUser . view userId) membs + liftSem $ mapM_ (E.deleteUser . view userId) membs Journal.teamDelete tid - Data.unsetTeamLegalholdWhitelisted tid - Data.deleteTeam tid + liftSem $ Data.unsetTeamLegalholdWhitelisted tid + liftSem $ E.deleteTeam tid where pushDeleteEvents :: [TeamMember] -> Event -> [Push] -> Galley r () pushDeleteEvents membs e ue = do @@ -372,16 +488,18 @@ uncheckedDeleteTeam zusr zcon tid = do -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - forM_ chunks $ \chunk -> case chunk of - [] -> return () - -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the - -- push module to never fan this out to more than the limit - x : xs -> push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) + liftSem $ + forM_ chunks $ \chunk -> case chunk of + [] -> return () + -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the + -- push module to never fan this out to more than the limit + x : xs -> E.push1 (newPushLocal1 ListComplete zusr (TeamEvent e) (list1 x xs) & pushConn .~ zcon) -- To avoid DoS on gundeck, send conversation deletion events slowly + -- FUTUREWORK: make this behaviour part of the GundeckAccess effect let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis (o ^. setDeleteConvThrottleMillis)) forM_ ue $ \event -> do -- push ConversationDelete events - push1 event + liftSem $ E.push1 event threadDelay delay createConvDeleteEvents :: UTCTime -> @@ -393,7 +511,7 @@ uncheckedDeleteTeam zusr zcon tid = do localDomain <- viewFederationDomain let qconvId = Qualified (c ^. conversationId) localDomain qorig = Qualified zusr localDomain - (bots, convMembs) <- localBotsAndUsers <$> Data.members (c ^. conversationId) + (bots, convMembs) <- liftSem $ localBotsAndUsers <$> E.getLocalMembers (c ^. conversationId) -- Only nonTeamMembers need to get any events, since on team deletion, -- all team users are deleted immediately after these events are sent -- and will thus never be able to see these events in practice. @@ -405,44 +523,54 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId -> TeamId -> Galley r Public.ConversationRolesList +getTeamConversationRoles :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + TeamId -> + Galley r Public.ConversationRolesList getTeamConversationRoles zusr tid = do - mem <- Data.teamMember tid zusr - case mem of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> do - -- NOTE: If/when custom roles are added, these roles should - -- be merged with the team roles (if they exist) - pure $ Public.ConversationRolesList wireConvRoles - -getTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> Galley r Response + liftSem . void $ E.getTeamMember tid zusr >>= noteED @NotATeamMember + -- NOTE: If/when custom roles are added, these roles should + -- be merged with the team roles (if they exist) + pure $ Public.ConversationRolesList wireConvRoles + +getTeamMembersH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JSON -> + Galley r Response getTeamMembersH (zusr ::: tid ::: maxResults ::: _) = do (memberList, withPerms) <- getTeamMembers zusr tid maxResults pure . json $ teamMemberListJson withPerms memberList -getTeamMembers :: UserId -> TeamId -> Range 1 Public.HardTruncationLimit Int32 -> Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) -getTeamMembers zusr tid maxResults = do - Data.teamMember tid zusr >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - mems <- Data.teamMembersWithLimit tid maxResults - let withPerms = (m `canSeePermsOf`) - pure (mems, withPerms) +getTeamMembers :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + TeamId -> + Range 1 Public.HardTruncationLimit Int32 -> + Galley r (Public.TeamMemberList, Public.TeamMember -> Bool) +getTeamMembers zusr tid maxResults = liftSem $ do + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.getTeamMembersWithLimit tid maxResults + let withPerms = (m `canSeePermsOf`) + pure (mems, withPerms) getTeamMembersCSVH :: - Member BrigAccess r => + (Members '[BrigAccess, Error ActionError, TeamStore] r) => UserId ::: TeamId ::: JSON -> Galley r Response getTeamMembersCSVH (zusr ::: tid ::: _) = do - Data.teamMember tid zusr >>= \case - Nothing -> throwM accessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwM accessDenied + liftSem $ + E.getTeamMember tid zusr >>= \case + Nothing -> throw AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throw AccessDenied env <- ask -- In case an exception is thrown inside the StreamingBody of responseStream -- the response will not contain a correct error message, but rather be an -- http error such as 'InvalidChunkHeaders'. The exception however still -- reaches the middleware and is being tracked in logging and metrics. + -- + -- FUTUREWORK: rewrite this using some streaming primitive (e.g. polysemy's Input) pure $ responseStream status200 @@ -454,21 +582,29 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do writeString headerLine flush evalGalley env $ do - Data.withTeamMembersWithChunks tid $ \members -> do - inviters <- lookupInviterHandle members - users <- lookupUser <$> lookupActivatedUsers (fmap (view userId) members) - richInfos <- lookupRichInfo <$> getRichInfoMultiUser (fmap (view userId) members) - liftIO $ do - writeString - ( encodeDefaultOrderedByNameWith - defaultEncodeOptions - (mapMaybe (teamExportUser users inviters richInfos) members) - ) - flush + E.withChunks pager $ + \members -> do + inviters <- lookupInviterHandle members + users <- + liftSem $ + lookupUser <$> E.lookupActivatedUsers (fmap (view userId) members) + richInfos <- + liftSem $ + lookupRichInfo <$> E.getRichInfoMultiUser (fmap (view userId) members) + liftIO $ do + writeString + ( encodeDefaultOrderedByNameWith + defaultEncodeOptions + (mapMaybe (teamExportUser users inviters richInfos) members) + ) + flush where headerLine :: LByteString headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) + pager :: Maybe (InternalPagingState TeamMember) -> Galley GalleyEffects (InternalPage TeamMember) + pager mps = liftSem $ E.listTeamMembers tid mps maxBound + defaultEncodeOptions :: EncodeOptions defaultEncodeOptions = EncodeOptions @@ -508,7 +644,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do let inviterIds :: [UserId] inviterIds = nub $ catMaybes $ fmap fst . view invitation <$> members - userList :: [User] <- accountUser <$$> getUsers inviterIds + userList :: [User] <- liftSem $ accountUser <$$> E.getUsers inviterIds let userMap :: M.Map UserId Handle.Handle userMap = M.fromList . catMaybes $ extract <$> userList @@ -535,66 +671,115 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId (UserScimExternalId _) -> Nothing -bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley r Response +bulkGetTeamMembersH :: + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> + Galley r Response bulkGetTeamMembersH (zusr ::: tid ::: maxResults ::: body ::: _) = do UserIdList uids <- fromJsonBody body (memberList, withPerms) <- bulkGetTeamMembers zusr tid maxResults uids pure . json $ teamMemberListJson withPerms memberList -- | like 'getTeamMembers', but with an explicit list of users we are to return. -bulkGetTeamMembers :: UserId -> TeamId -> Range 1 HardTruncationLimit Int32 -> [UserId] -> Galley r (TeamMemberList, TeamMember -> Bool) -bulkGetTeamMembers zusr tid maxResults uids = do +bulkGetTeamMembers :: + Members '[Error ActionError, Error InvalidInput, Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + TeamId -> + Range 1 HardTruncationLimit Int32 -> + [UserId] -> + Galley r (TeamMemberList, TeamMember -> Bool) +bulkGetTeamMembers zusr tid maxResults uids = liftSem $ do unless (length uids <= fromIntegral (fromRange maxResults)) $ - throwM bulkGetMemberLimitExceeded - Data.teamMember tid zusr >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - mems <- Data.teamMembersLimited tid uids - let withPerms = (m `canSeePermsOf`) - hasMore = ListComplete - pure (newTeamMemberList mems hasMore, withPerms) - -getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley r Response + throw BulkGetMemberLimitExceeded + m <- E.getTeamMember tid zusr >>= noteED @NotATeamMember + mems <- E.selectTeamMembers tid uids + let withPerms = (m `canSeePermsOf`) + hasMore = ListComplete + pure (newTeamMemberList mems hasMore, withPerms) + +getTeamMemberH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId ::: TeamId ::: UserId ::: JSON -> + Galley r Response getTeamMemberH (zusr ::: tid ::: uid ::: _) = do (member, withPerms) <- getTeamMember zusr tid uid pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId -> TeamId -> UserId -> Galley r (Public.TeamMember, Public.TeamMember -> Bool) +getTeamMember :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + TeamId -> + UserId -> + Galley r (Public.TeamMember, Public.TeamMember -> Bool) getTeamMember zusr tid uid = do - zusrMembership <- Data.teamMember tid zusr - case zusrMembership of - Nothing -> throwErrorDescriptionType @NotATeamMember - Just m -> do - let withPerms = (m `canSeePermsOf`) - Data.teamMember tid uid >>= \case - Nothing -> throwM teamMemberNotFound - Just member -> pure (member, withPerms) - -internalDeleteBindingTeamWithOneMemberH :: TeamId -> Galley r Response + m <- + liftSem $ + E.getTeamMember tid zusr + >>= noteED @NotATeamMember + let withPerms = (m `canSeePermsOf`) + member <- liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound + pure (member, withPerms) + +internalDeleteBindingTeamWithOneMemberH :: + Members '[Error InternalError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + Galley r Response internalDeleteBindingTeamWithOneMemberH tid = do internalDeleteBindingTeamWithOneMember tid pure (empty & setStatus status202) -uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley r Response +uncheckedGetTeamMemberH :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: UserId ::: JSON -> + Galley r Response uncheckedGetTeamMemberH (tid ::: uid ::: _) = do json <$> uncheckedGetTeamMember tid uid -uncheckedGetTeamMember :: TeamId -> UserId -> Galley r TeamMember -uncheckedGetTeamMember tid uid = do - Data.teamMember tid uid >>= ifNothing teamMemberNotFound +uncheckedGetTeamMember :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + UserId -> + Galley r TeamMember +uncheckedGetTeamMember tid uid = + liftSem $ E.getTeamMember tid uid >>= note TeamMemberNotFound -uncheckedGetTeamMembersH :: TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> Galley r Response +uncheckedGetTeamMembersH :: + Member TeamStore r => + TeamId ::: Range 1 HardTruncationLimit Int32 ::: JSON -> + Galley r Response uncheckedGetTeamMembersH (tid ::: maxResults ::: _) = do json <$> uncheckedGetTeamMembers tid maxResults uncheckedGetTeamMembers :: + Member TeamStore r => TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList -uncheckedGetTeamMembers tid maxResults = Data.teamMembersWithLimit tid maxResults +uncheckedGetTeamMembers tid maxResults = liftSem $ E.getTeamMembersWithLimit tid maxResults addTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + MemberStore, + TeamFeatureStore, + TeamNotificationStore, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -603,7 +788,20 @@ addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do pure empty addTeamMember :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + GundeckAccess, + Error ActionError, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + MemberStore, + TeamFeatureStore, + TeamNotificationStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -616,21 +814,34 @@ addTeamMember zusr zcon tid nmem = do . Log.field "action" (Log.val "Teams.addTeamMember") -- verify permissions zusrMembership <- - Data.teamMember tid zusr + liftSem (E.getTeamMember tid zusr) >>= permissionCheck AddTeamMember let targetPermissions = nmem ^. ntmNewTeamMember . permissions targetPermissions `ensureNotElevated` zusrMembership ensureNonBindingTeam tid ensureUnboundUsers [uid] ensureConnectedToLocals zusr [uid] - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid void $ addTeamMemberInternal tid (Just zusr) (Just zcon) nmem memList -- This function is "unchecked" because there is no need to check for user binding (invite only). uncheckedAddTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + Error LegalHoldError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamFeatureStore, + TeamStore, + TeamNotificationStore + ] + r => TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley r Response uncheckedAddTeamMemberH (tid ::: req ::: _) = do @@ -639,20 +850,41 @@ uncheckedAddTeamMemberH (tid ::: req ::: _) = do return empty uncheckedAddTeamMember :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + GundeckAccess, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, + MemberStore, + LegalHoldStore, + TeamFeatureStore, + TeamStore, + TeamNotificationStore + ] + r => TeamId -> NewTeamMember -> Galley r () uncheckedAddTeamMember tid nmem = do - mems <- Data.teamMembersForFanout tid - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + mems <- getTeamMembersForFanout tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) (TeamSize sizeBeforeAdd) <- addTeamMemberInternal tid Nothing Nothing nmem mems billingUserIds <- Journal.getBillingUserIds tid $ Just $ newTeamMemberList ((nmem ^. ntmNewTeamMember) : mems ^. teamMembers) (mems ^. teamMemberListType) Journal.teamUpdate tid (sizeBeforeAdd + 1) billingUserIds updateTeamMemberH :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.NewTeamMember ::: JSON -> Galley r Response updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do @@ -663,7 +895,15 @@ updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do updateTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + Error ActionError, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -677,29 +917,26 @@ updateTeamMember zusr zcon tid targetMember = do . Log.field "action" (Log.val "Teams.updateTeamMember") -- get the team and verify permissions - team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) + team <- liftSem . fmap tdTeam $ E.getTeam tid >>= note TeamNotFound user <- - Data.teamMember tid zusr + liftSem (E.getTeamMember tid zusr) >>= permissionCheck SetMemberPermissions -- user may not elevate permissions targetPermissions `ensureNotElevated` user previousMember <- - Data.teamMember tid targetId >>= \case - Nothing -> - -- target user must be in same team - throwM teamMemberNotFound - Just previousMember -> pure previousMember - when - ( downgradesOwner previousMember targetPermissions - && not (canDowngradeOwner user previousMember) - ) - $ throwM accessDenied + liftSem $ E.getTeamMember tid targetId >>= note TeamMemberNotFound + liftSem + . when + ( downgradesOwner previousMember targetPermissions + && not (canDowngradeOwner user previousMember) + ) + $ throw AccessDenied -- update target in Cassandra - Data.updateTeamMember (previousMember ^. permissions) tid targetId targetPermissions + liftSem $ E.setTeamMemberPermissions (previousMember ^. permissions) tid targetId targetPermissions - updatedMembers <- Data.teamMembersForFanout tid + updatedMembers <- getTeamMembersForFanout tid updateJournal team updatedMembers updatePeers targetId targetPermissions updatedMembers where @@ -713,7 +950,7 @@ updateTeamMember zusr zcon tid targetMember = do updateJournal :: Team -> TeamMemberList -> Galley r () updateJournal team mems = do when (team ^. teamBinding == Binding) $ do - (TeamSize size) <- BrigTeam.getSize tid + (TeamSize size) <- liftSem $ E.getSize tid billingUserIds <- Journal.getBillingUserIds tid $ Just mems Journal.teamUpdate tid size billingUserIds @@ -729,10 +966,23 @@ updateTeamMember zusr zcon tid targetMember = do let ePriv = newEvent MemberUpdate tid now & eventData ?~ privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon + liftSem $ for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon deleteTeamMemberH :: - Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest Public.TeamMemberDeleteData ::: JSON -> Galley r Response deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do @@ -747,7 +997,20 @@ data TeamMemberDeleteResult -- | 'TeamMemberDeleteData' is only required for binding teams deleteTeamMember :: - Members '[BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error AuthenticationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -758,20 +1021,20 @@ deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) . Log.field "action" (Log.val "Teams.deleteTeamMember") - zusrMember <- Data.teamMember tid zusr - targetMember <- Data.teamMember tid remove + zusrMember <- liftSem $ E.getTeamMember tid zusr + targetMember <- liftSem $ E.getTeamMember tid remove void $ permissionCheck RemoveTeamMember zusrMember - do - dm <- maybe (throwM teamMemberNotFound) pure zusrMember - tm <- maybe (throwM teamMemberNotFound) pure targetMember - unless (canDeleteMember dm tm) $ throwM accessDenied - team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) - mems <- Data.teamMembersForFanout tid + liftSem $ do + dm <- note TeamMemberNotFound zusrMember + tm <- note TeamMemberNotFound targetMember + unless (canDeleteMember dm tm) $ throw AccessDenied + team <- tdTeam <$> liftSem (E.getTeam tid >>= note TeamNotFound) + mems <- getTeamMembersForFanout tid if team ^. teamBinding == Binding && isJust targetMember then do - body <- mBody & ifNothing (invalidPayload "missing request body") + body <- liftSem $ mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tmdAuthPassword) - (TeamSize sizeBeforeDelete) <- BrigTeam.getSize tid + (TeamSize sizeBeforeDelete) <- liftSem $ E.getSize tid -- TeamSize is 'Natural' and subtracting from 0 is an error -- TeamSize could be reported as 0 if team members are added and removed very quickly, -- which happens in tests @@ -779,7 +1042,7 @@ deleteTeamMember zusr zcon tid remove mBody = do if sizeBeforeDelete == 0 then 0 else sizeBeforeDelete - 1 - deleteUser remove + liftSem $ E.deleteUser remove billingUsers <- Journal.getBillingUserIds tid (Just mems) Journal.teamUpdate tid sizeAfterDelete $ filter (/= remove) billingUsers pure TeamMemberDeleteAccepted @@ -790,7 +1053,15 @@ deleteTeamMember zusr zcon tid remove mBody = do -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. uncheckedDeleteTeamMember :: forall r. - Members '[BrigAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BrigAccess, + ConversationStore, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> Maybe ConnId -> TeamId -> @@ -800,7 +1071,7 @@ uncheckedDeleteTeamMember :: uncheckedDeleteTeamMember zusr zcon tid remove mems = do now <- liftIO getCurrentTime pushMemberLeaveEvent now - Data.removeTeamMember tid remove + liftSem $ E.deleteTeamMember tid remove removeFromConvsAndPushConvLeaveEvent now where -- notify all team members. @@ -808,7 +1079,8 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do pushMemberLeaveEvent now = do let e = newEvent MemberLeave tid now & eventData ?~ EdMemberLeave remove let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (mems ^. teamMembers)) - push1 $ newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon + liftSem . E.push1 $ + newPushLocal1 (mems ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ zcon -- notify all conversation members not in this team. removeFromConvsAndPushConvLeaveEvent :: UTCTime -> Galley r () removeFromConvsAndPushConvLeaveEvent now = do @@ -818,11 +1090,11 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do localDomain <- viewFederationDomain let tmids = Set.fromList $ map (view userId) (mems ^. teamMembers) let edata = Conv.EdMembersLeave (Conv.QualifiedUserIdList [Qualified remove localDomain]) - cc <- Data.teamConversations tid + cc <- liftSem $ E.getTeamConversations tid for_ cc $ \c -> - Data.conversation (c ^. conversationId) >>= \conv -> + liftSem (E.getConversation (c ^. conversationId)) >>= \conv -> for_ conv $ \dc -> when (remove `isMember` Data.convLocalMembers dc) $ do - Data.removeMember remove (c ^. conversationId) + liftSem $ E.deleteMembers (c ^. conversationId) (UserList [remove] []) -- If the list was truncated, then the tmids list is incomplete so we simply drop these events unless (c ^. managedConversation || mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc @@ -835,25 +1107,65 @@ uncheckedDeleteTeamMember zusr zcon tid remove mems = do let x = filter (\m -> not (Conv.lmId m `Set.member` exceptTo)) users let y = Conv.Event Conv.MemberLeave qconvId qusr now edata for_ (newPushLocal (mems ^. teamMemberListType) zusr (ConvEvent y) (recipient <$> x)) $ \p -> - push1 $ p & pushConn .~ zcon - External.deliverAsync (bots `zip` repeat y) + liftSem . E.push1 $ p & pushConn .~ zcon + liftSem $ E.deliverAsync (bots `zip` repeat y) -getTeamConversations :: UserId -> TeamId -> Galley r Public.TeamConversationList -getTeamConversations zusr tid = do - tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) +getTeamConversations :: + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + TeamId -> + Galley r Public.TeamConversationList +getTeamConversations zusr tid = liftSem $ do + tm <- + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - Public.newTeamConversationList <$> Data.teamConversations tid - -getTeamConversation :: UserId -> TeamId -> ConvId -> Galley r Public.TeamConversation -getTeamConversation zusr tid cid = do - tm <- Data.teamMember tid zusr >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) + throw . OperationDenied . show $ GetTeamConversations + Public.newTeamConversationList <$> E.getTeamConversations tid + +getTeamConversation :: + Members + '[ Error ActionError, + Error ConversationError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + TeamId -> + ConvId -> + Galley r Public.TeamConversation +getTeamConversation zusr tid cid = liftSem $ do + tm <- + E.getTeamMember tid zusr + >>= noteED @NotATeamMember unless (tm `hasPermission` GetTeamConversations) $ - throwErrorDescription (operationDenied GetTeamConversations) - Data.teamConversation tid cid >>= maybe (throwErrorDescriptionType @ConvNotFound) pure + throw . OperationDenied . show $ GetTeamConversations + E.getTeamConversation tid cid + >>= note ConvNotFound deleteTeamConversation :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> TeamId -> @@ -864,15 +1176,37 @@ deleteTeamConversation zusr zcon _tid cid = do lconv <- qualifyLocal cid void $ API.deleteLocalConversation lusr zcon lconv -getSearchVisibilityH :: UserId ::: TeamId ::: JSON -> Galley r Response +getSearchVisibilityH :: + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore + ] + r => + UserId ::: TeamId ::: JSON -> + Galley r Response getSearchVisibilityH (uid ::: tid ::: _) = do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ E.getTeamMember tid uid void $ permissionCheck ViewTeamSearchVisibility zusrMembership json <$> getSearchVisibilityInternal tid -setSearchVisibilityH :: UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> Galley r Response +setSearchVisibilityH :: + Members + '[ Error ActionError, + Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamStore, + TeamFeatureStore + ] + r => + UserId ::: TeamId ::: JsonRequest Public.TeamSearchVisibilityView ::: JSON -> + Galley r Response setSearchVisibilityH (uid ::: tid ::: req ::: _) = do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ E.getTeamMember tid uid void $ permissionCheck ChangeTeamSearchVisibility zusrMembership setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent @@ -889,7 +1223,10 @@ setSearchVisibilityH (uid ::: tid ::: req ::: _) = do -- The last case returns those team IDs which have an associated -- user. Additionally 'k' is passed in a 'hasMore' indication (which is -- always false if the third lookup-case is used). +-- +-- FUTUREWORK: avoid CPS withTeamIds :: + (Member TeamStore r, Member (ListItems LegacyPaging TeamId) r) => UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> @@ -897,48 +1234,48 @@ withTeamIds :: Galley r a withTeamIds usr range size k = case range of Nothing -> do - r <- Data.teamIdsFrom usr Nothing (rcast size) - k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) + r <- liftSem $ E.listItems usr Nothing (rcast size) + k (resultSetType r == ResultSetTruncated) (resultSetResult r) Just (Right c) -> do - r <- Data.teamIdsFrom usr (Just c) (rcast size) - k (Data.resultSetType r == Data.ResultSetTruncated) (Data.resultSetResult r) - Just (Left cc) -> do - ids <- Data.teamIdsOf usr cc + r <- liftSem $ E.listItems usr (Just c) (rcast size) + k (resultSetType r == ResultSetTruncated) (resultSetResult r) + Just (Left (fromRange -> cc)) -> do + ids <- liftSem $ E.selectTeams usr (Data.ByteString.Conversion.fromList cc) k False ids {-# INLINE withTeamIds #-} -ensureUnboundUsers :: [UserId] -> Galley r () +ensureUnboundUsers :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => [UserId] -> Galley r () ensureUnboundUsers uids = do -- We check only 1 team because, by definition, users in binding teams -- can only be part of one team. - ts <- liftGalley0 $ mapConcurrently Data.oneUserTeam uids - let teams = toList $ fromList (catMaybes ts) - binds <- liftGalley0 $ mapConcurrently Data.teamBinding teams - when (any ((==) (Just Binding)) binds) $ - throwM userBindingExists + teams <- liftSem $ Map.elems <$> E.getUsersTeams uids + binds <- liftSem $ E.getTeamsBindings teams + liftSem . when (any (== Binding) binds) $ + throw UserBindingExists -ensureNonBindingTeam :: TeamId -> Galley r () +ensureNonBindingTeam :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => TeamId -> Galley r () ensureNonBindingTeam tid = do - team <- Data.team tid >>= ifNothing teamNotFound - when ((tdTeam team) ^. teamBinding == Binding) $ - throwM noAddToBinding + team <- liftSem $ note TeamNotFound =<< E.getTeam tid + liftSem . when ((tdTeam team) ^. teamBinding == Binding) $ + throw NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions -- this is used to ensure users cannot "elevate" permissions -ensureNotElevated :: Permissions -> TeamMember -> Galley r () +ensureNotElevated :: Member (Error ActionError) r => Permissions -> TeamMember -> Galley r () ensureNotElevated targetPermissions member = - unless - ( (targetPermissions ^. self) - `Set.isSubsetOf` (member ^. permissions . copy) - ) - $ throwM invalidPermissions - -ensureNotTooLarge :: Member BrigAccess r => TeamId -> Galley r TeamSize + liftSem + . unless + ( (targetPermissions ^. self) + `Set.isSubsetOf` (member ^. permissions . copy) + ) + $ throw InvalidPermissions + +ensureNotTooLarge :: Members '[BrigAccess, Error TeamError] r => TeamId -> Galley r TeamSize ensureNotTooLarge tid = do o <- view options - (TeamSize size) <- BrigTeam.getSize tid - unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ - throwM tooManyTeamMembers + (TeamSize size) <- liftSem $ E.getSize tid + liftSem . unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ + throw TooManyTeamMembers return $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold @@ -950,17 +1287,24 @@ ensureNotTooLarge tid = do -- size unlimited, because we make the assumption that these teams won't turn -- LegalHold off after activation. -- FUTUREWORK: Find a way around the fanout limit. -ensureNotTooLargeForLegalHold :: Member BrigAccess r => TeamId -> Int -> Galley r () -ensureNotTooLargeForLegalHold tid teamSize = do - whenM (isLegalHoldEnabledForTeam tid) $ do - unlessM (teamSizeBelowLimit teamSize) $ do - throwM tooManyTeamMembersOnTeamWithLegalhold +ensureNotTooLargeForLegalHold :: + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Int -> + Galley r () +ensureNotTooLargeForLegalHold tid teamSize = + whenM (isLegalHoldEnabledForTeam tid) $ + unlessM (teamSizeBelowLimit teamSize) $ + liftSem $ throw TooManyTeamMembersOnTeamWithLegalhold -ensureNotTooLargeToActivateLegalHold :: Member BrigAccess r => TeamId -> Galley r () +ensureNotTooLargeToActivateLegalHold :: + Members '[BrigAccess, Error TeamError] r => + TeamId -> + Galley r () ensureNotTooLargeToActivateLegalHold tid = do - (TeamSize teamSize) <- BrigTeam.getSize tid - unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ do - throwM cannotEnableLegalHoldServiceLargeTeam + (TeamSize teamSize) <- liftSem $ E.getSize tid + unlessM (teamSizeBelowLimit (fromIntegral teamSize)) $ + liftSem $ throw CannotEnableLegalHoldServiceLargeTeam teamSizeBelowLimit :: Int -> Galley r Bool teamSizeBelowLimit teamSize = do @@ -974,7 +1318,16 @@ teamSizeBelowLimit teamSize = do pure True addTeamMemberInternal :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + GundeckAccess, + MemberStore, + TeamNotificationStore, + TeamStore + ] + r => TeamId -> Maybe UserId -> Maybe ConnId -> @@ -986,15 +1339,16 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi Log.field "targets" (toByteString (new ^. userId)) . Log.field "action" (Log.val "Teams.addTeamMemberInternal") sizeBeforeAdd <- ensureNotTooLarge tid - Data.addTeamMember tid new - cc <- filter (view managedConversation) <$> Data.teamConversations tid + liftSem $ E.createTeamMember tid new + cc <- liftSem $ filter (view managedConversation) <$> E.getTeamConversations tid now <- liftIO getCurrentTime for_ cc $ \c -> do lcid <- qualifyLocal (c ^. conversationId) luid <- qualifyLocal (new ^. userId) - Data.addMember lcid luid + liftSem $ E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) - push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn + liftSem . E.push1 $ + newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e return sizeBeforeAdd where @@ -1011,7 +1365,14 @@ addTeamMemberInternal tid origin originConn (view ntmNewTeamMember -> new) memLi -- less warped. This is a work-around because we cannot send events to all of a large team. -- See haddocks of module "Galley.API.TeamNotifications" for details. getTeamNotificationsH :: - Member BrigAccess r => + Members + '[ BrigAccess, + Error TeamError, + Error NotATeamMember, + Error TeamNotificationError, + TeamNotificationStore + ] + r => UserId ::: Maybe ByteString {- NotificationId -} ::: Range 1 10000 Int32 @@ -1022,13 +1383,13 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do json @Public.QueuedNotificationList <$> APITeamQueue.getTeamNotifications zusr since size where - parseSince :: Galley r (Maybe Public.NotificationId) + parseSince :: Member (Error TeamNotificationError) r => Galley r (Maybe Public.NotificationId) parseSince = maybe (pure Nothing) (fmap Just . parseUUID) sinceRaw - parseUUID :: ByteString -> Galley r Public.NotificationId + parseUUID :: Member (Error TeamNotificationError) r => ByteString -> Galley r Public.NotificationId parseUUID raw = maybe - (throwM invalidTeamNotificationId) + (liftSem (throw InvalidTeamNotificationId)) (pure . Id) ((UUID.fromASCIIBytes >=> isV1UUID) raw) @@ -1036,7 +1397,7 @@ getTeamNotificationsH (zusr ::: sinceRaw ::: size ::: _) = do isV1UUID u = if UUID.version u == 1 then Just u else Nothing finishCreateTeam :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamStore] r => Team -> TeamMember -> [TeamMember] -> @@ -1044,46 +1405,75 @@ finishCreateTeam :: Galley r () finishCreateTeam team owner others zcon = do let zusr = owner ^. userId - for_ (owner : others) $ - Data.addTeamMember (team ^. teamId) + liftSem $ + for_ (owner : others) $ + E.createTeamMember (team ^. teamId) now <- liftIO getCurrentTime let e = newEvent TeamCreate (team ^. teamId) now & eventData ?~ EdTeamCreate team let r = membersToRecipients Nothing others - push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon + liftSem . E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon -withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b +-- FUTUREWORK: Get rid of CPS +withBindingTeam :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound - binding <- Data.teamBinding tid >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember -getBindingTeamIdH :: UserId -> Galley r Response +getBindingTeamIdH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamIdH = fmap json . getBindingTeamId -getBindingTeamId :: UserId -> Galley r TeamId +getBindingTeamId :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r TeamId getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembersH :: UserId -> Galley r Response +getBindingTeamMembersH :: Members '[Error TeamError, Error NotATeamMember, TeamStore] r => UserId -> Galley r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers -getBindingTeamMembers :: UserId -> Galley r TeamMemberList +getBindingTeamMembers :: + Members + '[ Error TeamError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + Galley r TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> - Data.teamMembersForFanout tid + getTeamMembersForFanout tid -canUserJoinTeamH :: Member BrigAccess r => TeamId -> Galley r Response +canUserJoinTeamH :: + Members '[BrigAccess, Error LegalHoldError, LegalHoldStore, TeamFeatureStore] r => + TeamId -> + Galley r Response canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold -canUserJoinTeam :: Member BrigAccess r => TeamId -> Galley r () +canUserJoinTeam :: + Members + '[ BrigAccess, + Error LegalHoldError, + LegalHoldStore, + TeamFeatureStore + ] + r => + TeamId -> + Galley r () canUserJoinTeam tid = do lhEnabled <- isLegalHoldEnabledForTeam tid when lhEnabled $ do - (TeamSize sizeBeforeJoin) <- BrigTeam.getSize tid + (TeamSize sizeBeforeJoin) <- liftSem $ E.getSize tid ensureNotTooLargeForLegalHold tid (fromIntegral sizeBeforeJoin + 1) -getTeamSearchVisibilityAvailableInternal :: TeamId -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: + Member TeamFeatureStore r => + TeamId -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal tid = do -- TODO: This is just redundant given there is a decent default defConfig <- do @@ -1092,45 +1482,79 @@ getTeamSearchVisibilityAvailableInternal tid = do FeatureTeamSearchVisibilityEnabledByDefault -> Public.TeamFeatureEnabled FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled - fromMaybe defConfig - <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid + liftSem $ + fromMaybe defConfig + <$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility tid -- | Modify and get visibility type for a team (internal, no user permission checks) -getSearchVisibilityInternalH :: TeamId ::: JSON -> Galley r Response +getSearchVisibilityInternalH :: + Member SearchVisibilityStore r => + TeamId ::: JSON -> + Galley r Response getSearchVisibilityInternalH (tid ::: _) = json <$> getSearchVisibilityInternal tid -getSearchVisibilityInternal :: TeamId -> Galley r TeamSearchVisibilityView -getSearchVisibilityInternal = fmap TeamSearchVisibilityView . SearchVisibilityData.getSearchVisibility - -setSearchVisibilityInternalH :: TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> Galley r Response +getSearchVisibilityInternal :: + Member SearchVisibilityStore r => + TeamId -> + Galley r TeamSearchVisibilityView +getSearchVisibilityInternal = + fmap TeamSearchVisibilityView . liftSem + . SearchVisibilityData.getSearchVisibility + +setSearchVisibilityInternalH :: + Members + '[ Error InvalidInput, + Error TeamError, + Error NotATeamMember, + SearchVisibilityStore, + TeamFeatureStore + ] + r => + TeamId ::: JsonRequest TeamSearchVisibilityView ::: JSON -> + Galley r Response setSearchVisibilityInternalH (tid ::: req ::: _) = do setSearchVisibilityInternal tid =<< fromJsonBody req pure noContent -setSearchVisibilityInternal :: TeamId -> TeamSearchVisibilityView -> Galley r () +setSearchVisibilityInternal :: + Members '[Error TeamError, Error NotATeamMember, SearchVisibilityStore, TeamFeatureStore] r => + TeamId -> + TeamSearchVisibilityView -> + Galley r () setSearchVisibilityInternal tid (TeamSearchVisibilityView searchVisibility) = do status <- getTeamSearchVisibilityAvailableInternal tid - unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ - throwM teamSearchVisibilityNotEnabled - SearchVisibilityData.setSearchVisibility tid searchVisibility + liftSem . unless (Public.tfwoStatus status == Public.TeamFeatureEnabled) $ + throw TeamSearchVisibilityNotEnabled + liftSem $ SearchVisibilityData.setSearchVisibility tid searchVisibility -userIsTeamOwnerH :: TeamId ::: UserId ::: JSON -> Galley r Response +userIsTeamOwnerH :: + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId ::: UserId ::: JSON -> + Galley r Response userIsTeamOwnerH (tid ::: uid ::: _) = do userIsTeamOwner tid uid >>= \case True -> pure empty - False -> throwM accessDenied + False -> liftSem $ throw AccessDenied -userIsTeamOwner :: TeamId -> UserId -> Galley r Bool +userIsTeamOwner :: + Members '[Error TeamError, Error NotATeamMember, TeamStore] r => + TeamId -> + UserId -> + Galley r Bool userIsTeamOwner tid uid = do let asking = uid isTeamOwner . fst <$> getTeamMember asking tid uid -- Queues a team for async deletion -queueTeamDeletion :: TeamId -> UserId -> Maybe ConnId -> Galley r () +queueTeamDeletion :: + Member (Error InternalError) r => + TeamId -> + UserId -> + Maybe ConnId -> + Galley r () queueTeamDeletion tid zusr zcon = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr zcon) - if ok - then pure () - else throwM deleteQueueFull + liftSem . unless ok $ + throw DeleteQueueFull diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index b34917162d3..4498865cf33 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -38,14 +38,14 @@ module Galley.API.Teams.Features setFileSharingInternal, getConferenceCallingInternal, setConferenceCallingInternal, + getSelfDeletingMessagesInternal, + setSelfDeletingMessagesInternal, DoAuth (..), GetFeatureInternalParam, ) where -import Bilge (MonadHttp) import Control.Lens -import Control.Monad.Catch import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) import qualified Data.HashMap.Strict as HashMap @@ -57,24 +57,31 @@ import Galley.API.LegalHold import Galley.API.Teams (ensureNotTooLargeToActivateLegalHold) import Galley.API.Util import Galley.App -import qualified Galley.Data as Data -import qualified Galley.Data.SearchVisibility as SearchVisibilityData -import qualified Galley.Data.TeamFeatures as TeamFeatures +import Galley.Cassandra.Paging +import Galley.Data.TeamFeatures import Galley.Effects -import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush, push1) +import Galley.Effects.GundeckAccess +import Galley.Effects.Paging +import qualified Galley.Effects.SearchVisibilityStore as SearchVisibilityData +import qualified Galley.Effects.TeamFeatureStore as TeamFeatures +import Galley.Effects.TeamStore +import Galley.Intra.Push (PushEvent (FeatureConfigEvent), newPush) import Galley.Options import Galley.Types.Teams hiding (newTeam) import Imports import Network.HTTP.Client (Manager) import Network.Wai import Network.Wai.Predicate hiding (Error, or, result, setStatus) -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error import Servant.API ((:<|>) ((:<|>))) import qualified Servant.Client as Client import qualified System.Logger.Class as Log import Util.Options (Endpoint, epHost, epPort) -import Wire.API.Event.FeatureConfig (EventData (EdFeatureWithoutConfigChanged)) +import Wire.API.ErrorDescription +import Wire.API.Event.FeatureConfig import qualified Wire.API.Event.FeatureConfig as Event +import Wire.API.Federation.Client import qualified Wire.API.Routes.Internal.Brig as IAPI import Wire.API.Team.Feature (AllFeatureConfigs (..), FeatureHasNoConfig, KnownTeamFeatureName, TeamFeatureName) import qualified Wire.API.Team.Feature as Public @@ -85,7 +92,15 @@ data DoAuth = DoAuth UserId | DontDoAuth -- and a team id, but no uid of the member for which the feature config holds. getFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -93,7 +108,7 @@ getFeatureStatus :: getFeatureStatus getter doauth tid = do case doauth of DoAuth uid -> do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ getTeamMember tid uid void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -102,7 +117,15 @@ getFeatureStatus getter doauth tid = do -- | For team-settings, like 'getFeatureStatus'. setFeatureStatus :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (TeamId -> Public.TeamFeatureStatus a -> Galley r (Public.TeamFeatureStatus a)) -> DoAuth -> TeamId -> @@ -111,7 +134,7 @@ setFeatureStatus :: setFeatureStatus setter doauth tid status = do case doauth of DoAuth uid -> do - zusrMembership <- Data.teamMember tid uid + zusrMembership <- liftSem $ getTeamMember tid uid void $ permissionCheck (ChangeTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership DontDoAuth -> assertTeamExists tid @@ -120,28 +143,49 @@ setFeatureStatus setter doauth tid status = do -- | For individual users to get feature config for their account (personal or team). getFeatureConfig :: forall (a :: Public.TeamFeatureName) r. - Public.KnownTeamFeatureName a => + ( Public.KnownTeamFeatureName a, + Members + '[ Error ActionError, + Error TeamError, + Error NotATeamMember, + TeamStore + ] + r + ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> UserId -> Galley r (Public.TeamFeatureStatus a) getFeatureConfig getter zusr = do - mbTeam <- Data.oneUserTeam zusr + mbTeam <- liftSem $ getOneUserTeam zusr case mbTeam of Nothing -> getter (Left (Just zusr)) Just tid -> do - zusrMembership <- Data.teamMember tid zusr + zusrMembership <- liftSem $ getTeamMember tid zusr void $ permissionCheck (ViewTeamFeature (Public.knownTeamFeatureName @a)) zusrMembership assertTeamExists tid getter (Right tid) -getAllFeatureConfigs :: UserId -> Galley r AllFeatureConfigs +getAllFeatureConfigs :: + Members + '[ Error ActionError, + Error InternalError, + Error NotATeamMember, + Error TeamError, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId -> + Galley r AllFeatureConfigs getAllFeatureConfigs zusr = do - mbTeam <- Data.oneUserTeam zusr - zusrMembership <- maybe (pure Nothing) (flip Data.teamMember zusr) mbTeam + mbTeam <- liftSem $ getOneUserTeam zusr + zusrMembership <- maybe (pure Nothing) (liftSem . (flip getTeamMember zusr)) mbTeam let getStatus :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, - Aeson.ToJSON (Public.TeamFeatureStatus a) + Aeson.ToJSON (Public.TeamFeatureStatus a), + Members '[Error ActionError, Error TeamError, Error NotATeamMember, TeamStore] r ) => (GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus a)) -> Galley r (Text, Aeson.Value) @@ -162,14 +206,41 @@ getAllFeatureConfigs zusr = do getStatus @'Public.TeamFeatureAppLock getAppLockInternal, getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] -getAllFeaturesH :: UserId ::: TeamId ::: JSON -> Galley r Response +getAllFeaturesH :: + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId ::: TeamId ::: JSON -> + Galley r Response getAllFeaturesH (uid ::: tid ::: _) = json <$> getAllFeatures uid tid -getAllFeatures :: UserId -> TeamId -> Galley r Aeson.Value +getAllFeatures :: + forall r. + Members + '[ Error ActionError, + Error InternalError, + Error TeamError, + Error NotATeamMember, + LegalHoldStore, + TeamFeatureStore, + TeamStore + ] + r => + UserId -> + TeamId -> + Galley r Aeson.Value getAllFeatures uid tid = do Aeson.object <$> sequence @@ -181,11 +252,12 @@ getAllFeatures uid tid = do getStatus @'Public.TeamFeatureAppLock getAppLockInternal, getStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, - getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal + getStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, + getStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal ] where getStatus :: - forall (a :: Public.TeamFeatureName) r. + forall (a :: Public.TeamFeatureName). ( Public.KnownTeamFeatureName a, Aeson.ToJSON (Public.TeamFeatureStatus a) ) => @@ -198,20 +270,23 @@ getAllFeatures uid tid = do getFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. - (Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, TeamFeatures.HasStatusCol a) => + ( Public.FeatureHasNoConfig a, + HasStatusCol a, + Member TeamFeatureStore r + ) => Galley r Public.TeamFeatureStatusValue -> TeamId -> Galley r (Public.TeamFeatureStatus a) getFeatureStatusNoConfig getDefault tid = do defaultStatus <- Public.TeamFeatureStatusNoConfig <$> getDefault - fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid + liftSem $ fromMaybe defaultStatus <$> TeamFeatures.getFeatureStatusNoConfig @a tid setFeatureStatusNoConfig :: forall (a :: Public.TeamFeatureName) r. ( Public.KnownTeamFeatureName a, Public.FeatureHasNoConfig a, - TeamFeatures.HasStatusCol a, - Member GundeckAccess r + HasStatusCol a, + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r ) => (Public.TeamFeatureStatusValue -> TeamId -> Galley r ()) -> TeamId -> @@ -219,7 +294,7 @@ setFeatureStatusNoConfig :: Galley r (Public.TeamFeatureStatus a) setFeatureStatusNoConfig applyState tid status = do applyState (Public.tfwoStatus status) tid - newStatus <- TeamFeatures.setFeatureStatusNoConfig @a tid status + newStatus <- liftSem $ TeamFeatures.setFeatureStatusNoConfig @a tid status pushFeatureConfigEvent tid $ Event.Event Event.Update (Public.knownTeamFeatureName @a) (EdFeatureWithoutConfigChanged newStatus) pure newStatus @@ -228,7 +303,10 @@ setFeatureStatusNoConfig applyState tid status = do -- the feature flag, so that we get more type safety. type GetFeatureInternalParam = Either (Maybe UserId) TeamId -getSSOStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) +getSSOStatusInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) getSSOStatusInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -241,15 +319,18 @@ getSSOStatusInternal = FeatureSSODisabledByDefault -> Public.TeamFeatureDisabled setSSOStatusInternal :: - Member GundeckAccess r => + Members '[Error TeamFeatureError, GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSSO) setSSOStatusInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSSO $ \case - Public.TeamFeatureDisabled -> const (throwM disableSsoNotImplemented) + Public.TeamFeatureDisabled -> const (liftSem (throw DisableSsoNotImplemented)) Public.TeamFeatureEnabled -> const (pure ()) -getTeamSearchVisibilityAvailableInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) +getTeamSearchVisibilityAvailableInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) getTeamSearchVisibilityAvailableInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -261,15 +342,18 @@ getTeamSearchVisibilityAvailableInternal = FeatureTeamSearchVisibilityDisabledByDefault -> Public.TeamFeatureDisabled setTeamSearchVisibilityAvailableInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, SearchVisibilityStore, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSearchVisibility) setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.TeamFeatureSearchVisibility $ \case - Public.TeamFeatureDisabled -> SearchVisibilityData.resetSearchVisibility + Public.TeamFeatureDisabled -> liftSem . SearchVisibilityData.resetSearchVisibility Public.TeamFeatureEnabled -> const (pure ()) -getValidateSAMLEmailsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) +getValidateSAMLEmailsInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -281,13 +365,16 @@ getValidateSAMLEmailsInternal = getDef = pure Public.TeamFeatureDisabled setValidateSAMLEmailsInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureValidateSAMLEmails) setValidateSAMLEmailsInternal = setFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails $ \_ _ -> pure () -getDigitalSignaturesInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) +getDigitalSignaturesInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) getDigitalSignaturesInternal = either (const $ Public.TeamFeatureStatusNoConfig <$> getDef) @@ -299,13 +386,16 @@ getDigitalSignaturesInternal = getDef = pure Public.TeamFeatureDisabled setDigitalSignaturesInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureDigitalSignatures) setDigitalSignaturesInternal = setFeatureStatusNoConfig @'Public.TeamFeatureDigitalSignatures $ \_ _ -> pure () -getLegalholdStatusInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) +getLegalholdStatusInternal :: + Members '[LegalHoldStore, TeamFeatureStore] r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) getLegalholdStatusInternal (Left _) = pure $ Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled getLegalholdStatusInternal (Right tid) = do @@ -314,7 +404,35 @@ getLegalholdStatusInternal (Right tid) = do False -> Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled setLegalholdStatusInternal :: - Members '[BotAccess, BrigAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => + ( Paging p, + Bounded (PagingBounds p TeamMember), + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error AuthenticationError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error TeamError, + Error NotATeamMember, + Error TeamFeatureError, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + LegalHoldStore, + ListItems LegacyPaging ConvId, + MemberStore, + TeamFeatureStore, + TeamStore, + TeamMemberStore p + ] + r + ) => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureLegalHold) @@ -324,28 +442,31 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do -- enabeling LH for teams is only allowed in normal operation; disabled-permanently and -- whitelist-teams have no or their own way to do that, resp. featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) - case featureLegalHold of + liftSem $ case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do pure () FeatureLegalHoldDisabledPermanently -> do - throwM legalHoldFeatureFlagNotEnabled + throw LegalHoldFeatureFlagNotEnabled FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do - throwM legalHoldWhitelistedOnly + throw LegalHoldWhitelistedOnly -- we're good to update the status now. case statusValue of Public.TeamFeatureDisabled -> removeSettings' tid Public.TeamFeatureEnabled -> do ensureNotTooLargeToActivateLegalHold tid - TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status + liftSem $ TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status -getFileSharingInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) getFileSharingInternal = getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. - (KnownTeamFeatureName a, TeamFeatures.HasStatusCol a, FeatureHasNoConfig a) => + (KnownTeamFeatureName a, HasStatusCol a, FeatureHasNoConfig a, Member TeamFeatureStore r) => Lens' FeatureFlags (Defaults (Public.TeamFeatureStatus a)) -> Maybe TeamId -> Galley r (Public.TeamFeatureStatus a) @@ -360,23 +481,35 @@ getFeatureStatusWithDefaultConfig lens' = <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureFileSharing) setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () -getAppLockInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +getAppLockInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) getAppLockInternal mbtid = do Defaults defaultStatus <- view (options . optSettings . setFeatureFlags . flagAppLockDefaults) - status <- join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) + status <- + liftSem $ + join <$> (TeamFeatures.getApplockFeatureStatus `mapM` either (const Nothing) Just mbtid) pure $ fromMaybe defaultStatus status -setAppLockInternal :: TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) +setAppLockInternal :: + Members '[GundeckAccess, TeamFeatureStore, TeamStore, Error TeamFeatureError] r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureAppLock -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureAppLock) setAppLockInternal tid status = do when (Public.applockInactivityTimeoutSecs (Public.tfwcConfig status) < 30) $ - throwM inactivityTimeoutTooLow - TeamFeatures.setApplockFeatureStatus tid status + liftSem $ throw AppLockinactivityTimeoutTooLow + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event Event.Update Public.TeamFeatureAppLock (EdFeatureApplockChanged status) + (liftSem $ TeamFeatures.setApplockFeatureStatus tid status) <* pushEvent getClassifiedDomainsInternal :: GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureClassifiedDomains) getClassifiedDomainsInternal _mbtid = do @@ -388,6 +521,7 @@ getClassifiedDomainsInternal _mbtid = do Public.TeamFeatureEnabled -> config getConferenceCallingInternal :: + Members '[Error InternalError, TeamFeatureStore] r => GetFeatureInternalParam -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) getConferenceCallingInternal (Left (Just uid)) = do @@ -398,15 +532,42 @@ getConferenceCallingInternal (Right tid) = do getFeatureStatusWithDefaultConfig @'Public.TeamFeatureConferenceCalling flagConferenceCalling (Just tid) setConferenceCallingInternal :: - Member GundeckAccess r => + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => TeamId -> Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling -> Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureConferenceCalling) -setConferenceCallingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () +setConferenceCallingInternal = + setFeatureStatusNoConfig @'Public.TeamFeatureConferenceCalling $ \_status _tid -> pure () -pushFeatureConfigEvent :: Member GundeckAccess r => TeamId -> Event.Event -> Galley r () +getSelfDeletingMessagesInternal :: + Member TeamFeatureStore r => + GetFeatureInternalParam -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +getSelfDeletingMessagesInternal = \case + Left _ -> pure Public.defaultSelfDeletingMessagesStatus + Right tid -> + liftSem $ + TeamFeatures.getSelfDeletingMessagesStatus tid + <&> maybe Public.defaultSelfDeletingMessagesStatus id + +setSelfDeletingMessagesInternal :: + Members '[GundeckAccess, TeamFeatureStore, TeamStore] r => + TeamId -> + Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages -> + Galley r (Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages) +setSelfDeletingMessagesInternal tid st = do + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event Event.Update Public.TeamFeatureSelfDeletingMessages (EdFeatureSelfDeletingMessagesChanged st) + (liftSem $ TeamFeatures.setSelfDeletingMessagesStatus tid st) <* pushEvent + +pushFeatureConfigEvent :: + Members '[GundeckAccess, TeamStore] r => + TeamId -> + Event.Event -> + Galley r () pushFeatureConfigEvent tid event = do - memList <- Data.teamMembersForFanout tid + memList <- getTeamMembersForFanout tid when ((memList ^. teamMemberListType) == ListTruncated) $ do Log.warn $ Log.field "action" (Log.val "Features.pushFeatureConfigEvent") @@ -416,12 +577,12 @@ pushFeatureConfigEvent tid event = do let recipients = membersToRecipients Nothing (memList ^. teamMembers) for_ (newPush (memList ^. teamMemberListType) Nothing (FeatureConfigEvent event) recipients) - push1 + (liftSem . push1) -- | (Currently, we only have 'Public.TeamFeatureConferenceCalling' here, but we may have to -- extend this in the future.) getFeatureConfigViaAccount :: - (flag ~ 'Public.TeamFeatureConferenceCalling) => + (flag ~ 'Public.TeamFeatureConferenceCalling, Member (Error InternalError) r) => UserId -> Galley r (Public.TeamFeatureStatus flag) getFeatureConfigViaAccount uid = do @@ -430,13 +591,14 @@ getFeatureConfigViaAccount uid = do getAccountFeatureConfigClient brigep mgr uid >>= handleResp where handleResp :: + Member (Error InternalError) r => Either Client.ClientError Public.TeamFeatureStatusNoConfig -> Galley r Public.TeamFeatureStatusNoConfig handleResp (Right cfg) = pure cfg - handleResp (Left errmsg) = throwM . internalErrorWithDescription . cs . show $ errmsg + handleResp (Left errmsg) = liftSem . throw . InternalErrorWithDescription . cs . show $ errmsg getAccountFeatureConfigClient :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> UserId -> @@ -452,7 +614,7 @@ getFeatureConfigViaAccount uid = do ) = Client.client (Proxy @IAPI.API) runHereClientM :: - (HasCallStack, MonadIO m, MonadHttp m) => + (HasCallStack, MonadIO m) => Endpoint -> Manager -> Client.ClientM a -> diff --git a/services/galley/src/Galley/API/Teams/Notifications.hs b/services/galley/src/Galley/API/Teams/Notifications.hs index 08edac5eb25..0836369ee8a 100644 --- a/services/galley/src/Galley/API/Teams/Notifications.hs +++ b/services/galley/src/Galley/API/Teams/Notifications.hs @@ -52,38 +52,37 @@ import Galley.API.Error import Galley.App import qualified Galley.Data.TeamNotifications as DataTeamQueue import Galley.Effects -import Galley.Intra.User as Intra +import Galley.Effects.BrigAccess as Intra +import qualified Galley.Effects.TeamNotificationStore as E import Galley.Types.Teams hiding (newTeam) import Gundeck.Types.Notification import Imports import Network.HTTP.Types -import Network.Wai.Utilities +import Network.Wai.Utilities hiding (Error) +import Polysemy.Error getTeamNotifications :: - Member BrigAccess r => + Members '[BrigAccess, Error TeamError, TeamNotificationStore] r => UserId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r QueuedNotificationList getTeamNotifications zusr since size = do - tid :: TeamId <- do - mtid <- (userTeam . accountUser =<<) <$> Intra.getUser zusr - let err = throwM teamNotFound - maybe err pure mtid - page <- DataTeamQueue.fetch tid since size + tid <- liftSem . (note TeamNotFound =<<) $ (userTeam . accountUser =<<) <$> Intra.getUser zusr + page <- liftSem $ E.getTeamNotifications tid since size pure $ queuedNotificationList (toList (DataTeamQueue.resultSeq page)) (DataTeamQueue.resultHasMore page) Nothing -pushTeamEvent :: TeamId -> Event -> Galley r () +pushTeamEvent :: Member TeamNotificationStore r => TeamId -> Event -> Galley r () pushTeamEvent tid evt = do - nid <- mkNotificationId - DataTeamQueue.add tid nid (List1.singleton $ toJSONObject evt) + nid <- liftIO mkNotificationId + liftSem $ E.createTeamNotification tid nid (List1.singleton $ toJSONObject evt) -- | 'Data.UUID.V1.nextUUID' is sometimes unsuccessful, so we try a few times. -mkNotificationId :: (MonadIO m, MonadThrow m) => m NotificationId +mkNotificationId :: IO NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) maybe (throwM err) return ni diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index dee504abe4f..98344a35462 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -33,7 +33,6 @@ module Galley.API.Update updateLocalConversationMessageTimer, updateConversationMessageTimerUnqualified, updateConversationMessageTimer, - updateLocalConversation, updateConversationAccessUnqualified, updateConversationAccess, deleteLocalConversation, @@ -50,9 +49,6 @@ module Galley.API.Update removeMemberFromLocalConv, removeMemberFromRemoteConv, - -- * Notifications - notifyConversationMetadataUpdate, - -- * Talking postProteusMessage, postOtrMessageUnqualified, @@ -69,116 +65,172 @@ module Galley.API.Update ) where -import qualified Brig.Types.User as User import Control.Lens -import Control.Monad.Catch import Control.Monad.State import Control.Monad.Trans.Maybe import Data.Code import Data.Either.Extra (mapRight) import Data.Id import Data.Json.Util (fromBase64TextLenient, toUTCTimeMillis) -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.List1 import qualified Data.Map.Strict as Map -import Data.Misc (FutureWork (FutureWork)) import Data.Qualified import Data.Range import qualified Data.Set as Set import Data.Time +import Galley.API.Action import Galley.API.Error import Galley.API.LegalHold.Conflicts (guardLegalholdPolicyConflicts) import Galley.API.Mapping import Galley.API.Message import Galley.API.Util import Galley.App -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Data.Services as Data import Galley.Data.Types hiding (Conversation) import Galley.Effects -import qualified Galley.External as External -import qualified Galley.Intra.Client as Intra +import qualified Galley.Effects.BrigAccess as E +import qualified Galley.Effects.ClientStore as E +import qualified Galley.Effects.CodeStore as E +import qualified Galley.Effects.ConversationStore as E +import qualified Galley.Effects.ExternalAccess as E +import qualified Galley.Effects.FederatorAccess as E +import qualified Galley.Effects.GundeckAccess as E +import qualified Galley.Effects.MemberStore as E +import qualified Galley.Effects.ServiceStore as E +import qualified Galley.Effects.TeamStore as E import Galley.Intra.Push -import Galley.Intra.User (deleteBot, getContactList, lookupActivatedUsers) import Galley.Options import Galley.Types import Galley.Types.Bot hiding (addBot) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients -import Galley.Types.Conversations.Roles (Action (..), RoleName, roleNameWireMember) +import Galley.Types.Conversations.Members (newMember) +import Galley.Types.Conversations.Roles (Action (..), roleNameWireMember) import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList -import Galley.Validation import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai -import Network.Wai.Predicate hiding (and, failure, setStatus, _1, _2) -import Network.Wai.Utilities +import Network.Wai.Predicate hiding (Error, and, failure, setStatus, _1, _2) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action import qualified Wire.API.Conversation.Code as Public import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription - ( CodeNotFound, - ConvNotFound, - MissingLegalholdConsent, - UnknownClient, - mkErrorDescription, - ) -import qualified Wire.API.ErrorDescription as Public import qualified Wire.API.Event.Conversation as Public import qualified Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (HasFederatorConfig (..)) -import Wire.API.Federation.Error (federationNotConfigured, federationNotImplemented) +import Wire.API.Federation.Client import qualified Wire.API.Message as Public import Wire.API.Routes.Public.Galley.Responses import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) -import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client -acceptConvH :: Member GundeckAccess r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response +acceptConvH :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => + UserId ::: Maybe ConnId ::: ConvId -> + Galley r Response acceptConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> acceptConv usr conn cnv -acceptConv :: Member GundeckAccess r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation +acceptConv :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => + UserId -> + Maybe ConnId -> + ConvId -> + Galley r Conversation acceptConv usr conn cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem $ E.getConversation cnv >>= note ConvNotFound conv' <- acceptOne2One usr conv conn conversationView usr conv' -blockConvH :: UserId ::: ConvId -> Galley r Response +blockConvH :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => + UserId ::: ConvId -> + Galley r Response blockConvH (zusr ::: cnv) = empty <$ blockConv zusr cnv -blockConv :: UserId -> ConvId -> Galley r () +blockConv :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + MemberStore + ] + r => + UserId -> + ConvId -> + Galley r () blockConv zusr cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "block: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv let mems = Data.convLocalMembers conv - when (zusr `isMember` mems) $ Data.removeMember zusr cnv + when (zusr `isMember` mems) . liftSem $ + E.deleteMembers cnv (UserList [zusr] []) unblockConvH :: - Member GundeckAccess r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: ConvId -> Galley r Response unblockConvH (usr ::: conn ::: cnv) = setStatus status200 . json <$> unblockConv usr conn cnv unblockConv :: - Member GundeckAccess r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> ConvId -> Galley r Conversation unblockConv usr conn cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem $ E.getConversation cnv >>= note ConvNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ - throwM $ - invalidOp "unblock: invalid conversation type" + liftSem . throw . InvalidOp . Data.convType $ conv conv' <- acceptOne2One usr conv conn conversationView usr conv' @@ -190,7 +242,23 @@ handleUpdateResult = \case Unchanged -> empty & setStatus status204 updateConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -206,7 +274,22 @@ updateConversationAccess usr con qcnv update = do doUpdate qcnv lusr con update updateConversationAccessUnqualified :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -218,93 +301,52 @@ updateConversationAccessUnqualified usr zcon cnv update = do updateLocalConversationAccess lcnv lusr zcon update updateLocalConversationAccess :: - Members UpdateConversationActions r => + Members + '[ BotAccess, + BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + FireAndForget, + GundeckAccess, + MemberStore, + TeamStore + ] + r => Local ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateLocalConversationAccess lcnv lusr con target = +updateLocalConversationAccess lcnv lusr con = getUpdateResult . updateLocalConversation lcnv (qUntagged lusr) (Just con) - . ConversationActionAccessUpdate - $ target updateRemoteConversationAccess :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationAccessData -> Galley r (UpdateResult Event) -updateRemoteConversationAccess _ _ _ _ = throwM federationNotImplemented - -performAccessUpdateAction :: - forall r. - Members '[BrigAccess, BotAccess, ExternalAccess, FederatorAccess, FireAndForget, GundeckAccess] r => - Qualified UserId -> - Data.Conversation -> - ConversationAccessData -> - MaybeT (Galley r) () -performAccessUpdateAction qusr conv target = do - lcnv <- qualifyLocal (Data.convId conv) - guard $ Data.convAccessData conv /= target - -- Remove conversation codes if CodeAccess is revoked - when - ( CodeAccess `elem` Data.convAccess conv - && CodeAccess `notElem` cupAccess target - ) - $ lift $ do - key <- mkKey (tUnqualified lcnv) - Data.deleteCode key ReusableCode - - -- Determine bots and members to be removed - let filterBotsAndMembers = filterActivated >=> filterTeammates - let current = convBotsAndMembers conv -- initial bots and members - desired <- lift $ filterBotsAndMembers current -- desired bots and members - let toRemove = bmDiff current desired -- bots and members to be removed - - -- Update Cassandra - lift $ Data.updateConversationAccess (tUnqualified lcnv) target - lift . fireAndForget $ do - -- Remove bots - traverse_ (deleteBot (tUnqualified lcnv)) (map botMemId (toList (bmBots toRemove))) - - -- Update current bots and members - let current' = current {bmBots = bmBots desired} - - -- Remove users and notify everyone - void . for_ (nonEmpty (bmQualifiedMembers lcnv toRemove)) $ \usersToRemove -> do - let action = ConversationActionRemoveMembers usersToRemove - void . runMaybeT $ performAction qusr conv action - notifyConversationMetadataUpdate qusr Nothing lcnv current' action - where - filterActivated :: BotsAndMembers -> Galley r BotsAndMembers - filterActivated bm - | ( Data.convAccessRole conv > ActivatedAccessRole - && cupAccessRole target <= ActivatedAccessRole - ) = do - activated <- map User.userId <$> lookupActivatedUsers (toList (bmLocals bm)) - -- FUTUREWORK: should we also remove non-activated remote users? - pure $ bm {bmLocals = Set.fromList activated} - | otherwise = pure bm - - filterTeammates :: BotsAndMembers -> Galley r BotsAndMembers - filterTeammates bm = do - -- In a team-only conversation we also want to remove bots and guests - case (cupAccessRole target, Data.convTeam conv) of - (TeamAccessRole, Just tid) -> do - onlyTeamUsers <- flip filterM (toList (bmLocals bm)) $ \user -> - isJust <$> Data.teamMember tid user - pure $ - BotsAndMembers - { bmLocals = Set.fromList onlyTeamUsers, - bmBots = mempty, - bmRemotes = mempty - } - _ -> pure bm +updateRemoteConversationAccess _ _ _ _ = liftSem $ throw FederationNotImplemented updateConversationReceiptMode :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => + Members '[Error FederationError] r => UserId -> ConnId -> Qualified ConvId -> @@ -320,7 +362,16 @@ updateConversationReceiptMode usr zcon qcnv update = do doUpdate qcnv lusr zcon update updateConversationReceiptModeUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -332,7 +383,16 @@ updateConversationReceiptModeUnqualified usr zcon cnv update = do updateLocalConversationReceiptMode lcnv lusr zcon update updateLocalConversationReceiptMode :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -340,19 +400,28 @@ updateLocalConversationReceiptMode :: Galley r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionReceiptModeUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update updateRemoteConversationReceiptMode :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Public.ConversationReceiptModeUpdate -> Galley r (UpdateResult Event) -updateRemoteConversationReceiptMode _ _ _ _ = throwM federationNotImplemented +updateRemoteConversationReceiptMode _ _ _ _ = liftSem $ throw FederationNotImplemented updateConversationMessageTimerUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -364,7 +433,17 @@ updateConversationMessageTimerUnqualified usr zcon cnv update = do updateLocalConversationMessageTimer lusr zcon lcnv update updateConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -375,12 +454,21 @@ updateConversationMessageTimer usr zcon qcnv update = do foldQualified lusr (updateLocalConversationMessageTimer lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv update updateLocalConversationMessageTimer :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -388,107 +476,43 @@ updateLocalConversationMessageTimer :: Galley r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMessageTimerUpdate update + updateLocalConversation lcnv (qUntagged lusr) (Just con) update deleteLocalConversation :: - Members UpdateConversationActions r => + Members + '[ CodeStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + TeamStore + ] + r => Local UserId -> ConnId -> Local ConvId -> Galley r (UpdateResult Event) deleteLocalConversation lusr con lcnv = getUpdateResult $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationActionDelete - -type UpdateConversationActions = - '[ BotAccess, - BrigAccess, - ExternalAccess, - FederatorAccess, - FireAndForget, - GundeckAccess - ] - --- | Update a local conversation, and notify all local and remote members. -updateLocalConversation :: - Members UpdateConversationActions r => - Local ConvId -> - Qualified UserId -> - Maybe ConnId -> - ConversationAction -> - MaybeT (Galley r) Event -updateLocalConversation lcnv qusr con action = do - -- retrieve conversation - (conv, self) <- - lift $ - getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvNotFound) - qusr - (tUnqualified lcnv) - - -- perform checks - lift $ ensureConversationActionAllowed action conv self - - -- perform action - (extraTargets, action') <- performAction qusr conv action - - -- send notifications to both local and remote users - lift $ - notifyConversationMetadataUpdate - qusr - con - lcnv - (convBotsAndMembers conv <> extraTargets) - action' + updateLocalConversation lcnv (qUntagged lusr) (Just con) ConversationDelete getUpdateResult :: Functor m => MaybeT m a -> m (UpdateResult a) getUpdateResult = fmap (maybe Unchanged Updated) . runMaybeT --- | Perform a conversation action, and return extra notification targets and --- an updated action. -performAction :: - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - ConversationAction -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAction qusr conv action = case action of - ConversationActionAddMembers members role -> - performAddMemberAction qusr conv members role - ConversationActionRemoveMembers members -> do - performRemoveMemberAction conv (toList members) - pure (mempty, action) - ConversationActionRename rename -> lift $ do - cn <- rangeChecked (cupName rename) - Data.updateConversation (Data.convId conv) cn - pure (mempty, action) - ConversationActionMessageTimerUpdate update -> do - guard $ Data.convMessageTimer conv /= cupMessageTimer update - lift $ Data.updateConversationMessageTimer (Data.convId conv) (cupMessageTimer update) - pure (mempty, action) - ConversationActionReceiptModeUpdate update -> do - guard $ Data.convReceiptMode conv /= Just (cruReceiptMode update) - lift $ Data.updateConversationReceiptMode (Data.convId conv) (cruReceiptMode update) - pure (mempty, action) - ConversationActionMemberUpdate target update -> lift $ do - lcnv <- qualifyLocal (Data.convId conv) - void $ ensureOtherMember lcnv target conv - Data.updateOtherMemberLocalConv lcnv target update - pure (mempty, action) - ConversationActionAccessUpdate update -> do - performAccessUpdateAction qusr conv update - pure (mempty, action) - ConversationActionDelete -> lift $ do - let cid = Data.convId conv - (`Data.deleteCode` ReusableCode) =<< mkKey cid - case Data.convTeam conv of - Nothing -> Data.deleteConversation cid - Just tid -> Data.removeTeamConv tid cid - pure (mempty, action) - addCodeH :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response addCodeH (usr ::: zcon ::: cnv) = @@ -502,7 +526,14 @@ data AddCodeResult addCode :: forall r. - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -511,16 +542,16 @@ addCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv - mCode <- Data.lookupCode key ReusableCode + mCode <- liftSem $ E.getCode key ReusableCode case mCode of Nothing -> do code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable - Data.insertCode code + liftSem $ E.createCode code now <- liftIO getCurrentTime conversationCode <- createCode code let event = Event ConvCodeUpdate qcnv qusr now (EdConvCodeUpdate conversationCode) @@ -536,14 +567,28 @@ addCode usr zcon cnv = do return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix rmCodeH :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId ::: ConnId ::: ConvId -> Galley r Response rmCodeH (usr ::: zcon ::: cnv) = setStatus status200 . json <$> rmCode usr zcon cnv rmCode :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ CodeStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -552,30 +597,49 @@ rmCode usr zcon cnv = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified usr localDomain - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + conv <- + liftSem $ E.getConversation cnv >>= note ConvNotFound ensureConvMember (Data.convLocalMembers conv) usr - ensureAccess conv CodeAccess + liftSem $ ensureAccess conv CodeAccess let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- mkKey cnv - Data.deleteCode key ReusableCode + liftSem $ E.deleteCode key ReusableCode now <- liftIO getCurrentTime let event = Event ConvCodeDelete qcnv qusr now EdConvCodeDelete pushConversationEvent (Just zcon) event (map lmId users) bots pure event -getCodeH :: UserId ::: ConvId -> Galley r Response +getCodeH :: + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => + UserId ::: ConvId -> + Galley r Response getCodeH (usr ::: cnv) = setStatus status200 . json <$> getCode usr cnv -getCode :: UserId -> ConvId -> Galley r Public.ConversationCode +getCode :: + Members + '[ CodeStore, + ConversationStore, + Error CodeError, + Error ConversationError + ] + r => + UserId -> + ConvId -> + Galley r Public.ConversationCode getCode usr cnv = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv CodeAccess + conv <- + liftSem $ E.getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) usr key <- mkKey cnv - c <- - Data.lookupCode key ReusableCode - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + c <- liftSem $ E.getCode key ReusableCode >>= note CodeNotFound returnCode c returnCode :: Code -> Galley r Public.ConversationCode @@ -583,18 +647,40 @@ returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI pure $ Public.mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCodeH :: JsonRequest Public.ConversationCode -> Galley r Response +checkReusableCodeH :: + Members '[CodeStore, Error CodeError, Error InvalidInput] r => + JsonRequest Public.ConversationCode -> + Galley r Response checkReusableCodeH req = do convCode <- fromJsonBody req checkReusableCode convCode pure empty -checkReusableCode :: Public.ConversationCode -> Galley r () +checkReusableCode :: + Members '[CodeStore, Error CodeError] r => + Public.ConversationCode -> + Galley r () checkReusableCode convCode = void $ verifyReusableCode convCode joinConversationByReusableCodeH :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + FederatorAccess, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> Galley r Response joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do @@ -602,7 +688,23 @@ joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode joinConversationByReusableCode :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + CodeStore, + ConversationStore, + Error ActionError, + Error CodeError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + FederatorAccess, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Public.ConversationCode -> @@ -612,14 +714,42 @@ joinConversationByReusableCode zusr zcon convCode = do joinConversation zusr zcon (codeConversation c) CodeAccess joinConversationByIdH :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: ConvId ::: JSON -> Galley r Response joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = handleUpdateResult <$> joinConversationById zusr zcon cnv joinConversationById :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + FederatorAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -628,7 +758,21 @@ joinConversationById zusr zcon cnv = joinConversation zusr zcon cnv LinkAccess joinConversation :: - Members '[BrigAccess, FederatorAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ConversationStore, + FederatorAccess, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error NotATeamMember, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -638,7 +782,7 @@ joinConversation zusr zcon cnv access = do lusr <- qualifyLocal zusr lcnv <- qualifyLocal cnv conv <- ensureConversationAccess zusr cnv access - ensureGroupConvThrowing conv + liftSem . ensureGroupConversation $ conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [zusr] getUpdateResult $ do @@ -649,116 +793,31 @@ joinConversation zusr zcon cnv access = do (extraTargets, action) <- addMembersToLocalConversation lcnv (UserList users []) roleNameWireMember lift $ - notifyConversationMetadataUpdate + notifyConversationAction (qUntagged lusr) (Just zcon) lcnv (convBotsAndMembers conv <> extraTargets) - action - --- | Add users to a conversation without performing any checks. Return extra --- notification targets and the action performed. -addMembersToLocalConversation :: - Local ConvId -> - UserList UserId -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -addMembersToLocalConversation lcnv users role = do - (lmems, rmems) <- lift $ Data.addMembers lcnv (fmap (,role) users) - neUsers <- maybe mzero pure . nonEmpty . ulAll lcnv $ users - let action = ConversationActionAddMembers neUsers role - pure (bmFromMembers lmems rmems, action) - -performAddMemberAction :: - forall r. - Members UpdateConversationActions r => - Qualified UserId -> - Data.Conversation -> - NonEmpty (Qualified UserId) -> - RoleName -> - MaybeT (Galley r) (BotsAndMembers, ConversationAction) -performAddMemberAction qusr conv invited role = do - lcnv <- lift $ qualifyLocal (Data.convId conv) - let newMembers = ulNewMembers lcnv conv . toUserList lcnv $ invited - lift $ do - ensureMemberLimit (toList (Data.convLocalMembers conv)) newMembers - ensureAccess conv InviteAccess - checkLocals lcnv (Data.convTeam conv) (ulLocals newMembers) - checkRemotes (ulRemotes newMembers) - checkLHPolicyConflictsLocal lcnv (ulLocals newMembers) - checkLHPolicyConflictsRemote (FutureWork (ulRemotes newMembers)) - addMembersToLocalConversation lcnv newMembers role - where - userIsMember u = (^. userId . to (== u)) - - checkLocals :: Local ConvId -> Maybe TeamId -> [UserId] -> Galley r () - checkLocals lcnv (Just tid) newUsers = do - tms <- Data.teamMembersLimited tid newUsers - let userMembershipMap = map (\u -> (u, find (userIsMember u) tms)) newUsers - ensureAccessRole (Data.convAccessRole conv) userMembershipMap - tcv <- Data.teamConversation tid (tUnqualified lcnv) - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged - ensureConnectedOrSameTeam qusr newUsers - checkLocals _ Nothing newUsers = do - ensureAccessRole (Data.convAccessRole conv) (zip newUsers $ repeat Nothing) - ensureConnectedOrSameTeam qusr newUsers - - checkRemotes :: [Remote UserId] -> Galley r () - checkRemotes remotes = do - -- if federator is not configured, we fail early, so we avoid adding - -- remote members to the database - unless (null remotes) $ do - endpoint <- federatorEndpoint - when (isNothing endpoint) $ - throwM federationNotConfigured - - loc <- qualifyLocal () - foldQualified - loc - ensureConnectedToRemotes - (\_ _ -> throwM federationNotImplemented) - qusr - remotes - - checkLHPolicyConflictsLocal :: Local ConvId -> [UserId] -> Galley r () - checkLHPolicyConflictsLocal lcnv newUsers = do - let convUsers = Data.convLocalMembers conv - - allNewUsersGaveConsent <- allLegalholdConsentGiven newUsers - - whenM (anyLegalholdActivated (lmId <$> convUsers)) $ - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - whenM (anyLegalholdActivated newUsers) $ do - unless allNewUsersGaveConsent $ - throwErrorDescriptionType @MissingLegalholdConsent - - convUsersLHStatus <- do - uidsStatus <- getLHStatusForUsers (lmId <$> convUsers) - pure $ zipWith (\mem (_, status) -> (mem, status)) convUsers uidsStatus - - if any - ( \(mem, status) -> - lmConvRoleName mem == roleNameWireAdmin - && consentGiven status == ConsentGiven - ) - convUsersLHStatus - then do - for_ convUsersLHStatus $ \(mem, status) -> - when (consentGiven status == ConsentNotGiven) $ do - qvictim <- qUntagged <$> qualifyLocal (lmId mem) - void . runMaybeT $ - updateLocalConversation lcnv qvictim Nothing $ - ConversationActionRemoveMembers (pure qvictim) - else throwErrorDescriptionType @MissingLegalholdConsent - - checkLHPolicyConflictsRemote :: FutureWork 'LegalholdPlusFederationNotImplemented [Remote UserId] -> Galley r () - checkLHPolicyConflictsRemote _remotes = pure () + (conversationAction action) addMembersUnqualified :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -769,7 +828,23 @@ addMembersUnqualified zusr zcon cnv (Public.Invite users role) = do addMembers zusr zcon cnv (Public.InviteQualified qusers role) addMembers :: - Members UpdateConversationActions r => + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + Error LegalHoldError, + Error NotATeamMember, + ExternalAccess, + FederatorAccess, + GundeckAccess, + LegalHoldStore, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -780,10 +855,17 @@ addMembers zusr zcon cnv (Public.InviteQualified users role) = do lcnv <- qualifyLocal cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ - ConversationActionAddMembers users role + ConversationJoin users role updateSelfMember :: - Members '[GundeckAccess, ExternalAccess] r => + Members + '[ ConversationStore, + Error ConversationError, + GundeckAccess, + ExternalAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -791,19 +873,29 @@ updateSelfMember :: Galley r () updateSelfMember zusr zcon qcnv update = do lusr <- qualifyLocal zusr - exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr - unless exists (throwErrorDescriptionType @ConvNotFound) - Data.updateSelfMember lusr qcnv lusr update + exists <- liftSem $ foldQualified lusr checkLocalMembership checkRemoteMembership qcnv lusr + liftSem . unless exists . throw $ ConvNotFound + liftSem $ E.setSelfMember qcnv lusr update now <- liftIO getCurrentTime let e = Event MemberStateUpdate qcnv (qUntagged lusr) now (EdMemberUpdate (updateData lusr)) pushConversationEvent (Just zcon) e [zusr] [] where + checkLocalMembership :: + Members '[MemberStore] r => + Local ConvId -> + Local UserId -> + Sem r Bool checkLocalMembership lcnv lusr = isMember (tUnqualified lusr) - <$> Data.members (tUnqualified lcnv) + <$> E.getLocalMembers (tUnqualified lcnv) + checkRemoteMembership :: + Members '[ConversationStore] r => + Remote ConvId -> + Local UserId -> + Sem r Bool checkRemoteMembership rcnv lusr = isJust . Map.lookup rcnv - <$> Data.remoteConversationStatus (tUnqualified lusr) [rcnv] + <$> E.getRemoteConversationStatus (tUnqualified lusr) [rcnv] updateData luid = MemberUpdateData { misTarget = qUntagged luid, @@ -817,7 +909,14 @@ updateSelfMember zusr zcon qcnv update = do } updateUnqualifiedSelfMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -828,7 +927,17 @@ updateUnqualifiedSelfMember zusr zcon cnv update = do updateSelfMember zusr zcon (qUntagged lcnv) update updateOtherMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -842,7 +951,18 @@ updateOtherMemberUnqualified zusr zcon cnv victim update = do updateOtherMemberLocalConv lcnv lusr zcon (qUntagged lvictim) update updateOtherMember :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -855,7 +975,17 @@ updateOtherMember zusr zcon qcnv qvictim update = do doUpdate qcnv lusr zcon qvictim update updateOtherMemberLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> ConnId -> @@ -863,22 +993,33 @@ updateOtherMemberLocalConv :: Public.OtherMemberUpdate -> Galley r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do - when (qUntagged lusr == qvictim) $ - throwM invalidTargetUserOp + lift . liftSem . when (qUntagged lusr == qvictim) $ + throw InvalidTargetUserOp updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionMemberUpdate qvictim update + ConversationMemberUpdate qvictim update updateOtherMemberRemoteConv :: + Member (Error FederationError) r => Remote ConvId -> Local UserId -> ConnId -> Qualified UserId -> Public.OtherMemberUpdate -> Galley r () -updateOtherMemberRemoteConv _ _ _ _ _ = throwM federationNotImplemented +updateOtherMemberRemoteConv _ _ _ _ _ = liftSem $ throw FederationNotImplemented removeMemberUnqualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> ConvId -> @@ -890,7 +1031,17 @@ removeMemberUnqualified zusr con cnv victim = do removeMemberQualified zusr con (qUntagged lcnv) (qUntagged lvictim) removeMemberQualified :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -901,16 +1052,16 @@ removeMemberQualified zusr con qcnv victim = do foldQualified lusr removeMemberFromLocalConv removeMemberFromRemoteConv qcnv lusr (Just con) victim removeMemberFromRemoteConv :: - Member FederatorAccess r => + Members '[FederatorAccess] r => Remote ConvId -> Local UserId -> Maybe ConnId -> Qualified UserId -> Galley r RemoveFromConversationResponse -removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim +removeMemberFromRemoteConv cnv lusr _ victim | qUntagged lusr == victim = do - let lc = FederatedGalley.LeaveConversationRequest (qUnqualified qcnv) (qUnqualified victim) + let lc = FederatedGalley.LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = FederatedGalley.leaveConversation FederatedGalley.clientRoutes @@ -918,27 +1069,26 @@ removeMemberFromRemoteConv (qUntagged -> qcnv) lusr _ victim lc t <- liftIO getCurrentTime let successEvent = - Event MemberLeave qcnv (qUntagged lusr) t $ + Event MemberLeave (qUntagged cnv) (qUntagged lusr) t $ EdMembersLeave (QualifiedUserIdList [victim]) - mapRight (const successEvent) . FederatedGalley.leaveResponse <$> runFederated (qDomain qcnv) rpc + liftSem $ + mapRight (const successEvent) . FederatedGalley.leaveResponse + <$> E.runFederated cnv rpc | otherwise = pure . Left $ RemoveFromConversationErrorRemovalNotAllowed -performRemoveMemberAction :: - Data.Conversation -> - [Qualified UserId] -> - MaybeT (Galley r) () -performRemoveMemberAction conv victims = do - loc <- qualifyLocal () - let presentVictims = filter (isConvMember loc conv) victims - guard . not . null $ presentVictims - - let (lvictims, rvictims) = partitionQualified loc presentVictims - traverse_ (lift . Data.removeLocalMembersFromLocalConv (Data.convId conv)) (nonEmpty lvictims) - traverse_ (lift . Data.removeRemoteMembersFromLocalConv (Data.convId conv)) (nonEmpty rvictims) - -- | Remove a member from a local conversation. removeMemberFromLocalConv :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore + ] + r => Local ConvId -> Local UserId -> Maybe ConnId -> @@ -949,7 +1099,7 @@ removeMemberFromLocalConv lcnv lusr con victim = fmap (maybe (Left RemoveFromConversationErrorUnchanged) Right) . runMaybeT . updateLocalConversation lcnv (qUntagged lusr) con - . ConversationActionRemoveMembers + . ConversationLeave . pure $ victim @@ -958,18 +1108,41 @@ removeMemberFromLocalConv lcnv lusr con victim = data OtrResult = OtrSent !Public.ClientMismatch | OtrMissingRecipients !Public.ClientMismatch - | OtrUnknownClient !Public.UnknownClient - | OtrConversationNotFound !Public.ConvNotFound - -handleOtrResult :: OtrResult -> Galley r Response -handleOtrResult = \case - OtrSent m -> pure $ json m & setStatus status201 - OtrMissingRecipients m -> pure $ json m & setStatus status412 - OtrUnknownClient _ -> throwErrorDescriptionType @UnknownClient - OtrConversationNotFound _ -> throwErrorDescriptionType @ConvNotFound + | OtrUnknownClient !UnknownClient + | OtrConversationNotFound !ConvNotFound + +handleOtrResult :: + Members + '[ Error ClientError, + Error ConversationError + ] + r => + OtrResult -> + Galley r Response +handleOtrResult = + liftSem . \case + OtrSent m -> pure $ json m & setStatus status201 + OtrMissingRecipients m -> pure $ json m & setStatus status412 + OtrUnknownClient _ -> throw UnknownClient + OtrConversationNotFound _ -> throw ConvNotFound postBotMessageH :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> Galley r Response postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do @@ -978,31 +1151,65 @@ postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do handleOtrResult =<< postBotMessage zbot zcnv val' message postBotMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + ExternalAccess, + FederatorAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => BotId -> ConvId -> Public.OtrFilterMissing -> Public.NewOtrMessage -> Galley r OtrResult -postBotMessage zbot zcnv val message = - postNewOtrMessage Bot (botUserId zbot) Nothing zcnv val message +postBotMessage zbot = postNewOtrMessage Bot (botUserId zbot) Nothing postProteusMessage :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> Qualified ConvId -> RawProto Public.QualifiedNewOtrMessage -> Galley r (Public.PostOtrResponse Public.MessageSendingStatus) postProteusMessage zusr zcon conv msg = do - localDomain <- viewFederationDomain - let sender = Qualified zusr localDomain - if localDomain /= qDomain conv - then postRemoteOtrMessage sender conv (rpRaw msg) - else postQualifiedOtrMessage User sender (Just zcon) (qUnqualified conv) (rpValue msg) + sender <- qualifyLocal zusr + foldQualified + sender + (\c -> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) (tUnqualified c) (rpValue msg)) + (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) + conv postOtrMessageUnqualified :: - Members '[BotAccess, BrigAccess, FederatorAccess, GundeckAccess, ExternalAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + FederatorAccess, + GundeckAccess, + ExternalAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> ConvId -> @@ -1037,7 +1244,20 @@ postOtrMessageUnqualified zusr zcon cnv ignoreMissing reportMissing message = do <$> postQualifiedOtrMessage User sender (Just zcon) cnv qualifiedMessage postProtoOtrBroadcastH :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> Galley r Response postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do @@ -1046,7 +1266,20 @@ postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcastH :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error ClientError, + Error ConversationError, + Error LegalHoldError, + Error InvalidInput, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> Galley r Response postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do @@ -1055,7 +1288,17 @@ postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do handleOtrResult =<< postOtrBroadcast zusr zcon val' message postOtrBroadcast :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> ConnId -> Public.OtrFilterMissing -> @@ -1075,7 +1318,17 @@ allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrep -- | bots are not supported on broadcast postNewOtrBroadcast :: - Members '[BrigAccess, GundeckAccess] r => + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + GundeckAccess, + TeamStore + ] + r => UserId -> Maybe ConnId -> OtrFilterMissing -> @@ -1089,10 +1342,21 @@ postNewOtrBroadcast usr con val msg = do now <- liftIO getCurrentTime withValidOtrBroadcastRecipients usr sender recvrs val now $ \rs -> do let (_, toUsers) = foldr (newMessage qusr con Nothing msg now) ([], []) rs - pushSome (catMaybes toUsers) + liftSem $ E.push (catMaybes toUsers) postNewOtrMessage :: - Members '[BotAccess, BrigAccess, ExternalAccess, GundeckAccess] r => + Members + '[ BotAccess, + BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> Maybe ConnId -> @@ -1107,10 +1371,10 @@ postNewOtrMessage utype usr con cnv val msg = do sender = newOtrSender msg recvrs = newOtrRecipients msg now <- liftIO getCurrentTime - withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> do + withValidOtrRecipients utype usr sender cnv recvrs val now $ \rs -> liftSem $ do let (toBots, toUsers) = foldr (newMessage qusr con (Just qcnv) msg now) ([], []) rs - pushSome (catMaybes toUsers) - External.deliverAndDeleteAsync cnv toBots + E.push (catMaybes toUsers) + E.deliverAndDeleteAsync cnv toBots newMessage :: Qualified UserId -> @@ -1148,7 +1412,17 @@ newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = in (toBots, p : toUsers) updateConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> Qualified ConvId -> @@ -1159,12 +1433,21 @@ updateConversationName zusr zcon qcnv convRename = do foldQualified lusr (updateLocalConversationName lusr zcon) - (\_ _ -> throwM federationNotImplemented) + (\_ _ -> liftSem (throw FederationNotImplemented)) qcnv convRename updateUnqualifiedConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => UserId -> ConnId -> ConvId -> @@ -1176,20 +1459,38 @@ updateUnqualifiedConversationName zusr zcon cnv rename = do updateLocalConversationName lusr zcon lcnv rename updateLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> Public.ConversationRename -> Galley r (Maybe Public.Event) updateLocalConversationName lusr zcon lcnv convRename = do - alive <- Data.isConvAlive (tUnqualified lcnv) + alive <- liftSem $ E.isConversationAlive (tUnqualified lcnv) if alive then updateLiveLocalConversationName lusr zcon lcnv convRename - else Nothing <$ Data.deleteConversation (tUnqualified lcnv) + else liftSem $ Nothing <$ E.deleteConversation (tUnqualified lcnv) updateLiveLocalConversationName :: - Members UpdateConversationActions r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + FederatorAccess, + GundeckAccess + ] + r => Local UserId -> ConnId -> Local ConvId -> @@ -1197,32 +1498,16 @@ updateLiveLocalConversationName :: Galley r (Maybe Public.Event) updateLiveLocalConversationName lusr con lcnv rename = runMaybeT $ - updateLocalConversation lcnv (qUntagged lusr) (Just con) $ - ConversationActionRename rename - -notifyConversationMetadataUpdate :: - Members '[FederatorAccess, ExternalAccess, GundeckAccess] r => - Qualified UserId -> - Maybe ConnId -> - Local ConvId -> - BotsAndMembers -> - ConversationAction -> - Galley r Event -notifyConversationMetadataUpdate quid con (qUntagged -> qcnv) targets action = do - localDomain <- viewFederationDomain - now <- liftIO getCurrentTime - let e = conversationActionToEvent now quid qcnv action - - -- notify remote participants - runFederatedConcurrently_ (toList (bmRemotes targets)) $ \ruids -> - FederatedGalley.onConversationUpdated FederatedGalley.clientRoutes localDomain $ - FederatedGalley.ConversationUpdate now quid (qUnqualified qcnv) (tUnqualified ruids) action - - -- notify local participants and bots - pushConversationEvent con e (bmLocals targets) (bmBots targets) $> e + updateLocalConversation lcnv (qUntagged lusr) (Just con) rename isTypingH :: - Member GundeckAccess r => + Members + '[ Error ConversationError, + Error InvalidInput, + GundeckAccess, + MemberStore + ] + r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> Galley r Response isTypingH (zusr ::: zcon ::: cnv ::: req) = do @@ -1231,7 +1516,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do pure empty isTyping :: - Member GundeckAccess r => + Members '[Error ConversationError, GundeckAccess, MemberStore] r => UserId -> ConnId -> ConvId -> @@ -1241,30 +1526,50 @@ isTyping zusr zcon cnv typingData = do localDomain <- viewFederationDomain let qcnv = Qualified cnv localDomain qusr = Qualified zusr localDomain - mm <- Data.members cnv - unless (zusr `isMember` mm) $ - throwErrorDescriptionType @ConvNotFound + mm <- liftSem $ E.getLocalMembers cnv + liftSem . unless (zusr `isMember` mm) . throw $ ConvNotFound now <- liftIO getCurrentTime let e = Event Typing qcnv qusr now (EdTyping typingData) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> mm)) $ \p -> - push1 $ + liftSem . E.push1 $ p & pushConn ?~ zcon & pushRoute .~ RouteDirect & pushTransient .~ True -addServiceH :: JsonRequest Service -> Galley r Response +addServiceH :: + Members + '[ Error InvalidInput, + ServiceStore + ] + r => + JsonRequest Service -> + Galley r Response addServiceH req = do - Data.insertService =<< fromJsonBody req + liftSem . E.createService =<< fromJsonBody req return empty -rmServiceH :: JsonRequest ServiceRef -> Galley r Response +rmServiceH :: + Members '[Error InvalidInput, ServiceStore] r => + JsonRequest ServiceRef -> + Galley r Response rmServiceH req = do - Data.deleteService =<< fromJsonBody req + liftSem . E.deleteService =<< fromJsonBody req return empty addBotH :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ ClientStore, + ConversationStore, + Error ActionError, + Error InvalidInput, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId ::: ConnId ::: JsonRequest AddBot -> Galley r Response addBotH (zusr ::: zcon ::: req) = do @@ -1272,42 +1577,80 @@ addBotH (zusr ::: zcon ::: req) = do json <$> addBot zusr zcon bot addBot :: - Members '[ExternalAccess, GundeckAccess] r => + forall r. + Members + '[ ClientStore, + ConversationStore, + Error ActionError, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + GundeckAccess, + MemberStore, + TeamStore + ] + r => UserId -> ConnId -> AddBot -> Galley r Event addBot zusr zcon b = do lusr <- qualifyLocal zusr - c <- Data.conversation (b ^. addBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + c <- + liftSem $ E.getConversation (b ^. addBotConv) >>= note ConvNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) (bots, users) <- regularConvChecks lusr c t <- liftIO getCurrentTime - Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) - (e, bm) <- Data.addBotMember (qUntagged lusr) (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t + liftSem $ E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) + bm <- liftSem $ E.createBotMember (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) + let e = + Event + MemberJoin + (qUntagged (qualifyAs lusr (b ^. addBotConv))) + (qUntagged lusr) + t + ( EdMembersJoin + ( SimpleMembers + [ SimpleMember + (qUntagged (qualifyAs lusr (botUserId (botMemId bm)))) + roleNameWireAdmin + ] + ) + ) for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - push1 $ p & pushConn ?~ zcon - External.deliverAsync ((bm : bots) `zip` repeat e) + liftSem . E.push1 $ p & pushConn ?~ zcon + liftSem $ E.deliverAsync ((bm : bots) `zip` repeat e) pure e where regularConvChecks lusr c = do let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) - unless (zusr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound - ensureGroupConvThrowing c - ensureActionAllowed AddConversationMember =<< getSelfMemberFromLocalsLegacy zusr users + liftSem . unless (zusr `isMember` users) . throw $ ConvNotFound + liftSem $ ensureGroupConversation c + self <- getSelfMemberFromLocals zusr users + ensureActionAllowed AddConversationMember self unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) + teamConvChecks :: ConvId -> TeamId -> Galley r () teamConvChecks cid tid = do - tcv <- Data.teamConversation tid cid - when (maybe True (view managedConversation) tcv) $ - throwM noAddToManaged + tcv <- liftSem $ E.getTeamConversation tid cid + liftSem $ + when (maybe True (view managedConversation) tcv) $ + throw NoAddToManaged rmBotH :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + Error InvalidInput, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley r Response rmBotH (zusr ::: zcon ::: req) = do @@ -1315,46 +1658,49 @@ rmBotH (zusr ::: zcon ::: req) = do handleUpdateResult <$> rmBot zusr zcon bot rmBot :: - Members '[ExternalAccess, GundeckAccess] r => + Members + '[ ClientStore, + ConversationStore, + Error ConversationError, + ExternalAccess, + GundeckAccess, + MemberStore + ] + r => UserId -> Maybe ConnId -> RemoveBot -> Galley r (UpdateResult Event) rmBot zusr zcon b = do - c <- Data.conversation (b ^. rmBotConv) >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) + c <- + liftSem $ E.getConversation (b ^. rmBotConv) >>= note ConvNotFound localDomain <- viewFederationDomain let qcnv = Qualified (Data.convId c) localDomain qusr = Qualified zusr localDomain - unless (zusr `isMember` Data.convLocalMembers c) $ - throwErrorDescriptionType @ConvNotFound + liftSem . unless (zusr `isMember` Data.convLocalMembers c) $ + throw ConvNotFound let (bots, users) = localBotsAndUsers (Data.convLocalMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) then pure Unchanged else do t <- liftIO getCurrentTime - let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) - let e = Event MemberLeave qcnv qusr t evd - for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> - push1 $ p & pushConn .~ zcon - Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) - Data.eraseClients (botUserId (b ^. rmBotId)) - External.deliverAsync (bots `zip` repeat e) - pure $ Updated e + liftSem $ do + let evd = EdMembersLeave (QualifiedUserIdList [Qualified (botUserId (b ^. rmBotId)) localDomain]) + let e = Event MemberLeave qcnv qusr t evd + for_ (newPushLocal ListComplete zusr (ConvEvent e) (recipient <$> users)) $ \p -> + E.push1 $ p & pushConn .~ zcon + E.deleteMembers (Data.convId c) (UserList [botUserId (b ^. rmBotId)] []) + E.deleteClients (botUserId (b ^. rmBotId)) + E.deliverAsync (bots `zip` repeat e) + pure $ Updated e ------------------------------------------------------------------------------- -- Helpers -ensureMemberLimit :: Foldable f => [LocalMember] -> f a -> Galley r () -ensureMemberLimit old new = do - o <- view options - let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) - when (length old + length new > maxSize) $ - throwM tooManyMembers - -ensureConvMember :: [LocalMember] -> UserId -> Galley r () +ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Galley r () ensureConvMember users usr = - unless (usr `isMember` users) $ - throwErrorDescriptionType @ConvNotFound + liftSem $ + unless (usr `isMember` users) $ throw ConvNotFound ------------------------------------------------------------------------------- -- OtrRecipients Validation @@ -1372,7 +1718,17 @@ data CheckedOtrRecipients -- | bots are not supported on broadcast withValidOtrBroadcastRecipients :: - Member BrigAccess r => + forall r. + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error LegalHoldError, + Error NotATeamMember, + Error TeamError, + TeamStore + ] + r => UserId -> ClientId -> OtrRecipients -> @@ -1383,8 +1739,8 @@ withValidOtrBroadcastRecipients :: withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do limit <- fromIntegral . fromRange <$> fanoutLimit -- If we are going to fan this out to more than limit, we want to fail early - unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ - throwM broadcastLimitExceeded + liftSem . unless (Map.size (userClientMap (otrRecipientsMap rcps)) <= limit) $ + throw BroadcastLimitExceeded -- In large teams, we may still use the broadcast endpoint but only if `report_missing` -- is used and length `report_missing` < limit since we cannot fetch larger teams than -- that. @@ -1392,14 +1748,15 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ fmap (view userId) <$> case val of OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us _ -> maybeFetchAllMembersInTeam tid - contacts <- getContactList usr + contacts <- liftSem $ E.getContactList usr let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then Clients.fromUserClients <$> Intra.lookupClients users - else Data.lookupClients users - let membs = Data.newMember <$> users + liftSem $ + if isInternal + then Clients.fromUserClients <$> E.lookupClients users + else E.getClients users + let membs = newMember <$> users handleOtrResponse User usr clt rcps membs clts val now go where maybeFetchLimitedTeamMemberList limit tid uListInFilter = do @@ -1407,17 +1764,26 @@ withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ let localUserIdsInFilter = toList uListInFilter let localUserIdsInRcps = Map.keys $ userClientMap (otrRecipientsMap rcps) let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) - unless (length localUserIdsToLookup <= limit) $ - throwM broadcastLimitExceeded - Data.teamMembersLimited tid localUserIdsToLookup + liftSem . unless (length localUserIdsToLookup <= limit) $ + throw BroadcastLimitExceeded + liftSem $ E.selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: TeamId -> Galley r [TeamMember] maybeFetchAllMembersInTeam tid = do - mems <- Data.teamMembersForFanout tid - when (mems ^. teamMemberListType == ListTruncated) $ - throwM broadcastLimitExceeded + mems <- getTeamMembersForFanout tid + liftSem . when (mems ^. teamMemberListType == ListTruncated) $ + throw BroadcastLimitExceeded pure (mems ^. teamMembers) withValidOtrRecipients :: - Member BrigAccess r => + Members + '[ BrigAccess, + ClientStore, + ConversationStore, + Error LegalHoldError, + MemberStore, + TeamStore + ] + r => UserType -> UserId -> ClientId -> @@ -1428,23 +1794,24 @@ withValidOtrRecipients :: ([(LocalMember, ClientId, Text)] -> Galley r ()) -> Galley r OtrResult withValidOtrRecipients utype usr clt cnv rcps val now go = do - alive <- Data.isConvAlive cnv + alive <- liftSem $ E.isConversationAlive cnv if not alive then do - Data.deleteConversation cnv + liftSem $ E.deleteConversation cnv pure $ OtrConversationNotFound mkErrorDescription else do - localMembers <- Data.members cnv + localMembers <- liftSem $ E.getLocalMembers cnv let localMemberIds = lmId <$> localMembers isInternal <- view $ options . optSettings . setIntraListing clts <- - if isInternal - then Clients.fromUserClients <$> Intra.lookupClients localMemberIds - else Data.lookupClients localMemberIds + liftSem $ + if isInternal + then Clients.fromUserClients <$> E.lookupClients localMemberIds + else E.getClients localMemberIds handleOtrResponse utype usr clt rcps localMembers clts val now go handleOtrResponse :: - Member BrigAccess r => + Members '[BrigAccess, Error LegalHoldError, TeamStore] r => -- | Type of proposed sender (user / bot) UserType -> -- | Proposed sender (user) @@ -1468,7 +1835,7 @@ handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipi ValidOtrRecipients m r -> go r >> pure (OtrSent m) MissingOtrRecipients m -> do guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - >>= either (const (throwErrorDescriptionType @MissingLegalholdConsent)) pure + >>= either (const (liftSem . throw $ MissingLegalholdConsent)) pure pure (OtrMissingRecipients m) InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription @@ -1556,10 +1923,18 @@ checkOtrRecipients usr sid prs vms vcs val now OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss -- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: UserId -> (TeamId -> Galley r b) -> Galley r b +withBindingTeam :: + Members + '[ Error TeamError, + TeamStore + ] + r => + UserId -> + (TeamId -> Galley r b) -> + Galley r b withBindingTeam zusr callback = do - tid <- Data.oneUserTeam zusr >>= ifNothing teamNotFound - binding <- Data.teamBinding tid >>= ifNothing teamNotFound + tid <- liftSem $ E.getOneUserTeam zusr >>= note TeamNotFound + binding <- liftSem $ E.getTeamBinding tid >>= note TeamNotFound case binding of Binding -> callback tid - NonBinding -> throwM nonBindingTeam + NonBinding -> liftSem $ throw NotABindingTeamMember diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bbcf15950d7..f76e4ff748b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. @@ -22,11 +23,8 @@ module Galley.API.Util where import Brig.Types (Relation (..)) import Brig.Types.Intra (ReAuthUser (..)) import Control.Arrow (Arrow (second), second) -import Control.Error (ExceptT, hoistEither, note) import Control.Lens (set, view, (.~), (^.)) -import Control.Monad.Catch -import Control.Monad.Except (runExceptT) -import Control.Monad.Extra (allM, anyM, eitherM) +import Control.Monad.Extra (allM, anyM) import Data.ByteString.Conversion import Data.Domain (Domain) import Data.Id as Id @@ -36,19 +34,24 @@ import qualified Data.Map as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified import qualified Data.Set as Set -import qualified Data.Text.Lazy as LT import Data.Time import Galley.API.Error import Galley.App -import qualified Galley.Data as Data -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) +import qualified Galley.Data.Conversation as Data import Galley.Data.Services (BotMember, newBotMember) import qualified Galley.Data.Types as DataTypes import Galley.Effects -import qualified Galley.External as External +import Galley.Effects.BrigAccess +import Galley.Effects.CodeStore +import Galley.Effects.ConversationStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess +import Galley.Effects.GundeckAccess +import Galley.Effects.LegalHoldStore +import Galley.Effects.MemberStore +import Galley.Effects.TeamStore import Galley.Intra.Push -import Galley.Intra.User -import Galley.Options (optSettings, setFeatureFlags, setFederationDomain) +import Galley.Options import Galley.Types import Galley.Types.Conversations.Members (localMemberToOther, remoteMemberToOther) import Galley.Types.Conversations.Roles @@ -58,30 +61,30 @@ import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error) -import Network.Wai.Utilities -import UnliftIO.Async (concurrently, pooledForConcurrentlyN) +import qualified Network.Wai.Utilities as Wai +import Polysemy +import Polysemy.Error import qualified Wire.API.Conversation as Public -import Wire.API.Conversation.Action (ConversationAction (..), conversationActionTag) import Wire.API.ErrorDescription -import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley as FederatedGalley -import Wire.API.Federation.Client (FederationClientFailure, FederatorClient, executeFederated) -import Wire.API.Federation.Error (federationErrorToWai, federationNotImplemented) -import Wire.API.Federation.GRPC.Types (Component (..)) -import qualified Wire.API.User as User +import Wire.API.Federation.Client type JSON = Media "application" "json" -ensureAccessRole :: Member BrigAccess r => AccessRole -> [(UserId, Maybe TeamMember)] -> Galley r () -ensureAccessRole role users = case role of - PrivateAccessRole -> throwErrorDescriptionType @ConvAccessDenied +ensureAccessRole :: + Members '[BrigAccess, Error NotATeamMember, Error ConversationError] r => + AccessRole -> + [(UserId, Maybe TeamMember)] -> + Galley r () +ensureAccessRole role users = liftSem $ case role of + PrivateAccessRole -> throw ConvAccessDenied TeamAccessRole -> when (any (isNothing . snd) users) $ - throwErrorDescriptionType @NotATeamMember + throwED @NotATeamMember ActivatedAccessRole -> do activated <- lookupActivatedUsers $ map fst users when (length activated /= length users) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied NonActivatedAccessRole -> return () -- | Check that the given user is either part of the same team(s) as the other @@ -89,174 +92,171 @@ ensureAccessRole role users = case role of -- -- Team members are always considered connected, so we only check 'ensureConnected' -- for non-team-members of the _given_ user -ensureConnectedOrSameTeam :: Member BrigAccess r => Qualified UserId -> [UserId] -> Galley r () +ensureConnectedOrSameTeam :: + Members '[BrigAccess, TeamStore, Error ActionError] r => + Local UserId -> + [UserId] -> + Galley r () ensureConnectedOrSameTeam _ [] = pure () -ensureConnectedOrSameTeam (Qualified u domain) uids = do - -- FUTUREWORK(federation, #1262): handle remote users (can't be part of the same team, just check connections) - localDomain <- viewFederationDomain - when (localDomain == domain) $ do - uTeams <- Data.userTeams u - -- We collect all the relevant uids from same teams as the origin user - sameTeamUids <- forM uTeams $ \team -> - fmap (view userId) <$> Data.teamMembersLimited team uids - -- Do not check connections for users that are on the same team - ensureConnectedToLocals u (uids \\ join sameTeamUids) +ensureConnectedOrSameTeam (tUnqualified -> u) uids = do + uTeams <- liftSem $ getUserTeams u + -- We collect all the relevant uids from same teams as the origin user + sameTeamUids <- liftSem . forM uTeams $ \team -> + fmap (view userId) <$> selectTeamMembers team uids + -- Do not check connections for users that are on the same team + ensureConnectedToLocals u (uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: Member BrigAccess r => Local UserId -> UserList UserId -> Galley r () +ensureConnected :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + UserList UserId -> + Galley r () ensureConnected self others = do ensureConnectedToLocals (tUnqualified self) (ulLocals others) ensureConnectedToRemotes self (ulRemotes others) -ensureConnectedToLocals :: Member BrigAccess r => UserId -> [UserId] -> Galley r () +ensureConnectedToLocals :: + Members '[BrigAccess, Error ActionError] r => + UserId -> + [UserId] -> + Galley r () ensureConnectedToLocals _ [] = pure () -ensureConnectedToLocals u uids = liftGalley0 $ do +ensureConnectedToLocals u uids = liftSem $ do (connsFrom, connsTo) <- - getConnectionsUnqualified0 [u] (Just uids) (Just Accepted) - `concurrently` getConnectionsUnqualified0 uids (Just [u]) (Just Accepted) + getConnectionsUnqualifiedBidi [u] uids (Just Accepted) (Just Accepted) unless (length connsFrom == length uids && length connsTo == length uids) $ - throwErrorDescriptionType @NotConnected + throw NotConnected -ensureConnectedToRemotes :: Member BrigAccess r => Local UserId -> [Remote UserId] -> Galley r () +ensureConnectedToRemotes :: + Members '[BrigAccess, Error ActionError] r => + Local UserId -> + [Remote UserId] -> + Galley r () ensureConnectedToRemotes _ [] = pure () -ensureConnectedToRemotes u remotes = do +ensureConnectedToRemotes u remotes = liftSem $ do acceptedConns <- getConnections [tUnqualified u] (Just $ map qUntagged remotes) (Just Accepted) when (length acceptedConns /= length remotes) $ - throwErrorDescriptionType @NotConnected - -ensureReAuthorised :: Member BrigAccess r => UserId -> Maybe PlainTextPassword -> Galley r () -ensureReAuthorised u secret = do - reAuthed <- reAuthUser u (ReAuthUser secret) + throw NotConnected + +ensureReAuthorised :: + Members + '[ BrigAccess, + Error AuthenticationError + ] + r => + UserId -> + Maybe PlainTextPassword -> + Galley r () +ensureReAuthorised u secret = liftSem $ do + reAuthed <- reauthUser u (ReAuthUser secret) unless reAuthed $ - throwM reAuthFailed + throw ReAuthFailed -- | Given a member in a conversation, check if the given action -- is permitted. If the user does not have the given permission, throw -- 'operationDenied'. -ensureActionAllowed :: IsConvMember mem => Action -> mem -> Galley r () -ensureActionAllowed action self = case isActionAllowed action (convMemberRole self) of +ensureActionAllowed :: + (IsConvMember mem, Members '[Error ActionError, Error InvalidInput] r) => + Action -> + mem -> + Galley r () +ensureActionAllowed action self = liftSem $ case isActionAllowed action (convMemberRole self) of Just True -> pure () - Just False -> throwErrorDescription (actionDenied action) + Just False -> throw (ActionDenied action) -- Actually, this will "never" happen due to the -- fact that there can be no custom roles at the moment - Nothing -> throwM (badRequest "Custom roles not supported") + Nothing -> throw CustomRolesNotSupported --- | Comprehensive permission check, taking action-specific logic into account. -ensureConversationActionAllowed :: - IsConvMember mem => - ConversationAction -> - Data.Conversation -> - mem -> - Galley r () -ensureConversationActionAllowed action conv self = do - loc <- qualifyLocal () - let tag = conversationActionTag (convMemberId loc self) action - -- general action check - ensureActionAllowed tag self - -- check if it is a group conversation (except for rename actions) - when (tag /= ModifyConversationName) $ - ensureGroupConvThrowing conv - -- extra action-specific checks - case action of - ConversationActionAddMembers _ role -> ensureConvRoleNotElevated self role - ConversationActionDelete -> do - case Data.convTeam conv of - Just tid -> do - foldQualified - loc - ( \lusr -> do - void $ - Data.teamMember tid (tUnqualified lusr) - >>= ifNothing (errorDescriptionTypeToWai @NotATeamMember) - ) - (\_ -> throwM federationNotImplemented) - (convMemberId loc self) - Nothing -> pure () - ConversationActionAccessUpdate target -> do - -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and - -- so on; users are not supposed to be able to make other conversations - -- have 'PrivateAccessRole' - when - ( PrivateAccess `elem` Public.cupAccess target - || PrivateAccessRole == Public.cupAccessRole target - ) - $ throwErrorDescriptionType @InvalidTargetAccess - -- Team conversations incur another round of checks - case Data.convTeam conv of - Just tid -> do - -- Access mode change for managed conversation is not allowed - tcv <- Data.teamConversation tid (Data.convId conv) - when (maybe False (view managedConversation) tcv) $ - throwM invalidManagedConvOp - -- Access mode change might result in members being removed from the - -- conversation, so the user must have the necessary permission flag - ensureActionAllowed RemoveConversationMember self - Nothing -> - when (Public.cupAccessRole target == TeamAccessRole) $ - throwErrorDescriptionType @InvalidTargetAccess - _ -> pure () - -ensureGroupConvThrowing :: Data.Conversation -> Galley r () -ensureGroupConvThrowing conv = case Data.convType conv of - SelfConv -> throwM invalidSelfOp - One2OneConv -> throwM invalidOne2OneOp - ConnectConv -> throwM invalidConnectOp - _ -> pure () +ensureGroupConversation :: Member (Error ActionError) r => Data.Conversation -> Sem r () +ensureGroupConversation conv = do + let ty = Data.convType conv + when (ty /= RegularConv) $ throw (InvalidOp ty) -- | Ensure that the set of actions provided are not "greater" than the user's -- own. This is used to ensure users cannot "elevate" allowed actions -- This function needs to be review when custom roles are introduced since only -- custom roles can cause `roleNameToActions` to return a Nothing -ensureConvRoleNotElevated :: IsConvMember mem => mem -> RoleName -> Galley r () -ensureConvRoleNotElevated origMember targetRole = do +ensureConvRoleNotElevated :: + (IsConvMember mem, Members '[Error InvalidInput, Error ActionError] r) => + mem -> + RoleName -> + Galley r () +ensureConvRoleNotElevated origMember targetRole = liftSem $ do case (roleNameToActions targetRole, roleNameToActions (convMemberRole origMember)) of (Just targetActions, Just memberActions) -> unless (Set.isSubsetOf targetActions memberActions) $ - throwM invalidActions + throw InvalidAction (_, _) -> - throwM (badRequest "Custom roles not supported") + throw CustomRolesNotSupported -- | If a team member is not given throw 'notATeamMember'; if the given team -- member does not have the given permission, throw 'operationDenied'. -- Otherwise, return the team member. -permissionCheck :: (IsPerm perm, Show perm) => perm -> Maybe TeamMember -> Galley r TeamMember -permissionCheck p = \case - Just m -> do - if m `hasPermission` p - then pure m - else throwErrorDescription (operationDenied p) - Nothing -> throwErrorDescriptionType @NotATeamMember - -assertTeamExists :: TeamId -> Galley r () -assertTeamExists tid = do - teamExists <- isJust <$> Data.team tid +permissionCheck :: + (IsPerm perm, Show perm, Members '[Error ActionError, Error NotATeamMember] r) => + perm -> + Maybe TeamMember -> + Galley r TeamMember +permissionCheck p = + liftSem . \case + Just m -> do + if m `hasPermission` p + then pure m + else throw (OperationDenied (show p)) + Nothing -> throwED @NotATeamMember + +assertTeamExists :: Members '[Error TeamError, TeamStore] r => TeamId -> Galley r () +assertTeamExists tid = liftSem $ do + teamExists <- isJust <$> getTeam tid if teamExists then pure () - else throwM teamNotFound + else throw TeamNotFound -assertOnTeam :: UserId -> TeamId -> Galley r () -assertOnTeam uid tid = do - Data.teamMember tid uid >>= \case - Nothing -> throwErrorDescriptionType @NotATeamMember - Just _ -> return () +assertOnTeam :: Members '[Error NotATeamMember, TeamStore] r => UserId -> TeamId -> Galley r () +assertOnTeam uid tid = + liftSem $ + getTeamMember tid uid >>= \case + Nothing -> throwED @NotATeamMember + Just _ -> return () -- | If the conversation is in a team, throw iff zusr is a team member and does not have named -- permission. If the conversation is not in a team, do nothing (no error). -permissionCheckTeamConv :: UserId -> ConvId -> Perm -> Galley r () +permissionCheckTeamConv :: + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + ConvId -> + Perm -> + Galley r () permissionCheckTeamConv zusr cnv perm = - Data.conversation cnv >>= \case + liftSem (getConversation cnv) >>= \case Just cnv' -> case Data.convTeam cnv' of - Just tid -> void $ permissionCheck perm =<< Data.teamMember tid zusr + Just tid -> void $ permissionCheck perm =<< liftSem (getTeamMember tid zusr) Nothing -> pure () - Nothing -> throwErrorDescriptionType @ConvNotFound + Nothing -> liftSem $ throw ConvNotFound -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: - Member GundeckAccess r => + Members + '[ ConversationStore, + Error ActionError, + Error ConversationError, + Error InternalError, + MemberStore, + GundeckAccess + ] + r => UserId -> Data.Conversation -> Maybe ConnId -> @@ -269,33 +269,29 @@ acceptOne2One usr conv conn = do if usr `isMember` mems then return conv else do - mm <- Data.addMember lcid lusr + mm <- liftSem $ createMember lcid lusr return $ conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | usr `isMember` mems -> promote - [_, _] -> throwErrorDescriptionType @ConvNotFound + [_, _] | usr `isMember` mems -> liftSem promote + [_, _] -> liftSem $ throw ConvNotFound _ -> do when (length mems > 2) $ - throwM badConvState + liftSem . throw . BadConvState $ cid now <- liftIO getCurrentTime - mm <- Data.addMember lcid lusr + mm <- liftSem $ createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] - conv' <- if isJust (find ((usr /=) . lmId) mems) then promote else pure conv + conv' <- if isJust (find ((usr /=) . lmId) mems) then liftSem promote else pure conv let mems' = mems <> toList mm for_ (newPushLocal ListComplete usr (ConvEvent e) (recipient <$> mems')) $ \p -> - push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect + liftSem $ push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect return $ conv' {Data.convLocalMembers = mems'} - _ -> throwM $ invalidOp "accept: invalid conversation type" + x -> liftSem . throw . InvalidOp $ x where cid = Data.convId conv mems = Data.convLocalMembers conv promote = do - Data.acceptConnect cid + acceptConnectConversation cid return $ conv {Data.convType = One2OneConv} - badConvState = - mkError status500 "bad-state" $ - "Connect conversation with more than 2 members: " - <> LT.pack (show cid) memberJoinEvent :: Local UserId -> @@ -436,7 +432,7 @@ localBotsAndUsers = foldMap botOrUser Nothing -> ([], [m]) location :: ToByteString a => a -> Response -> Response -location = addHeader hLocation . toByteString' +location = Wai.addHeader hLocation . toByteString' nonTeamMembers :: [LocalMember] -> [TeamMember] -> [LocalMember] nonTeamMembers cm tm = filter (not . isMemberOfTeam . lmId) cm @@ -455,84 +451,51 @@ membersToRecipients :: Maybe UserId -> [TeamMember] -> [Recipient] membersToRecipients Nothing = map (userRecipient . view userId) membersToRecipients (Just u) = map userRecipient . filter (/= u) . map (view userId) --- | Note that we use 2 nearly identical functions but slightly different --- semantics; when using `getSelfMemberFromLocals`, if that user is _not_ part --- of the conversation, we don't want to disclose that such a conversation with --- that id exists. getSelfMemberFromLocals :: - (Foldable t, Monad m) => - UserId -> - t LocalMember -> - ExceptT ConvNotFound m LocalMember -getSelfMemberFromLocals = getLocalMember (mkErrorDescription :: ConvNotFound) - --- | A legacy version of 'getSelfMemberFromLocals' that runs in the Galley r monad. -getSelfMemberFromLocalsLegacy :: - Foldable t => + (Foldable t, Member (Error ConversationError) r) => UserId -> t LocalMember -> Galley r LocalMember -getSelfMemberFromLocalsLegacy usr lmems = - eitherM throwErrorDescription pure . runExceptT $ getSelfMemberFromLocals usr lmems +getSelfMemberFromLocals usr lmems = + liftSem $ getMember lmId ConvNotFound usr lmems -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). ensureOtherMember :: + Member (Error ConversationError) r => Local a -> Qualified UserId -> Data.Conversation -> - Galley r (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) ensureOtherMember loc quid conv = - maybe (throwErrorDescriptionType @ConvMemberNotFound) pure $ - (Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv)) - <|> (Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv)) + note ConvMemberNotFound $ + Left <$> find ((== quid) . qUntagged . qualifyAs loc . lmId) (Data.convLocalMembers conv) + <|> Right <$> find ((== quid) . qUntagged . rmId) (Data.convRemoteMembers conv) getSelfMemberFromRemotes :: - (Foldable t, Monad m) => + (Foldable t, Member (Error ConversationError) r) => Remote UserId -> t RemoteMember -> - ExceptT ConvNotFound m RemoteMember -getSelfMemberFromRemotes = getRemoteMember (mkErrorDescription :: ConvNotFound) - -getSelfMemberFromRemotesLegacy :: Foldable t => Remote UserId -> t RemoteMember -> Galley r RemoteMember -getSelfMemberFromRemotesLegacy usr rmems = - eitherM throwErrorDescription pure . runExceptT $ - getSelfMemberFromRemotes usr rmems - --- | Since we search by local user ID, we know that the member must be local. -getLocalMember :: - (Foldable t, Monad m) => - e -> - UserId -> - t LocalMember -> - ExceptT e m LocalMember -getLocalMember = getMember lmId - --- | Since we search by remote user ID, we know that the member must be remote. -getRemoteMember :: - (Foldable t, Monad m) => - e -> - Remote UserId -> - t RemoteMember -> - ExceptT e m RemoteMember -getRemoteMember = getMember rmId + Galley r RemoteMember +getSelfMemberFromRemotes usr rmems = + liftSem $ getMember rmId ConvNotFound usr rmems getQualifiedMember :: - Monad m => + Member (Error e) r => Local x -> e -> Qualified UserId -> Data.Conversation -> - ExceptT e m (Either LocalMember RemoteMember) + Sem r (Either LocalMember RemoteMember) getQualifiedMember loc e qusr conv = foldQualified loc - (\lusr -> Left <$> getLocalMember e (tUnqualified lusr) (Data.convLocalMembers conv)) - (\rusr -> Right <$> getRemoteMember e rusr (Data.convRemoteMembers conv)) + (\lusr -> Left <$> getMember lmId e (tUnqualified lusr) (Data.convLocalMembers conv)) + (\rusr -> Right <$> getMember rmId e rusr (Data.convRemoteMembers conv)) qusr getMember :: - (Foldable t, Eq userId, Monad m) => + (Foldable t, Eq userId, Member (Error e) r) => -- | A projection from a member type to its user ID (mem -> userId) -> -- | An error to throw in case the user is not in the list @@ -541,36 +504,35 @@ getMember :: userId -> -- | A list of members to search t mem -> - ExceptT e m mem -getMember p ex u = hoistEither . note ex . find ((u ==) . p) + Sem r mem +getMember p ex u = note ex . find ((u ==) . p) getConversationAndCheckMembership :: + Members '[ConversationStore, Error ConversationError] r => UserId -> ConvId -> Galley r Data.Conversation getConversationAndCheckMembership uid cnv = do (conv, _) <- getConversationAndMemberWithError - (errorDescriptionTypeToWai @ConvAccessDenied) + ConvAccessDenied uid cnv pure conv getConversationAndMemberWithError :: - IsConvMemberId uid mem => - Error -> + (Members '[ConversationStore, Error ConversationError] r, IsConvMemberId uid mem) => + ConversationError -> uid -> ConvId -> Galley r (Data.Conversation, mem) getConversationAndMemberWithError ex usr convId = do - c <- Data.conversation convId >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - when (DataTypes.isConvDeleted c) $ do - Data.deleteConversation convId - throwErrorDescriptionType @ConvNotFound + c <- liftSem $ getConversation convId >>= note ConvNotFound + liftSem . when (DataTypes.isConvDeleted c) $ do + deleteConversation convId + throw ConvNotFound loc <- qualifyLocal () - member <- - either throwM pure . note ex $ - getConvMember loc c usr + member <- liftSem . note ex $ getConvMember loc c usr pure (c, member) -- | Deletion requires a permission check, but also a 'Role' comparison: @@ -601,30 +563,59 @@ pushConversationEvent :: pushConversationEvent conn e users bots = do localDomain <- viewFederationDomain for_ (newConversationEventPush localDomain e (toList users)) $ \p -> - push1 $ p & set pushConn conn - External.deliverAsync (toList bots `zip` repeat e) + liftSem $ push1 $ p & set pushConn conn + liftSem $ deliverAsync (toList bots `zip` repeat e) -verifyReusableCode :: ConversationCode -> Galley r DataTypes.Code +verifyReusableCode :: + Members '[CodeStore, Error CodeError] r => + ConversationCode -> + Galley r DataTypes.Code verifyReusableCode convCode = do c <- - Data.lookupCode (conversationKey convCode) DataTypes.ReusableCode - >>= ifNothing (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ + getCode (conversationKey convCode) DataTypes.ReusableCode + >>= note CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ - throwM (errorDescriptionTypeToWai @CodeNotFound) + liftSem $ throw CodeNotFound return c -ensureConversationAccess :: Member BrigAccess r => UserId -> ConvId -> Access -> Galley r Data.Conversation +ensureConversationAccess :: + Members + '[ BrigAccess, + ConversationStore, + Error ActionError, + Error ConversationError, + Error FederationError, + Error NotATeamMember, + TeamStore + ] + r => + UserId -> + ConvId -> + Access -> + Galley r Data.Conversation ensureConversationAccess zusr cnv access = do - conv <- Data.conversation cnv >>= ifNothing (errorDescriptionTypeToWai @ConvNotFound) - ensureAccess conv access - zusrMembership <- maybe (pure Nothing) (`Data.teamMember` zusr) (Data.convTeam conv) + conv <- + liftSem $ + getConversation cnv >>= note ConvNotFound + liftSem $ ensureAccess conv access + zusrMembership <- + liftSem $ + maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRole conv) [(zusr, zusrMembership)] pure conv -ensureAccess :: Data.Conversation -> Access -> Galley r () +ensureAccess :: + Member (Error ConversationError) r => + Data.Conversation -> + Access -> + Sem r () ensureAccess conv access = unless (access `elem` Data.convAccess conv) $ - throwErrorDescriptionType @ConvAccessDenied + throw ConvAccessDenied + +ensureLocal :: Member (Error FederationError) r => Local x -> Qualified a -> Sem r (Local a) +ensureLocal loc = foldQualified loc pure (\_ -> throw FederationNotImplemented) -------------------------------------------------------------------------------- -- Federation @@ -635,76 +626,6 @@ viewFederationDomain = view (options . optSettings . setFederationDomain) qualifyLocal :: MonadReader Env m => a -> m (Local a) qualifyLocal a = toLocalUnsafe <$> viewFederationDomain <*> pure a -checkRemoteUsersExist :: - (Member FederatorAccess r, Functor f, Foldable f) => - f (Remote UserId) -> - Galley r () -checkRemoteUsersExist = - -- FUTUREWORK: pooledForConcurrentlyN_ instead of sequential checks per domain - traverse_ checkRemotesFor . bucketRemote - -checkRemotesFor :: Member FederatorAccess r => Remote [UserId] -> Galley r () -checkRemotesFor (qUntagged -> Qualified uids domain) = do - let rpc = FederatedBrig.getUsersByIds FederatedBrig.clientRoutes uids - users <- runFederatedBrig domain rpc - let uids' = - map - (qUnqualified . User.profileQualifiedId) - (filter (not . User.profileDeleted) users) - unless (Set.fromList uids == Set.fromList uids') $ - throwM unknownRemoteUser - -type FederatedGalleyRPC c a = FederatorClient c (ExceptT FederationClientFailure Galley0) a - -runFederated0 :: - forall (c :: Component) a. - Domain -> - FederatedGalleyRPC c a -> - Galley0 a -runFederated0 remoteDomain rpc = do - runExceptT (executeFederated remoteDomain rpc) - >>= either (throwM . federationErrorToWai) pure - -runFederatedGalley :: - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC 'Galley a -> - Galley r a -runFederatedGalley = runFederated - -runFederatedBrig :: - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC 'Brig a -> - Galley r a -runFederatedBrig = runFederated - -runFederated :: - forall (c :: Component) r a. - Member FederatorAccess r => - Domain -> - FederatedGalleyRPC c a -> - Galley r a -runFederated remoteDomain = liftGalley0 . runFederated0 remoteDomain - -runFederatedConcurrently :: - Member FederatorAccess r => - (Foldable f, Functor f) => - f (Remote a) -> - (Remote [a] -> FederatedGalleyRPC c b) -> - Galley r [Remote b] -runFederatedConcurrently xs rpc = liftGalley0 $ - pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> - qualifyAs r <$> runFederated0 (tDomain r) (rpc r) - -runFederatedConcurrently_ :: - Member FederatorAccess r => - (Foldable f, Functor f) => - f (Remote a) -> - (Remote [a] -> FederatedGalleyRPC c ()) -> - Galley r () -runFederatedConcurrently_ xs = void . runFederatedConcurrently xs - -- | Convert an internal conversation representation 'Data.Conversation' to -- 'NewRemoteConversation' to be sent over the wire to a remote backend that will -- reconstruct this into multiple public-facing @@ -814,7 +735,7 @@ registerRemoteConversationMemberships :: Domain -> Data.Conversation -> Galley r () -registerRemoteConversationMemberships now localDomain c = do +registerRemoteConversationMemberships now localDomain c = liftSem $ do let allRemoteMembers = nubOrd (map rmId (Data.convRemoteMembers c)) rc = toNewRemoteConversation now localDomain c runFederatedConcurrently_ allRemoteMembers $ \_ -> @@ -840,21 +761,29 @@ consentGiven = \case UserLegalHoldEnabled -> ConsentGiven UserLegalHoldNoConsent -> ConsentNotGiven -checkConsent :: Map UserId TeamId -> UserId -> Galley r ConsentGiven +checkConsent :: + Member TeamStore r => + Map UserId TeamId -> + UserId -> + Galley r ConsentGiven checkConsent teamsOfUsers other = do consentGiven <$> getLHStatus (Map.lookup other teamsOfUsers) other -- Get legalhold status of user. Defaults to 'defUserLegalHoldStatus' if user -- doesn't belong to a team. -getLHStatus :: Maybe TeamId -> UserId -> Galley r UserLegalHoldStatus +getLHStatus :: + Member TeamStore r => + Maybe TeamId -> + UserId -> + Galley r UserLegalHoldStatus getLHStatus teamOfUser other = do case teamOfUser of Nothing -> pure defUserLegalHoldStatus Just team -> do - mMember <- Data.teamMember team other + mMember <- liftSem $ getTeamMember team other pure $ maybe defUserLegalHoldStatus (view legalHoldStatus) mMember -anyLegalholdActivated :: [UserId] -> Galley r Bool +anyLegalholdActivated :: Member TeamStore r => [UserId] -> Galley r Bool anyLegalholdActivated uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False @@ -863,31 +792,49 @@ anyLegalholdActivated uids = do where check = do flip anyM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- Data.usersTeams uidsPage + teamsOfUsers <- liftSem $ getUsersTeams uidsPage anyM (\uid -> userLHEnabled <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage -allLegalholdConsentGiven :: [UserId] -> Galley r Bool +allLegalholdConsentGiven :: + Members '[LegalHoldStore, TeamStore] r => + [UserId] -> + Galley r Bool allLegalholdConsentGiven uids = do view (options . optSettings . setFeatureFlags . flagLegalHold) >>= \case FeatureLegalHoldDisabledPermanently -> pure False FeatureLegalHoldDisabledByDefault -> do flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsOfUsers <- Data.usersTeams uidsPage + teamsOfUsers <- liftSem $ getUsersTeams uidsPage allM (\uid -> (== ConsentGiven) . consentGiven <$> getLHStatus (Map.lookup uid teamsOfUsers) uid) uidsPage FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do -- For this feature the implementation is more efficient. Being part of -- a whitelisted team is equivalent to have given consent to be in a -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsPage <- nub . Map.elems <$> Data.usersTeams uidsPage - allM isTeamLegalholdWhitelisted teamsPage + teamsPage <- liftSem $ nub . Map.elems <$> getUsersTeams uidsPage + allM (liftSem . isTeamLegalholdWhitelisted) teamsPage -- | Add to every uid the legalhold status -getLHStatusForUsers :: [UserId] -> Galley r [(UserId, UserLegalHoldStatus)] +getLHStatusForUsers :: + Member TeamStore r => + [UserId] -> + Galley r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- Data.usersTeams uidsChunk + teamsOfUsers <- liftSem $ getUsersTeams uidsChunk for uidsChunk $ \uid -> do (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid ) + +getTeamMembersForFanout :: Member TeamStore r => TeamId -> Galley r TeamMemberList +getTeamMembersForFanout tid = do + lim <- fanoutLimit + liftSem $ getTeamMembersWithLimit tid lim + +ensureMemberLimit :: (Foldable f, Member (Error ConversationError) r) => [LocalMember] -> f a -> Galley r () +ensureMemberLimit old new = do + o <- view options + let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) + liftSem . when (length old + length new > maxSize) $ + throw TooManyMembers diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 10ba4724994..3053713219c 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -47,19 +46,18 @@ module Galley.App toServantHandler, -- * Utilities - ifNothing, fromJsonBody, fromOptionalJsonBody, fromProtoBody, - initExtEnv, fanoutLimit, currentFanoutLimit, - -- * MonadUnliftIO / Sem compatibility + -- * Temporary compatibility functions fireAndForget, spawnMany, liftGalley0, liftSem, + unGalley, interpretGalleyToGalley0, ) where @@ -77,10 +75,8 @@ import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.ByteString.Conversion (toByteString') import Data.Default (def) -import Data.Id (ConnId, TeamId, UserId) import qualified Data.List.NonEmpty as NE import Data.Metrics.Middleware -import Data.Misc (Fingerprint, Rsa) import qualified Data.ProtocolBuffers as Proto import Data.Proxy (Proxy (..)) import Data.Range @@ -90,8 +86,25 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Galley.API.Error import qualified Galley.Aws as Aws +import Galley.Cassandra.Client +import Galley.Cassandra.Code +import Galley.Cassandra.Conversation +import Galley.Cassandra.Conversation.Members +import Galley.Cassandra.ConversationList +import Galley.Cassandra.CustomBackend +import Galley.Cassandra.LegalHold +import Galley.Cassandra.SearchVisibility +import Galley.Cassandra.Services +import Galley.Cassandra.Team +import Galley.Cassandra.TeamFeatures +import Galley.Cassandra.TeamNotifications import Galley.Effects +import Galley.Effects.FireAndForget (interpretFireAndForget) import qualified Galley.Effects.FireAndForget as E +import Galley.Env +import Galley.External +import Galley.Intra.Effects +import Galley.Intra.Federator import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types.Teams as Teams @@ -103,53 +116,26 @@ import Network.HTTP.Types (hContentType) import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Wai import Network.Wai.Utilities hiding (Error) -import qualified Network.Wai.Utilities as WaiError +import qualified Network.Wai.Utilities as Wai import qualified Network.Wai.Utilities.Server as Server -import OpenSSL.EVP.Digest (getDigestByName) import OpenSSL.Session as Ssl import qualified OpenSSL.X509.SystemStore as Ssl import Polysemy +import Polysemy.Error import Polysemy.Internal (Append) import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P import qualified Servant import Ssl.Util -import System.Logger.Class hiding (Error, info) +import System.Logger.Class import qualified System.Logger.Extended as Logger import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Federation.Client (HasFederatorConfig (..)) -data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) - deriving (Eq, Ord, Show) - --- | Main application environment. -data Env = Env - { _reqId :: RequestId, - _monitor :: Metrics, - _options :: Opts, - _applog :: Logger, - _manager :: Manager, - _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? - _brig :: Endpoint, -- FUTUREWORK: see _federator - _cstate :: ClientState, - _deleteQueue :: Q.Queue DeleteItem, - _extEnv :: ExtEnv, - _aEnv :: Maybe Aws.Env - } - --- | Environment specific to the communication with external --- service providers. -data ExtEnv = ExtEnv - { _extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ()) - } - -makeLenses ''Env - -makeLenses ''ExtEnv - -- MTL-style effects derived from the old implementation of the Galley monad. -- They will disappear as we introduce more high-level effects into Galley. -type GalleyEffects0 = '[P.Reader ClientState, P.Reader Env, Embed IO, Final IO] +type GalleyEffects0 = '[P.TinyLog, P.Reader ClientState, P.Reader Env, Embed IO, Final IO] type GalleyEffects = Append GalleyEffects1 GalleyEffects0 @@ -171,19 +157,10 @@ instance Monad (Galley r) where instance MonadIO (Galley r) where liftIO action = Galley (liftIO action) -instance MonadThrow (Galley r) where - throwM e = Galley (embed @IO (throwM e)) - instance MonadReader Env (Galley r) where ask = Galley $ P.ask @Env local f m = Galley $ P.local f (unGalley m) -instance MonadClient (Galley r) where - liftClient m = Galley $ do - cs <- P.ask @ClientState - embed @IO $ runClient cs m - localState f m = Galley $ P.local f (unGalley m) - instance HasFederatorConfig (Galley r) where federatorEndpoint = view federator federationDomain = view (options . optSettings . setFederationDomain) @@ -191,14 +168,8 @@ instance HasFederatorConfig (Galley r) where fanoutLimit :: Galley r (Range 1 Teams.HardTruncationLimit Int32) fanoutLimit = view options >>= return . currentFanoutLimit -currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 -currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) - let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) - unsafeRange (min maxTeamSize optFanoutLimit) - -- Define some invariants for the options used -validateOptions :: Logger.Logger -> Opts -> IO () +validateOptions :: Logger -> Opts -> IO () validateOptions l o = do let settings = view optSettings o optFanoutLimit = fromIntegral . fromRange $ currentFanoutLimit o @@ -221,9 +192,7 @@ validateOptions l o = do error "setMaxTeamSize cannot be < setTruncationLimit" instance MonadLogger (Galley r) where - log l m = do - e <- ask - Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) + log l m = Galley $ P.polylog l m instance MonadHttp (Galley r) where handleRequestWithCont req handler = do @@ -262,6 +231,7 @@ initCassandra o l = do . C.setSendTimeout 3 . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 + . C.setPolicy (C.dcFilterPolicyIfConfigured l (o ^. optCassandra . casFilterNodesByDatacentre)) $ C.defSettings initHttpManager :: Opts -> IO Manager @@ -280,29 +250,6 @@ initHttpManager o = do managerIdleConnectionCount = 3 * (o ^. optSettings . setHttpPoolSize) } --- TODO: somewhat duplicates Brig.App.initExtGetManager -initExtEnv :: IO ExtEnv -initExtEnv = do - ctx <- Ssl.context - Ssl.contextSetVerificationMode ctx Ssl.VerifyNone - Ssl.contextAddOption ctx SSL_OP_NO_SSLv2 - Ssl.contextAddOption ctx SSL_OP_NO_SSLv3 - Ssl.contextAddOption ctx SSL_OP_NO_TLSv1 - Ssl.contextSetCiphers ctx rsaCiphers - Ssl.contextLoadSystemCerts ctx - mgr <- - newManager - (opensslManagerSettings (pure ctx)) - { managerResponseTimeout = responseTimeoutMicro 10000000, - managerConnCount = 100 - } - Just sha <- getDigestByName "SHA256" - return $ ExtEnv (mgr, mkVerify sha) - where - mkVerify sha fprs = - let pinset = map toByteString' fprs - in verifyRsaFingerprint sha pinset - runGalley :: Env -> Request -> Galley GalleyEffects a -> IO a runGalley e r m = let e' = reqId .~ lookupReqId r $ e @@ -314,6 +261,15 @@ evalGalley0 e = . embedToFinal @IO . P.runReader e . P.runReader (e ^. cstate) + . interpretTinyLog e + +interpretTinyLog :: + Members '[Embed IO] r => + Env -> + Sem (P.TinyLog ': r) a -> + Sem r a +interpretTinyLog e = interpret $ \case + P.Polylog l m -> Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) evalGalley :: Env -> Galley GalleyEffects a -> IO a evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 @@ -321,28 +277,25 @@ evalGalley e = evalGalley0 e . unGalley . interpretGalleyToGalley0 lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders -reqIdMsg :: RequestId -> Msg -> Msg -reqIdMsg = ("request" .=) . unRequestId -{-# INLINE reqIdMsg #-} - -fromJsonBody :: FromJSON a => JsonRequest a -> Galley r a -fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) +fromJsonBody :: (Member (Error InvalidInput) r, FromJSON a) => JsonRequest a -> Galley r a +fromJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} -fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley r (Maybe a) -fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) +fromOptionalJsonBody :: + ( Member (Error InvalidInput) r, + FromJSON a + ) => + OptionalJsonRequest a -> + Galley r (Maybe a) +fromOptionalJsonBody r = exceptT (liftSem . throw . InvalidPayload) return (parseOptionalBody r) {-# INLINE fromOptionalJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> Galley r a +fromProtoBody :: (Member (Error InvalidInput) r, Proto.Decode a) => Request -> Galley r a fromProtoBody r = do b <- readBody r - either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (liftSem . throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} -ifNothing :: WaiError.Error -> Maybe a -> Galley r a -ifNothing e = maybe (throwM e) return -{-# INLINE ifNothing #-} - toServantHandler :: Env -> Galley GalleyEffects a -> Servant.Handler a toServantHandler env galley = do eith <- liftIO $ Control.Exception.try (evalGalley env galley) @@ -351,14 +304,60 @@ toServantHandler env galley = do handleWaiErrors (view applog env) (unRequestId (view reqId env)) werr Right result -> pure result where - handleWaiErrors :: Logger -> ByteString -> WaiError.Error -> Servant.Handler a + handleWaiErrors :: Logger -> ByteString -> Wai.Error -> Servant.Handler a handleWaiErrors logger reqId' werr = do Server.logError' logger (Just reqId') werr Servant.throwError $ Servant.ServerError (mkCode werr) (mkPhrase werr) (Aeson.encode werr) [(hContentType, renderHeader (Servant.contentType (Proxy @Servant.JSON)))] - mkCode = statusCode . WaiError.code - mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . WaiError.code + mkCode = statusCode . Wai.code + mkPhrase = Text.unpack . Text.decodeUtf8 . statusMessage . Wai.code + +withLH :: + Member (P.Reader Env) r => + (Teams.FeatureLegalHold -> Sem (eff ': r) a -> Sem r a) -> + Sem (eff ': r) a -> + Sem r a +withLH f action = do + lh <- P.asks (view (options . optSettings . setFeatureFlags . Teams.flagLegalHold)) + f lh action + +interpretErrorToException :: + (Exception e, Member (Embed IO) r) => + Sem (Error e ': r) a -> + Sem r a +interpretErrorToException = (either (embed @IO . UnliftIO.throwIO) pure =<<) . runError + +interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a +interpretGalleyToGalley0 = + Galley + . interpretErrorToException + . mapAllErrors + . interpretInternalTeamListToCassandra + . interpretTeamListToCassandra + . interpretLegacyConversationListToCassandra + . interpretRemoteConversationListToCassandra + . interpretConversationListToCassandra + . withLH interpretTeamMemberStoreToCassandra + . withLH interpretTeamStoreToCassandra + . interpretTeamNotificationStoreToCassandra + . interpretTeamFeatureStoreToCassandra + . interpretServiceStoreToCassandra + . interpretSearchVisibilityStoreToCassandra + . interpretMemberStoreToCassandra + . withLH interpretLegalHoldStoreToCassandra + . interpretCustomBackendStoreToCassandra + . interpretConversationStoreToCassandra + . interpretCodeStoreToCassandra + . interpretClientStoreToCassandra + . interpretFireAndForget + . interpretBotAccess + . interpretFederatorAccess + . interpretExternalAccess + . interpretSparAccess + . interpretGundeckAccess + . interpretBrigAccess + . unGalley ---------------------------------------------------------------------------------- ---- temporary MonadUnliftIO support code for the polysemy refactoring @@ -385,6 +384,9 @@ instance MonadMask Galley0 where (\resource exitCase -> evalGalley0 env (unGalley (release resource exitCase))) (\resource -> evalGalley0 env (unGalley (useB resource))) +instance MonadThrow Galley0 where + throwM e = Galley (embed @IO (throwM e)) + instance MonadCatch Galley0 where catch = UnliftIO.catch @@ -393,16 +395,3 @@ liftGalley0 (Galley m) = Galley $ subsume_ m liftSem :: Sem r a -> Galley r a liftSem m = Galley m - -interpretGalleyToGalley0 :: Galley GalleyEffects a -> Galley0 a -interpretGalleyToGalley0 = - Galley - . interpretFireAndForget - . interpretIntra - . interpretBot - . interpretFederator - . interpretExternal - . interpretSpar - . interpretGundeck - . interpretBrig - . unGalley diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs new file mode 100644 index 00000000000..a32e4fdce1a --- /dev/null +++ b/services/galley/src/Galley/Cassandra.hs @@ -0,0 +1,23 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra (schemaVersion) where + +import Imports + +schemaVersion :: Int32 +schemaVersion = 54 diff --git a/services/galley/src/Galley/Cassandra/Access.hs b/services/galley/src/Galley/Cassandra/Access.hs new file mode 100644 index 00000000000..a2c4fb176b7 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Access.hs @@ -0,0 +1,37 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Access where + +import Cassandra +import Galley.Data.Conversation +import Imports hiding (Set) +import Wire.API.Conversation hiding (Conversation) + +defAccess :: ConvType -> Maybe (Set Access) -> [Access] +defAccess SelfConv Nothing = [PrivateAccess] +defAccess ConnectConv Nothing = [PrivateAccess] +defAccess One2OneConv Nothing = [PrivateAccess] +defAccess RegularConv Nothing = defRegularConvAccess +defAccess SelfConv (Just (Set [])) = [PrivateAccess] +defAccess ConnectConv (Just (Set [])) = [PrivateAccess] +defAccess One2OneConv (Just (Set [])) = [PrivateAccess] +defAccess RegularConv (Just (Set [])) = defRegularConvAccess +defAccess _ (Just (Set (x : xs))) = x : xs + +privateOnly :: Set Access +privateOnly = Set [PrivateAccess] diff --git a/services/galley/src/Galley/Cassandra/Client.hs b/services/galley/src/Galley/Cassandra/Client.hs new file mode 100644 index 00000000000..ee0f4e3bda2 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Client.hs @@ -0,0 +1,64 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Client + ( interpretClientStoreToCassandra, + lookupClients, + ) +where + +import Cassandra +import Control.Arrow +import Data.Id +import Data.List.Split (chunksOf) +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store +import Galley.Effects.ClientStore (ClientStore (..)) +import Galley.Types.Clients (Clients) +import qualified Galley.Types.Clients as Clients +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO + +updateClient :: Bool -> UserId -> ClientId -> Client () +updateClient add usr cls = do + let q = if add then Cql.addMemberClient else Cql.rmMemberClient + retry x5 $ write (q cls) (params LocalQuorum (Identity usr)) + +-- Do, at most, 16 parallel lookups of up to 128 users each +lookupClients :: [UserId] -> Client Clients +lookupClients users = + Clients.fromList . concat . concat + <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) + where + getClients us = + map (second fromSet) + <$> retry x1 (query Cql.selectClients (params LocalQuorum (Identity us))) + +eraseClients :: UserId -> Client () +eraseClients user = retry x5 (write Cql.rmClients (params LocalQuorum (Identity user))) + +interpretClientStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ClientStore ': r) a -> + Sem r a +interpretClientStoreToCassandra = interpret $ \case + GetClients uids -> embedClient $ lookupClients uids + CreateClient uid cid -> embedClient $ updateClient True uid cid + DeleteClient uid cid -> embedClient $ updateClient False uid cid + DeleteClients uid -> embedClient $ eraseClients uid diff --git a/services/galley/src/Galley/Cassandra/Code.hs b/services/galley/src/Galley/Cassandra/Code.hs new file mode 100644 index 00000000000..539c2aaa4ec --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Code.hs @@ -0,0 +1,61 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Code + ( interpretCodeStoreToCassandra, + ) +where + +import Brig.Types.Code +import Cassandra +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store +import Galley.Data.Types +import qualified Galley.Data.Types as Code +import Galley.Effects.CodeStore (CodeStore (..)) +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretCodeStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (CodeStore ': r) a -> + Sem r a +interpretCodeStoreToCassandra = interpret $ \case + GetCode k s -> embedClient $ lookupCode k s + CreateCode code -> embedClient $ insertCode code + DeleteCode k s -> embedClient $ deleteCode k s + MakeKey cid -> Code.mkKey cid + GenerateCode cid s t -> Code.generate cid s t + +-- | Insert a conversation code +insertCode :: Code -> Client () +insertCode c = do + let k = codeKey c + let v = codeValue c + let cnv = codeConversation c + let t = round (codeTTL c) + let s = codeScope c + retry x5 (write Cql.insertCode (params LocalQuorum (k, v, cnv, s, t))) + +-- | Lookup a conversation by code. +lookupCode :: Key -> Scope -> Client (Maybe Code) +lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params LocalQuorum (k, s))) + +-- | Delete a code associated with the given conversation key +deleteCode :: Key -> Scope -> Client () +deleteCode k s = retry x5 $ write Cql.deleteCode (params LocalQuorum (k, s)) diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs new file mode 100644 index 00000000000..04822d1850c --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -0,0 +1,374 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Conversation + ( createConversation, + deleteConversation, + interpretConversationStoreToCassandra, + ) +where + +import Cassandra hiding (Set) +import qualified Cassandra as Cql +import Data.ByteString.Conversion +import Data.Id +import qualified Data.Map as Map +import Data.Misc +import Data.Qualified +import Data.Range +import qualified Data.UUID.Tagged as U +import Data.UUID.V4 (nextRandom) +import Galley.Cassandra.Access +import Galley.Cassandra.Conversation.Members +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store +import Galley.Data.Conversation +import Galley.Data.Conversation.Types +import Galley.Effects.ConversationStore (ConversationStore (..)) +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import Polysemy.TinyLog +import qualified System.Logger as Log +import qualified UnliftIO +import Wire.API.Conversation hiding (Conversation, Member) +import Wire.API.Conversation.Role (roleNameWireAdmin) + +createConversation :: NewConversation -> Client Conversation +createConversation (NewConversation ty usr acc arole name mtid mtimer recpt users role) = do + conv <- Id <$> liftIO nextRandom + retry x5 $ case mtid of + Nothing -> + write Cql.insertConv (params LocalQuorum (conv, ty, usr, Cql.Set (toList acc), arole, fmap fromRange name, Nothing, mtimer, recpt)) + Just tid -> batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery Cql.insertConv (conv, ty, usr, Cql.Set (toList acc), arole, fmap fromRange name, Just tid, mtimer, recpt) + addPrepQuery Cql.insertTeamConv (tid, conv, False) + let newUsers = fmap (,role) (fromConvSize users) + (lmems, rmems) <- addMembers conv (ulAddLocal (usr, roleNameWireAdmin) newUsers) + pure $ + Conversation + { convId = conv, + convType = ty, + convCreator = usr, + convName = fmap fromRange name, + convAccess = acc, + convAccessRole = arole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = mtid, + convDeleted = Nothing, + convMessageTimer = mtimer, + convReceiptMode = recpt + } + +createConnectConversation :: + U.UUID U.V4 -> + U.UUID U.V4 -> + Maybe (Range 1 256 Text) -> + Client Conversation +createConnectConversation a b name = do + let conv = localOne2OneConvId a b + a' = Id . U.unpack $ a + retry x5 $ + write Cql.insertConv (params LocalQuorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + (lmems, rmems) <- addMembers conv (UserList [a'] []) + pure + Conversation + { convId = conv, + convType = ConnectConv, + convCreator = a', + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createConnectConversationWithRemote :: + ConvId -> + UserId -> + UserList UserId -> + Client Conversation +createConnectConversationWithRemote cid creator m = do + retry x5 $ + write Cql.insertConv (params LocalQuorum (cid, ConnectConv, creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) + -- We add only one member, second one gets added later, + -- when the other user accepts the connection request. + (lmems, rmems) <- addMembers cid m + pure + Conversation + { convId = cid, + convType = ConnectConv, + convCreator = creator, + convName = Nothing, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createLegacyOne2OneConversation :: + Local x -> + U.UUID U.V4 -> + U.UUID U.V4 -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Client Conversation +createLegacyOne2OneConversation loc a b name ti = do + let conv = localOne2OneConvId a b + a' = Id (U.unpack a) + b' = Id (U.unpack b) + createOne2OneConversation + conv + (qualifyAs loc a') + (qUntagged (qualifyAs loc b')) + name + ti + +createOne2OneConversation :: + ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + Client Conversation +createOne2OneConversation conv self other name mtid = do + retry x5 $ case mtid of + Nothing -> write Cql.insertConv (params LocalQuorum (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + Just tid -> batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery Cql.insertConv (conv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) + addPrepQuery Cql.insertTeamConv (tid, conv, False) + (lmems, rmems) <- addMembers conv (toUserList self [qUntagged self, other]) + pure + Conversation + { convId = conv, + convType = ConnectConv, + convCreator = tUnqualified self, + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Client Conversation +createSelfConversation lusr name = do + let usr = tUnqualified lusr + conv = selfConv usr + lconv = qualifyAs lusr conv + retry x5 $ + write Cql.insertConv (params LocalQuorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) + (lmems, rmems) <- addMembers (tUnqualified lconv) (UserList [tUnqualified lusr] []) + pure + Conversation + { convId = conv, + convType = SelfConv, + convCreator = usr, + convName = fmap fromRange name, + convAccess = [PrivateAccess], + convAccessRole = privateRole, + convLocalMembers = lmems, + convRemoteMembers = rmems, + convTeam = Nothing, + convDeleted = Nothing, + convMessageTimer = Nothing, + convReceiptMode = Nothing + } + +deleteConversation :: ConvId -> Client () +deleteConversation cid = do + retry x5 $ write Cql.markConvDeleted (params LocalQuorum (Identity cid)) + + localMembers <- members cid + remoteMembers <- lookupRemoteMembers cid + + removeMembersFromLocalConv cid $ + UserList (lmId <$> localMembers) (rmId <$> remoteMembers) + + retry x5 $ write Cql.deleteConv (params LocalQuorum (Identity cid)) + +conversationMeta :: ConvId -> Client (Maybe ConversationMetadata) +conversationMeta conv = + fmap toConvMeta + <$> retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) + where + toConvMeta (t, c, a, r, n, i, _, mt, rm) = + ConversationMetadata t c (defAccess t a) (maybeRole t r) n i mt rm + +isConvAlive :: ConvId -> Client Bool +isConvAlive cid = do + result <- retry x1 (query1 Cql.isConvDeleted (params LocalQuorum (Identity cid))) + case runIdentity <$> result of + Nothing -> pure False + Just Nothing -> pure True + Just (Just True) -> pure False + Just (Just False) -> pure True + +updateConvType :: ConvId -> ConvType -> Client () +updateConvType cid ty = + retry x5 $ + write Cql.updateConvType (params LocalQuorum (ty, cid)) + +updateConvName :: ConvId -> Range 1 256 Text -> Client () +updateConvName cid name = retry x5 $ write Cql.updateConvName (params LocalQuorum (fromRange name, cid)) + +updateConvAccess :: ConvId -> ConversationAccessData -> Client () +updateConvAccess cid (ConversationAccessData acc role) = + retry x5 $ + write Cql.updateConvAccess (params LocalQuorum (Cql.Set (toList acc), role, cid)) + +updateConvReceiptMode :: ConvId -> ReceiptMode -> Client () +updateConvReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params LocalQuorum (receiptMode, cid)) + +updateConvMessageTimer :: ConvId -> Maybe Milliseconds -> Client () +updateConvMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params LocalQuorum (mtimer, cid)) + +getConversation :: ConvId -> Client (Maybe Conversation) +getConversation conv = do + cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params LocalQuorum (Identity conv))) + remoteMems <- UnliftIO.async $ lookupRemoteMembers conv + mbConv <- + toConv conv + <$> members conv + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait cdata + return mbConv >>= conversationGC + +{- "Garbage collect" the conversation, i.e. the conversation may be + marked as deleted, in which case we delete it and return Nothing -} +conversationGC :: + Maybe Conversation -> + Client (Maybe Conversation) +conversationGC conv = case join (convDeleted <$> conv) of + (Just True) -> do + sequence_ $ deleteConversation . convId <$> conv + return Nothing + _ -> return conv + +localConversations :: + (Members '[Embed IO, P.Reader ClientState, TinyLog] r) => + [ConvId] -> + Sem r [Conversation] +localConversations [] = return [] +localConversations ids = do + cs <- embedClient $ do + convs <- UnliftIO.async fetchConvs + mems <- UnliftIO.async $ memberLists ids + remoteMems <- UnliftIO.async $ remoteMemberLists ids + zipWith4 toConv ids + <$> UnliftIO.wait mems + <*> UnliftIO.wait remoteMems + <*> UnliftIO.wait convs + foldrM flatten [] (zip ids cs) + where + fetchConvs = do + cs <- retry x1 $ query Cql.selectConvs (params LocalQuorum (Identity ids)) + let m = Map.fromList $ map (\(c, t, u, n, a, r, i, d, mt, rm) -> (c, (t, u, n, a, r, i, d, mt, rm))) cs + return $ map (`Map.lookup` m) ids + flatten (i, c) cc = case c of + Nothing -> do + warn $ Log.msg ("No conversation for: " <> toByteString i) + return cc + Just c' -> return (c' : cc) + +-- | Takes a list of conversation ids and returns those found for the given +-- user. +localConversationIdsOf :: UserId -> [ConvId] -> Client [ConvId] +localConversationIdsOf usr cids = do + runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params LocalQuorum (usr, cids))) + +-- | Takes a list of remote conversation ids and fetches member status flags +-- for the given user +remoteConversationStatus :: + UserId -> + [Remote ConvId] -> + Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatus uid = + fmap mconcat + . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomain uid) + . bucketRemote + +remoteConversationStatusOnDomain :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) +remoteConversationStatusOnDomain uid rconvs = + Map.fromList . map toPair + <$> query Cql.selectRemoteConvMemberStatuses (params LocalQuorum (uid, tDomain rconvs, tUnqualified rconvs)) + where + toPair (conv, omus, omur, oar, oarr, hid, hidr) = + ( qualifyAs rconvs conv, + toMemberStatus (omus, omur, oar, oarr, hid, hidr) + ) + +toConv :: + ConvId -> + [LocalMember] -> + [RemoteMember] -> + Maybe (ConvType, UserId, Maybe (Cql.Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> + Maybe Conversation +toConv cid mms remoteMems conv = + f mms <$> conv + where + f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm + +interpretConversationStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState, TinyLog] r => + Sem (ConversationStore ': r) a -> + Sem r a +interpretConversationStoreToCassandra = interpret $ \case + CreateConversation nc -> embedClient $ createConversation nc + CreateConnectConversation x y name -> + embedClient $ createConnectConversation x y name + CreateConnectConversationWithRemote cid lusr mems -> + embedClient $ createConnectConversationWithRemote cid lusr mems + CreateLegacyOne2OneConversation loc x y name tid -> + embedClient $ createLegacyOne2OneConversation loc x y name tid + CreateOne2OneConversation conv self other name mtid -> + embedClient $ createOne2OneConversation conv self other name mtid + CreateSelfConversation lusr name -> + embedClient $ createSelfConversation lusr name + GetConversation cid -> embedClient $ getConversation cid + GetConversations cids -> localConversations cids + GetConversationMetadata cid -> embedClient $ conversationMeta cid + IsConversationAlive cid -> embedClient $ isConvAlive cid + SelectConversations uid cids -> embedClient $ localConversationIdsOf uid cids + GetRemoteConversationStatus uid cids -> embedClient $ remoteConversationStatus uid cids + SetConversationType cid ty -> embedClient $ updateConvType cid ty + SetConversationName cid value -> embedClient $ updateConvName cid value + SetConversationAccess cid value -> embedClient $ updateConvAccess cid value + SetConversationReceiptMode cid value -> embedClient $ updateConvReceiptMode cid value + SetConversationMessageTimer cid value -> embedClient $ updateConvMessageTimer cid value + DeleteConversation cid -> embedClient $ deleteConversation cid diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs new file mode 100644 index 00000000000..039fc643428 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -0,0 +1,361 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Conversation.Members + ( addMembers, + members, + memberLists, + remoteMemberLists, + lookupRemoteMembers, + removeMembersFromLocalConv, + toMemberStatus, + interpretMemberStoreToCassandra, + ) +where + +import Cassandra +import Data.Domain +import Data.Id +import qualified Data.List.Extra as List +import qualified Data.Map as Map +import Data.Monoid +import Data.Qualified +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Services +import Galley.Cassandra.Store +import Galley.Effects.MemberStore +import Galley.Types.Conversations.Members +import Galley.Types.ToUserRole +import Galley.Types.UserList +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO +import Wire.API.Conversation.Member +import Wire.API.Conversation.Role +import Wire.API.Provider.Service + +-- | Add members to a local conversation. +-- Conversation is local, so we can add any member to it (including remote ones). +-- When the role is not specified, it defaults to admin. +-- Please make sure the conversation doesn't exceed the maximum size! +addMembers :: + ToUserRole a => + ConvId -> + UserList a -> + Client ([LocalMember], [RemoteMember]) +addMembers conv (fmap toUserRole -> UserList lusers rusers) = do + -- batch statement with 500 users are known to be above the batch size limit + -- and throw "Batch too large" errors. Therefor we chunk requests and insert + -- sequentially. (parallelizing would not aid performance as the partition + -- key, i.e. the convId, is on the same cassandra node) + -- chunk size 32 was chosen to lead to batch statements + -- below the batch threshold + -- With chunk size of 64: + -- [galley] Server warning: Batch for [galley_test.member, galley_test.user] is of size 7040, exceeding specified threshold of 5120 by 1920. + -- + for_ (List.chunksOf 32 lusers) $ \chunk -> do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ chunk $ \(u, r) -> do + -- User is local, too, so we add it to both the member and the user table + addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) + addPrepQuery Cql.insertUserConv (u, conv) + + for_ (List.chunksOf 32 rusers) $ \chunk -> do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do + -- User is remote, so we only add it to the member_remote_user + -- table, but the reverse mapping has to be done on the remote + -- backend; so we assume an additional call to their backend has + -- been (or will be) made separately. See Galley.API.Update.addMembers + addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) + + pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) + +removeMembersFromLocalConv :: ConvId -> UserList UserId -> Client () +removeMembersFromLocalConv cnv victims = void $ do + UnliftIO.concurrently + (removeLocalMembersFromLocalConv cnv (ulLocals victims)) + (removeRemoteMembersFromLocalConv cnv (ulRemotes victims)) + +removeLocalMembersFromLocalConv :: ConvId -> [UserId] -> Client () +removeLocalMembersFromLocalConv _ [] = pure () +removeLocalMembersFromLocalConv cnv victims = do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ victims $ \victim -> do + addPrepQuery Cql.removeMember (cnv, victim) + addPrepQuery Cql.deleteUserConv (victim, cnv) + +removeRemoteMembersFromLocalConv :: ConvId -> [Remote UserId] -> Client () +removeRemoteMembersFromLocalConv _ [] = pure () +removeRemoteMembersFromLocalConv cnv victims = do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ victims $ \(qUntagged -> Qualified uid domain) -> + addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) + +memberLists :: [ConvId] -> Client [[LocalMember]] +memberLists convs = do + mems <- retry x1 $ query Cql.selectMembers (params LocalQuorum (Identity convs)) + let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems + return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs + where + insert (_, Nothing) acc = acc + insert (conv, Just mem) acc = + let f = (Just . maybe [mem] (mem :)) + in Map.alter f conv acc + mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = + (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) + +members :: ConvId -> Client [LocalMember] +members = fmap concat . memberLists . pure + +toMemberStatus :: + ( -- otr muted + Maybe MutedStatus, + Maybe Text, + -- otr archived + Maybe Bool, + Maybe Text, + -- hidden + Maybe Bool, + Maybe Text + ) -> + MemberStatus +toMemberStatus (omus, omur, oar, oarr, hid, hidr) = + MemberStatus + { msOtrMutedStatus = omus, + msOtrMutedRef = omur, + msOtrArchived = fromMaybe False oar, + msOtrArchivedRef = oarr, + msHidden = fromMaybe False hid, + msHiddenRef = hidr + } + +toMember :: + ( UserId, + Maybe ServiceId, + Maybe ProviderId, + Maybe Cql.MemberStatus, + -- otr muted + Maybe MutedStatus, + Maybe Text, + -- otr archived + Maybe Bool, + Maybe Text, + -- hidden + Maybe Bool, + Maybe Text, + -- conversation role name + Maybe RoleName + ) -> + Maybe LocalMember +toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn) = + Just $ + LocalMember + { lmId = usr, + lmService = newServiceRef <$> srv <*> prv, + lmStatus = toMemberStatus (omus, omur, oar, oarr, hid, hidr), + lmConvRoleName = fromMaybe roleNameWireAdmin crn + } +toMember _ = Nothing + +toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember +toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) + +newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember +newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = + RemoteMember + { rmId = qualifyAs ur u, + rmConvRoleName = r + } + +remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] +remoteMemberLists convs = do + mems <- retry x1 $ query Cql.selectRemoteMembers (params LocalQuorum (Identity convs)) + let convMembers = foldr (insert . mkMem) Map.empty mems + return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs + where + insert (conv, mem) acc = + let f = (Just . maybe [mem] (mem :)) + in Map.alter f conv acc + mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) + +lookupRemoteMembers :: ConvId -> Client [RemoteMember] +lookupRemoteMembers conv = join <$> remoteMemberLists [conv] + +member :: + ConvId -> + UserId -> + Client (Maybe LocalMember) +member cnv usr = + (toMember =<<) + <$> retry x1 (query1 Cql.selectMember (params LocalQuorum (cnv, usr))) + +-- | Set local users as belonging to a remote conversation. This is invoked by a +-- remote galley when users from the current backend are added to conversations +-- on the remote end. +addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Client () +addLocalMembersToRemoteConv _ [] = pure () +addLocalMembersToRemoteConv rconv users = do + -- FUTUREWORK: consider using pooledMapConcurrentlyN + for_ (List.chunksOf 32 users) $ \chunk -> + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ chunk $ \u -> + addPrepQuery + Cql.insertUserRemoteConv + (u, tDomain rconv, tUnqualified rconv) + +updateSelfMember :: + Qualified ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMember qcnv lusr = + foldQualified + lusr + updateSelfMemberLocalConv + updateSelfMemberRemoteConv + qcnv + lusr + +updateSelfMemberLocalConv :: + Local ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMemberLocalConv lcid luid mup = do + retry x5 . batch $ do + setType BatchUnLogged + setConsistency LocalQuorum + for_ (mupOtrMuteStatus mup) $ \ms -> + addPrepQuery + Cql.updateOtrMemberMutedStatus + (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) + for_ (mupOtrArchive mup) $ \a -> + addPrepQuery + Cql.updateOtrMemberArchived + (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) + for_ (mupHidden mup) $ \h -> + addPrepQuery + Cql.updateMemberHidden + (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) + +updateSelfMemberRemoteConv :: + Remote ConvId -> + Local UserId -> + MemberUpdate -> + Client () +updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do + retry x5 . batch $ do + setType BatchUnLogged + setConsistency LocalQuorum + for_ (mupOtrMuteStatus mup) $ \ms -> + addPrepQuery + Cql.updateRemoteOtrMemberMutedStatus + (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) + for_ (mupOtrArchive mup) $ \a -> + addPrepQuery + Cql.updateRemoteOtrMemberArchived + (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) + for_ (mupHidden mup) $ \h -> + addPrepQuery + Cql.updateRemoteMemberHidden + (h, mupHiddenRef mup, domain, cid, tUnqualified luid) + +updateOtherMemberLocalConv :: + Local ConvId -> + Qualified UserId -> + OtherMemberUpdate -> + Client () +updateOtherMemberLocalConv lcid quid omu = + do + let addQuery r + | tDomain lcid == qDomain quid = + addPrepQuery + Cql.updateMemberConvRoleName + (r, tUnqualified lcid, qUnqualified quid) + | otherwise = + addPrepQuery + Cql.updateRemoteMemberConvRoleName + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) + retry x5 . batch $ do + setType BatchUnLogged + setConsistency LocalQuorum + traverse_ addQuery (omuConvRoleName omu) + +-- | Select only the members of a remote conversation from a list of users. +-- Return the filtered list and a boolean indicating whether the all the input +-- users are members. +filterRemoteConvMembers :: + [UserId] -> + Remote ConvId -> + Client ([UserId], Bool) +filterRemoteConvMembers users (qUntagged -> Qualified conv dom) = + fmap Data.Monoid.getAll + . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) + <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users + where + filterMember :: UserId -> Client [UserId] + filterMember user = + fmap (map runIdentity) + . retry x1 + $ query Cql.selectRemoteConvMembers (params LocalQuorum (user, dom, conv)) + +removeLocalMembersFromRemoteConv :: + -- | The conversation to remove members from + Remote ConvId -> + -- | Members to remove local to this backend + [UserId] -> + Client () +removeLocalMembersFromRemoteConv _ [] = pure () +removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) + +interpretMemberStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (MemberStore ': r) a -> + Sem r a +interpretMemberStoreToCassandra = interpret $ \case + CreateMembers cid ul -> embedClient $ addMembers cid ul + CreateMembersInRemoteConversation rcid uids -> + embedClient $ addLocalMembersToRemoteConv rcid uids + CreateBotMember sr bid cid -> embedClient $ addBotMember sr bid cid + GetLocalMember cid uid -> embedClient $ member cid uid + GetLocalMembers cid -> embedClient $ members cid + GetRemoteMembers rcid -> embedClient $ lookupRemoteMembers rcid + SelectRemoteMembers uids rcnv -> embedClient $ filterRemoteConvMembers uids rcnv + SetSelfMember qcid luid upd -> embedClient $ updateSelfMember qcid luid upd + SetOtherMember lcid quid upd -> + embedClient $ updateOtherMemberLocalConv lcid quid upd + DeleteMembers cnv ul -> embedClient $ removeMembersFromLocalConv cnv ul + DeleteMembersInRemoteConversation rcnv uids -> + embedClient $ + removeLocalMembersFromRemoteConv rcnv uids diff --git a/services/galley/src/Galley/Cassandra/ConversationList.hs b/services/galley/src/Galley/Cassandra/ConversationList.hs new file mode 100644 index 00000000000..324b7fad34e --- /dev/null +++ b/services/galley/src/Galley/Cassandra/ConversationList.hs @@ -0,0 +1,87 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.ConversationList + ( interpretConversationListToCassandra, + interpretRemoteConversationListToCassandra, + interpretLegacyConversationListToCassandra, + ) +where + +import Cassandra +import Data.Id +import Data.Qualified +import Data.Range +import Galley.Cassandra.Instances () +import Galley.Cassandra.Paging +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.ResultSet +import Galley.Cassandra.Store +import Galley.Effects.ListItems +import Imports hiding (max) +import Polysemy +import qualified Polysemy.Reader as P + +-- | Deprecated, use 'localConversationIdsPageFrom' +conversationIdsFrom :: + UserId -> + Maybe ConvId -> + Range 1 1000 Int32 -> + Client (ResultSet ConvId) +conversationIdsFrom usr start (fromRange -> max) = + mkResultSet . strip . fmap runIdentity <$> case start of + Just c -> paginate Cql.selectUserConvsFrom (paramsP LocalQuorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserConvs (paramsP LocalQuorum (Identity usr) (max + 1)) + where + strip p = p {result = take (fromIntegral max) (result p)} + +localConversationIdsPageFrom :: + UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + Client (PageWithState ConvId) +localConversationIdsPageFrom usr pagingState (fromRange -> max) = + fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) + +remoteConversationIdsPageFrom :: + UserId -> + Maybe PagingState -> + Int32 -> + Client (PageWithState (Remote ConvId)) +remoteConversationIdsPageFrom usr pagingState max = + uncurry toRemoteUnsafe <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState LocalQuorum (Identity usr) max pagingState) + +interpretConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems CassandraPaging ConvId ': r) a -> + Sem r a +interpretConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ localConversationIdsPageFrom uid ps max + +interpretRemoteConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems CassandraPaging (Remote ConvId) ': r) a -> + Sem r a +interpretRemoteConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ remoteConversationIdsPageFrom uid ps (fromRange max) + +interpretLegacyConversationListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems LegacyPaging ConvId ': r) a -> + Sem r a +interpretLegacyConversationListToCassandra = interpret $ \case + ListItems uid ps max -> embedClient $ conversationIdsFrom uid ps max diff --git a/services/galley/src/Galley/Data/CustomBackend.hs b/services/galley/src/Galley/Cassandra/CustomBackend.hs similarity index 57% rename from services/galley/src/Galley/Data/CustomBackend.hs rename to services/galley/src/Galley/Cassandra/CustomBackend.hs index 10cd979b8af..fe757271b82 100644 --- a/services/galley/src/Galley/Data/CustomBackend.hs +++ b/services/galley/src/Galley/Cassandra/CustomBackend.hs @@ -17,32 +17,40 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.CustomBackend - ( getCustomBackend, - setCustomBackend, - deleteCustomBackend, - ) -where +module Galley.Cassandra.CustomBackend (interpretCustomBackendStoreToCassandra) where import Cassandra import Data.Domain (Domain) -import Galley.Data.Instances () -import qualified Galley.Data.Queries as Cql +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.Store +import Galley.Effects.CustomBackendStore (CustomBackendStore (..)) import Galley.Types import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretCustomBackendStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (CustomBackendStore ': r) a -> + Sem r a +interpretCustomBackendStoreToCassandra = interpret $ \case + GetCustomBackend dom -> embedClient $ getCustomBackend dom + SetCustomBackend dom b -> embedClient $ setCustomBackend dom b + DeleteCustomBackend dom -> embedClient $ deleteCustomBackend dom getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) getCustomBackend domain = fmap toCustomBackend <$> do - retry x1 $ query1 Cql.selectCustomBackend (params Quorum (Identity domain)) + retry x1 $ query1 Cql.selectCustomBackend (params LocalQuorum (Identity domain)) where toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} setCustomBackend :: MonadClient m => Domain -> CustomBackend -> m () setCustomBackend domain CustomBackend {..} = do - retry x5 $ write Cql.updateCustomBackend (params Quorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) + retry x5 $ write Cql.updateCustomBackend (params LocalQuorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) deleteCustomBackend :: MonadClient m => Domain -> m () deleteCustomBackend domain = do - retry x5 $ write Cql.deleteCustomBackend (params Quorum (Identity domain)) + retry x5 $ write Cql.deleteCustomBackend (params LocalQuorum (Identity domain)) diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs similarity index 99% rename from services/galley/src/Galley/Data/Instances.hs rename to services/galley/src/Galley/Cassandra/Instances.hs index b1d259548e4..198aa2675c0 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -18,7 +18,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.Instances +module Galley.Cassandra.Instances ( ) where diff --git a/services/galley/src/Galley/Data/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs similarity index 53% rename from services/galley/src/Galley/Data/LegalHold.hs rename to services/galley/src/Galley/Cassandra/LegalHold.hs index e975e223011..87345d5c79e 100644 --- a/services/galley/src/Galley/Data/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -17,17 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.LegalHold - ( createSettings, - getSettings, - removeSettings, - Galley.Data.LegalHold.insertPendingPrekeys, - Galley.Data.LegalHold.selectPendingPrekeys, - Galley.Data.LegalHold.dropPendingPrekeys, - setUserLegalHoldStatus, - setTeamLegalholdWhitelisted, +module Galley.Cassandra.LegalHold + ( interpretLegalHoldStoreToCassandra, isTeamLegalholdWhitelisted, - unsetTeamLegalholdWhitelisted, + + -- * Used by tests + selectPendingPrekeys, ) where @@ -35,33 +28,52 @@ import Brig.Types.Client.Prekey import Brig.Types.Instances () import Brig.Types.Team.LegalHold import Cassandra -import Control.Lens (unsnoc, view) +import Control.Lens (unsnoc) import Data.Id import Data.LegalHold -import Galley.App (Env, options) -import Galley.Data.Instances () -import Galley.Data.Queries as Q -import qualified Galley.Options as Opts -import Galley.Types.Teams (FeatureLegalHold (..), flagLegalHold) +import Galley.Cassandra.Instances () +import qualified Galley.Cassandra.Queries as Q +import Galley.Cassandra.Store +import Galley.Effects.LegalHoldStore (LegalHoldStore (..)) +import Galley.Types.Teams import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretLegalHoldStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (LegalHoldStore ': r) a -> + Sem r a +interpretLegalHoldStoreToCassandra lh = interpret $ \case + CreateSettings s -> embedClient $ createSettings s + GetSettings tid -> embedClient $ getSettings tid + RemoveSettings tid -> embedClient $ removeSettings tid + InsertPendingPrekeys uid pkeys -> embedClient $ insertPendingPrekeys uid pkeys + SelectPendingPrekeys uid -> embedClient $ selectPendingPrekeys uid + DropPendingPrekeys uid -> embedClient $ dropPendingPrekeys uid + SetUserLegalHoldStatus tid uid st -> embedClient $ setUserLegalHoldStatus tid uid st + SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid + UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid + IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid -- | Returns 'False' if legal hold is not enabled for this team -- The Caller is responsible for checking whether legal hold is enabled for this team createSettings :: MonadClient m => LegalHoldService -> m () createSettings (LegalHoldService tid url fpr tok key) = do - retry x1 $ write insertLegalHoldSettings (params Quorum (url, fpr, tok, key, tid)) + retry x1 $ write Q.insertLegalHoldSettings (params LocalQuorum (url, fpr, tok, key, tid)) -- | Returns 'Nothing' if no settings are saved -- The Caller is responsible for checking whether legal hold is enabled for this team getSettings :: MonadClient m => TeamId -> m (Maybe LegalHoldService) getSettings tid = fmap toLegalHoldService <$> do - retry x1 $ query1 selectLegalHoldSettings (params Quorum (Identity tid)) + retry x1 $ query1 Q.selectLegalHoldSettings (params LocalQuorum (Identity tid)) where toLegalHoldService (httpsUrl, fingerprint, tok, key) = LegalHoldService tid httpsUrl fingerprint tok key removeSettings :: MonadClient m => TeamId -> m () -removeSettings tid = retry x5 (write removeLegalHoldSettings (params Quorum (Identity tid))) +removeSettings tid = retry x5 (write Q.removeLegalHoldSettings (params LocalQuorum (Identity tid))) insertPendingPrekeys :: MonadClient m => UserId -> [Prekey] -> m () insertPendingPrekeys uid keys = retry x5 . batch $ @@ -74,7 +86,7 @@ insertPendingPrekeys uid keys = retry x5 . batch $ selectPendingPrekeys :: MonadClient m => UserId -> m (Maybe ([Prekey], LastPrekey)) selectPendingPrekeys uid = pickLastKey . fmap fromTuple - <$> retry x1 (query Q.selectPendingPrekeys (params Quorum (Identity uid))) + <$> retry x1 (query Q.selectPendingPrekeys (params LocalQuorum (Identity uid))) where fromTuple (keyId, key) = Prekey keyId key pickLastKey allPrekeys = @@ -83,24 +95,22 @@ selectPendingPrekeys uid = Just (keys, lst) -> pure (keys, lastPrekey . prekeyKey $ lst) dropPendingPrekeys :: MonadClient m => UserId -> m () -dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params Quorum (Identity uid))) +dropPendingPrekeys uid = retry x5 (write Q.dropPendingPrekeys (params LocalQuorum (Identity uid))) setUserLegalHoldStatus :: MonadClient m => TeamId -> UserId -> UserLegalHoldStatus -> m () setUserLegalHoldStatus tid uid status = - retry x5 (write Q.updateUserLegalHoldStatus (params Quorum (status, tid, uid))) + retry x5 (write Q.updateUserLegalHoldStatus (params LocalQuorum (status, tid, uid))) setTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () setTeamLegalholdWhitelisted tid = - retry x5 (write Q.insertLegalHoldWhitelistedTeam (params Quorum (Identity tid))) + retry x5 (write Q.insertLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) unsetTeamLegalholdWhitelisted :: MonadClient m => TeamId -> m () unsetTeamLegalholdWhitelisted tid = - retry x5 (write Q.removeLegalHoldWhitelistedTeam (params Quorum (Identity tid))) + retry x5 (write Q.removeLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid))) -isTeamLegalholdWhitelisted :: (MonadReader Env m, MonadClient m) => TeamId -> m Bool -isTeamLegalholdWhitelisted tid = do - view (options . Opts.optSettings . Opts.setFeatureFlags . flagLegalHold) >>= \case - FeatureLegalHoldDisabledPermanently -> pure False - FeatureLegalHoldDisabledByDefault -> pure False - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> - isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params Quorum (Identity tid)))) +isTeamLegalholdWhitelisted :: FeatureLegalHold -> TeamId -> Client Bool +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledPermanently _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldDisabledByDefault _ = pure False +isTeamLegalholdWhitelisted FeatureLegalHoldWhitelistTeamsAndImplicitConsent tid = + isJust <$> (runIdentity <$$> retry x5 (query1 Q.selectLegalHoldWhitelistedTeam (params LocalQuorum (Identity tid)))) diff --git a/services/galley/src/Galley/Cassandra/Paging.hs b/services/galley/src/Galley/Cassandra/Paging.hs new file mode 100644 index 00000000000..f4dd6a07c79 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Paging.hs @@ -0,0 +1,103 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Paging + ( CassandraPaging, + LegacyPaging, + InternalPaging, + InternalPage (..), + InternalPagingState (..), + mkInternalPage, + ipNext, + + -- * Re-exports + ResultSet, + resultSetResult, + resultSetType, + ResultSetType (..), + ) +where + +import Cassandra +import Data.Id +import Data.Qualified +import Data.Range +import Galley.Cassandra.ResultSet +import qualified Galley.Effects.Paging as E +import Imports +import Wire.API.Team.Member (HardTruncationLimit, TeamMember) + +-- | This paging system uses Cassandra's 'PagingState' to keep track of state, +-- and does not rely on ordering. This is the preferred way of paging across +-- multiple tables, as in 'MultiTablePaging'. +data CassandraPaging + +type instance E.PagingState CassandraPaging a = PagingState + +type instance E.Page CassandraPaging a = PageWithState a + +type instance E.PagingBounds CassandraPaging ConvId = Range 1 1000 Int32 + +type instance E.PagingBounds CassandraPaging (Remote ConvId) = Range 1 1000 Int32 + +type instance E.PagingBounds CassandraPaging TeamId = Range 1 100 Int32 + +-- | This paging system is based on ordering, and keeps track of state using +-- the id of the next item to fetch. Implementations of this paging system also +-- contain extra logic to detect if the last page has been fetched. +data LegacyPaging + +type instance E.PagingState LegacyPaging a = a + +type instance E.Page LegacyPaging a = ResultSet a + +type instance E.PagingBounds LegacyPaging ConvId = Range 1 1000 Int32 + +type instance E.PagingBounds LegacyPaging TeamId = Range 1 100 Int32 + +data InternalPaging + +data InternalPagingState a = forall s. InternalPagingState (Page s, s -> Client a) + +deriving instance (Functor InternalPagingState) + +data InternalPage a = forall s. InternalPage (Page s, s -> Client a, [a]) + +deriving instance (Functor InternalPage) + +mkInternalPage :: Page s -> (s -> Client a) -> Client (InternalPage a) +mkInternalPage p f = do + items <- traverse f (result p) + pure $ InternalPage (p, f, items) + +ipNext :: InternalPagingState a -> Client (InternalPage a) +ipNext (InternalPagingState (p, f)) = do + p' <- nextPage p + mkInternalPage p' f + +type instance E.PagingState InternalPaging a = InternalPagingState a + +type instance E.Page InternalPaging a = InternalPage a + +type instance E.PagingBounds InternalPaging TeamMember = Range 1 HardTruncationLimit Int32 + +type instance E.PagingBounds InternalPaging TeamId = Range 1 100 Int32 + +instance E.Paging InternalPaging where + pageItems (InternalPage (_, _, items)) = items + pageHasMore (InternalPage (p, _, _)) = hasMore p + pageState (InternalPage (p, f, _)) = InternalPagingState (p, f) diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs similarity index 99% rename from services/galley/src/Galley/Data/Queries.hs rename to services/galley/src/Galley/Cassandra/Queries.hs index a562b792f13..641fdcbe572 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -15,7 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.Queries where +module Galley.Cassandra.Queries where import Brig.Types.Client.Prekey import Brig.Types.Code @@ -28,7 +28,7 @@ import Data.Json.Util import Data.LegalHold import Data.Misc import qualified Data.Text.Lazy as LT -import Galley.Data.Types +import Galley.Data.Scope import Galley.Types hiding (Conversation) import Galley.Types.Conversations.Roles import Galley.Types.Teams diff --git a/services/galley/src/Galley/Cassandra/ResultSet.hs b/services/galley/src/Galley/Cassandra/ResultSet.hs new file mode 100644 index 00000000000..441a5baa40c --- /dev/null +++ b/services/galley/src/Galley/Cassandra/ResultSet.hs @@ -0,0 +1,51 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.ResultSet where + +import Cassandra +import Imports + +-- We use this newtype to highlight the fact that the 'Page' wrapped in here +-- can not reliably used for paging. +-- +-- The reason for this is that Cassandra returns 'hasMore' as true if the +-- page size requested is equal to result size. To work around this we +-- actually request for one additional element and drop the last value if +-- necessary. This means however that 'nextPage' does not work properly as +-- we would miss a value on every page size. +-- Thus, and since we don't want to expose the ResultSet constructor +-- because it gives access to `nextPage`, we give accessors to the results +-- and a more typed `hasMore` (ResultSetComplete | ResultSetTruncated) +data ResultSet a = ResultSet + { resultSetResult :: [a], + resultSetType :: ResultSetType + } + deriving stock (Show, Functor, Foldable, Traversable) + +-- | A more descriptive type than using a simple bool to represent `hasMore` +data ResultSetType + = ResultSetComplete + | ResultSetTruncated + deriving stock (Eq, Show) + +mkResultSet :: Page a -> ResultSet a +mkResultSet page = ResultSet (result page) typ + where + typ + | hasMore page = ResultSetTruncated + | otherwise = ResultSetComplete diff --git a/services/galley/src/Galley/Data/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs similarity index 62% rename from services/galley/src/Galley/Data/SearchVisibility.hs rename to services/galley/src/Galley/Cassandra/SearchVisibility.hs index 680a74702b0..cd3905ad4ce 100644 --- a/services/galley/src/Galley/Data/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -17,25 +15,33 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.SearchVisibility - ( setSearchVisibility, - getSearchVisibility, - resetSearchVisibility, - ) -where +module Galley.Cassandra.SearchVisibility (interpretSearchVisibilityStoreToCassandra) where import Cassandra import Data.Id -import Galley.Data.Instances () -import Galley.Data.Queries +import Galley.Cassandra.Instances () +import Galley.Cassandra.Queries +import Galley.Cassandra.Store +import Galley.Effects.SearchVisibilityStore (SearchVisibilityStore (..)) import Galley.Types.Teams.SearchVisibility import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretSearchVisibilityStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (SearchVisibilityStore ': r) a -> + Sem r a +interpretSearchVisibilityStoreToCassandra = interpret $ \case + GetSearchVisibility tid -> embedClient $ getSearchVisibility tid + SetSearchVisibility tid value -> embedClient $ setSearchVisibility tid value + ResetSearchVisibility tid -> embedClient $ resetSearchVisibility tid -- | Return whether a given team is allowed to enable/disable sso getSearchVisibility :: MonadClient m => TeamId -> m TeamSearchVisibility getSearchVisibility tid = toSearchVisibility <$> do - retry x1 $ query1 selectSearchVisibility (params Quorum (Identity tid)) + retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) where -- The value is either set or we return the default toSearchVisibility :: (Maybe (Identity (Maybe TeamSearchVisibility))) -> TeamSearchVisibility @@ -45,8 +51,8 @@ getSearchVisibility tid = -- | Determines whether a given team is allowed to enable/disable sso setSearchVisibility :: MonadClient m => TeamId -> TeamSearchVisibility -> m () setSearchVisibility tid visibilityType = do - retry x5 $ write updateSearchVisibility (params Quorum (visibilityType, tid)) + retry x5 $ write updateSearchVisibility (params LocalQuorum (visibilityType, tid)) resetSearchVisibility :: MonadClient m => TeamId -> m () resetSearchVisibility tid = do - retry x5 $ write updateSearchVisibility (params Quorum (SearchVisibilityStandard, tid)) + retry x5 $ write updateSearchVisibility (params LocalQuorum (SearchVisibilityStandard, tid)) diff --git a/services/galley/src/Galley/Cassandra/Services.hs b/services/galley/src/Galley/Cassandra/Services.hs new file mode 100644 index 00000000000..724c5dab5f5 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Services.hs @@ -0,0 +1,78 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Services where + +import Cassandra +import Control.Lens +import Data.Id +import Galley.Cassandra.Queries +import Galley.Cassandra.Store +import Galley.Data.Services +import Galley.Effects.ServiceStore (ServiceStore (..)) +import Galley.Types hiding (Conversation) +import Galley.Types.Bot +import Galley.Types.Conversations.Members (newMember) +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +-- FUTUREWORK: support adding bots to a remote conversation +addBotMember :: ServiceRef -> BotId -> ConvId -> Client BotMember +addBotMember s bot cnv = do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery insertUserConv (botUserId bot, cnv) + addPrepQuery insertBot (cnv, bot, sid, pid) + pure (BotMember mem) + where + pid = s ^. serviceRefProvider + sid = s ^. serviceRefId + mem = (newMember (botUserId bot)) {lmService = Just s} + +-- Service -------------------------------------------------------------------- + +interpretServiceStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ServiceStore ': r) a -> + Sem r a +interpretServiceStoreToCassandra = interpret $ \case + CreateService s -> embedClient $ insertService s + GetService sr -> embedClient $ lookupService sr + DeleteService sr -> embedClient $ deleteService sr + +insertService :: MonadClient m => Service -> m () +insertService s = do + let sid = s ^. serviceRef . serviceRefId + let pid = s ^. serviceRef . serviceRefProvider + let tok = s ^. serviceToken + let url = s ^. serviceUrl + let fps = Set (s ^. serviceFingerprints) + let ena = s ^. serviceEnabled + retry x5 $ write insertSrv (params LocalQuorum (pid, sid, url, tok, fps, ena)) + +lookupService :: MonadClient m => ServiceRef -> m (Maybe Service) +lookupService s = + fmap toService + <$> retry x1 (query1 selectSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) + where + toService (url, tok, Set fps, ena) = + newService s url tok fps & set serviceEnabled ena + +deleteService :: MonadClient m => ServiceRef -> m () +deleteService s = retry x5 (write rmSrv (params LocalQuorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Cassandra/Store.hs b/services/galley/src/Galley/Cassandra/Store.hs new file mode 100644 index 00000000000..d610321fcc0 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Store.hs @@ -0,0 +1,31 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Store + ( embedClient, + ) +where + +import Cassandra +import Imports +import Polysemy +import Polysemy.Reader as P + +embedClient :: Members '[Embed IO, P.Reader ClientState] r => Client a -> Sem r a +embedClient client = do + cs <- P.ask + embed @IO $ runClient cs client diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs new file mode 100644 index 00000000000..9e5ece8d008 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -0,0 +1,422 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.Team + ( interpretTeamStoreToCassandra, + interpretTeamMemberStoreToCassandra, + interpretTeamListToCassandra, + interpretInternalTeamListToCassandra, + ) +where + +import Cassandra +import Cassandra.Util +import Control.Exception (ErrorCall (ErrorCall)) +import Control.Lens hiding ((<|)) +import Control.Monad.Catch (throwM) +import Control.Monad.Extra (ifM) +import Data.Id as Id +import Data.Json.Util (UTCTimeMillis (..)) +import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) +import qualified Data.Map.Strict as Map +import Data.Range +import qualified Data.Set as Set +import Data.UUID.V4 (nextRandom) +import qualified Galley.Cassandra.Conversation as C +import Galley.Cassandra.LegalHold (isTeamLegalholdWhitelisted) +import Galley.Cassandra.Paging +import qualified Galley.Cassandra.Queries as Cql +import Galley.Cassandra.ResultSet +import Galley.Cassandra.Store +import Galley.Effects.ListItems +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamStore (TeamStore (..)) +import Galley.Types.Teams hiding + ( DeleteTeam, + GetTeamConversations, + SetTeamData, + ) +import qualified Galley.Types.Teams as Teams +import Galley.Types.Teams.Intra +import Imports hiding (Set, max) +import Polysemy +import qualified Polysemy.Reader as P +import qualified UnliftIO +import Wire.API.Team.Member + +interpretTeamStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (TeamStore ': r) a -> + Sem r a +interpretTeamStoreToCassandra lh = interpret $ \case + CreateTeamMember tid mem -> embedClient $ addTeamMember tid mem + SetTeamMemberPermissions perm0 tid uid perm1 -> + embedClient $ updateTeamMember perm0 tid uid perm1 + CreateTeam t uid n i k b -> embedClient $ createTeam t uid n i k b + DeleteTeamMember tid uid -> embedClient $ removeTeamMember tid uid + GetBillingTeamMembers tid -> embedClient $ listBillingTeamMembers tid + GetTeam tid -> embedClient $ team tid + GetTeamName tid -> embedClient $ getTeamName tid + GetTeamConversation tid cid -> embedClient $ teamConversation tid cid + GetTeamConversations tid -> embedClient $ getTeamConversations tid + SelectTeams uid tids -> embedClient $ teamIdsOf uid tids + GetTeamMember tid uid -> embedClient $ teamMember lh tid uid + GetTeamMembersWithLimit tid n -> embedClient $ teamMembersWithLimit lh tid n + GetTeamMembers tid -> embedClient $ teamMembersCollectedWithPagination lh tid + SelectTeamMembers tid uids -> embedClient $ teamMembersLimited lh tid uids + GetUserTeams uid -> embedClient $ userTeams uid + GetUsersTeams uids -> embedClient $ usersTeams uids + GetOneUserTeam uid -> embedClient $ oneUserTeam uid + GetTeamsBindings tid -> embedClient $ getTeamsBindings tid + GetTeamBinding tid -> embedClient $ getTeamBinding tid + GetTeamCreationTime tid -> embedClient $ teamCreationTime tid + DeleteTeam tid -> embedClient $ deleteTeam tid + DeleteTeamConversation tid cid -> embedClient $ removeTeamConv tid cid + SetTeamData tid upd -> embedClient $ updateTeam tid upd + SetTeamStatus tid st -> embedClient $ updateTeamStatus tid st + +interpretTeamListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems LegacyPaging TeamId ': r) a -> + Sem r a +interpretTeamListToCassandra = interpret $ \case + ListItems uid ps lim -> embedClient $ teamIdsFrom uid ps lim + +interpretInternalTeamListToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (ListItems InternalPaging TeamId ': r) a -> + Sem r a +interpretInternalTeamListToCassandra = interpret $ \case + ListItems uid mps lim -> embedClient $ case mps of + Nothing -> do + page <- teamIdsForPagination uid Nothing lim + mkInternalPage page pure + Just ps -> ipNext ps + +interpretTeamMemberStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + FeatureLegalHold -> + Sem (TeamMemberStore InternalPaging ': r) a -> + Sem r a +interpretTeamMemberStoreToCassandra lh = interpret $ \case + ListTeamMembers tid mps lim -> embedClient $ case mps of + Nothing -> do + page <- teamMembersForPagination tid Nothing lim + mkInternalPage page (newTeamMember' lh tid) + Just ps -> ipNext ps + +createTeam :: + Maybe TeamId -> + UserId -> + Range 1 256 Text -> + Range 1 256 Text -> + Maybe (Range 1 256 Text) -> + TeamBinding -> + Client Team +createTeam t uid (fromRange -> n) (fromRange -> i) k b = do + tid <- maybe (Id <$> liftIO nextRandom) return t + retry x5 $ write Cql.insertTeam (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) + pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) + where + initialStatus Binding = PendingActive -- Team becomes Active after User account activation + initialStatus NonBinding = Active + +listBillingTeamMembers :: TeamId -> Client [UserId] +listBillingTeamMembers tid = + fmap runIdentity + <$> retry x1 (query Cql.listBillingTeamMembers (params LocalQuorum (Identity tid))) + +getTeamName :: TeamId -> Client (Maybe Text) +getTeamName tid = + fmap runIdentity + <$> retry x1 (query1 Cql.selectTeamName (params LocalQuorum (Identity tid))) + +teamConversation :: TeamId -> ConvId -> Client (Maybe TeamConversation) +teamConversation t c = + fmap (newTeamConversation c . runIdentity) + <$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) + +getTeamConversations :: TeamId -> Client [TeamConversation] +getTeamConversations t = + map (uncurry newTeamConversation) + <$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) + +teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) +teamIdsFrom usr range (fromRange -> max) = + mkResultSet . fmap runIdentity . strip <$> case range of + Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) (max + 1)) + Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) (max + 1)) + where + strip p = p {result = take (fromIntegral max) (result p)} + +teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (Page TeamId) +teamIdsForPagination usr range (fromRange -> max) = + fmap runIdentity <$> case range of + Just c -> paginate Cql.selectUserTeamsFrom (paramsP LocalQuorum (usr, c) max) + Nothing -> paginate Cql.selectUserTeams (paramsP LocalQuorum (Identity usr) max) + +teamMember :: FeatureLegalHold -> TeamId -> UserId -> Client (Maybe TeamMember) +teamMember lh t u = + newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params LocalQuorum (t, u))) + where + newTeamMember'' :: + UserId -> + Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> + Client (Maybe TeamMember) + newTeamMember'' _ Nothing = pure Nothing + newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = + Just <$> newTeamMember' lh t (uid, perms, minvu, minvt, mulhStatus) + +addTeamMember :: TeamId -> TeamMember -> Client () +addTeamMember t m = + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery + Cql.insertTeamMember + ( t, + m ^. userId, + m ^. permissions, + m ^? invitation . _Just . _1, + m ^? invitation . _Just . _2 + ) + addPrepQuery Cql.insertUserTeam (m ^. userId, t) + when (m `hasPermission` SetBilling) $ + addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) + +updateTeamMember :: + -- | Old permissions, used for maintaining 'billing_team_member' table + Permissions -> + TeamId -> + UserId -> + -- | New permissions + Permissions -> + Client () +updateTeamMember oldPerms tid uid newPerms = do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery Cql.updatePermissions (newPerms, tid, uid) + + when (SetBilling `Set.member` acquiredPerms) $ + addPrepQuery Cql.insertBillingTeamMember (tid, uid) + + when (SetBilling `Set.member` lostPerms) $ + addPrepQuery Cql.deleteBillingTeamMember (tid, uid) + where + permDiff = Set.difference `on` view Teams.self + acquiredPerms = newPerms `permDiff` oldPerms + lostPerms = oldPerms `permDiff` newPerms + +removeTeamMember :: TeamId -> UserId -> Client () +removeTeamMember t m = + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery Cql.deleteTeamMember (t, m) + addPrepQuery Cql.deleteUserTeam (m, t) + addPrepQuery Cql.deleteBillingTeamMember (t, m) + +team :: TeamId -> Client (Maybe TeamData) +team tid = + fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params LocalQuorum (Identity tid))) + where + toTeam (u, n, i, k, d, s, st, b) = + let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k + status = if d then PendingDelete else fromMaybe Active s + in TeamData t status (writeTimeToUTC <$> st) + +teamIdsOf :: UserId -> [TeamId] -> Client [TeamId] +teamIdsOf usr tids = + map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params LocalQuorum (usr, toList tids))) + +teamMembersWithLimit :: + FeatureLegalHold -> + TeamId -> + Range 1 HardTruncationLimit Int32 -> + Client TeamMemberList +teamMembersWithLimit lh t (fromRange -> limit) = do + -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size + pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity t) (limit + 1))) + ms <- mapM (newTeamMember' lh t) . take (fromIntegral limit) $ result pageTuple + pure $ + if hasMore pageTuple + then newTeamMemberList ms ListTruncated + else newTeamMemberList ms ListComplete + +-- NOTE: Use this function with care... should only be required when deleting a team! +-- Maybe should be left explicitly for the caller? +teamMembersCollectedWithPagination :: FeatureLegalHold -> TeamId -> Client [TeamMember] +teamMembersCollectedWithPagination lh tid = do + mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) + collectTeamMembersPaginated [] mems + where + collectTeamMembersPaginated acc mems = do + tMembers <- mapM (newTeamMember' lh tid) (result mems) + if (null $ result mems) + then collectTeamMembersPaginated (tMembers ++ acc) =<< nextPage mems + else return (tMembers ++ acc) + +-- Lookup only specific team members: this is particularly useful for large teams when +-- needed to look up only a small subset of members (typically 2, user to perform the action +-- and the target user) +teamMembersLimited :: FeatureLegalHold -> TeamId -> [UserId] -> Client [TeamMember] +teamMembersLimited lh t u = + mapM (newTeamMember' lh t) + =<< retry x1 (query Cql.selectTeamMembers' (params LocalQuorum (t, u))) + +userTeams :: UserId -> Client [TeamId] +userTeams u = + map runIdentity + <$> retry x1 (query Cql.selectUserTeams (params LocalQuorum (Identity u))) + +usersTeams :: [UserId] -> Client (Map UserId TeamId) +usersTeams uids = do + pairs :: [(UserId, TeamId)] <- + catMaybes + <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeam uid) uids + pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs + +oneUserTeam :: UserId -> Client (Maybe TeamId) +oneUserTeam u = + fmap runIdentity + <$> retry x1 (query1 Cql.selectOneUserTeam (params LocalQuorum (Identity u))) + +teamCreationTime :: TeamId -> Client (Maybe TeamCreationTime) +teamCreationTime t = + checkCreation . fmap runIdentity + <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params LocalQuorum (Identity t))) + where + checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts + checkCreation _ = Nothing + +getTeamBinding :: TeamId -> Client (Maybe TeamBinding) +getTeamBinding t = + fmap (fromMaybe NonBinding . runIdentity) + <$> retry x1 (query1 Cql.selectTeamBinding (params LocalQuorum (Identity t))) + +getTeamsBindings :: [TeamId] -> Client [TeamBinding] +getTeamsBindings = + fmap catMaybes + . UnliftIO.pooledMapConcurrentlyN 8 getTeamBinding + +deleteTeam :: TeamId -> Client () +deleteTeam tid = do + -- TODO: delete service_whitelist records that mention this team + retry x5 $ write Cql.markTeamDeleted (params LocalQuorum (PendingDelete, tid)) + mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) + removeTeamMembers mems + cnvs <- teamConversationsForPagination tid Nothing (unsafeRange 2000) + removeConvs cnvs + retry x5 $ write Cql.deleteTeam (params LocalQuorum (Deleted, tid)) + where + removeConvs :: Page TeamConversation -> Client () + removeConvs cnvs = do + for_ (result cnvs) $ removeTeamConv tid . view conversationId + unless (null $ result cnvs) $ + removeConvs =<< liftClient (nextPage cnvs) + + removeTeamMembers :: + Page + ( UserId, + Permissions, + Maybe UserId, + Maybe UTCTimeMillis, + Maybe UserLegalHoldStatus + ) -> + Client () + removeTeamMembers mems = do + mapM_ (removeTeamMember tid . view _1) (result mems) + unless (null $ result mems) $ + removeTeamMembers =<< liftClient (nextPage mems) + +removeTeamConv :: TeamId -> ConvId -> Client () +removeTeamConv tid cid = liftClient $ do + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery Cql.markConvDeleted (Identity cid) + addPrepQuery Cql.deleteTeamConv (tid, cid) + C.deleteConversation cid + +updateTeamStatus :: TeamId -> TeamStatus -> Client () +updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params LocalQuorum (s, t)) + +updateTeam :: TeamId -> TeamUpdateData -> Client () +updateTeam tid u = retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ (u ^. nameUpdate) $ \n -> + addPrepQuery Cql.updateTeamName (fromRange n, tid) + for_ (u ^. iconUpdate) $ \i -> + addPrepQuery Cql.updateTeamIcon (fromRange i, tid) + for_ (u ^. iconKeyUpdate) $ \k -> + addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) + +-- | Construct 'TeamMember' from database tuple. +-- If FeatureLegalHoldWhitelistTeamsAndImplicitConsent is enabled set UserLegalHoldDisabled +-- if team is whitelisted. +-- +-- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the +-- other is 'Just', which can only be caused by inconsistent database content. +newTeamMember' :: + FeatureLegalHold -> + TeamId -> + (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> + Client TeamMember +newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do + mk minvu minvt >>= maybeGrant + where + maybeGrant :: TeamMember -> Client TeamMember + maybeGrant m = + ifM + (isTeamLegalholdWhitelisted lh tid) + (pure (grantImplicitConsent m)) + (pure m) + + grantImplicitConsent :: TeamMember -> TeamMember + grantImplicitConsent = + legalHoldStatus %~ \case + UserLegalHoldNoConsent -> UserLegalHoldDisabled + -- the other cases don't change; we just enumerate them to catch future changes in + -- 'UserLegalHoldStatus' better. + UserLegalHoldDisabled -> UserLegalHoldDisabled + UserLegalHoldPending -> UserLegalHoldPending + UserLegalHoldEnabled -> UserLegalHoldEnabled + + mk (Just invu) (Just invt) = pure $ TeamMember uid perms (Just (invu, invt)) lhStatus + mk Nothing Nothing = pure $ TeamMember uid perms Nothing lhStatus + mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." + +teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Client (Page TeamConversation) +teamConversationsForPagination tid start (fromRange -> max) = + fmap (uncurry newTeamConversation) <$> case start of + Just c -> paginate Cql.selectTeamConvsFrom (paramsP LocalQuorum (tid, c) max) + Nothing -> paginate Cql.selectTeamConvs (paramsP LocalQuorum (Identity tid) max) + +type RawTeamMember = (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) + +-- This function has a bit of a difficult type to work with because we don't +-- have a pure function of type RawTeamMember -> TeamMember so we cannot fmap +-- over the ResultSet. We don't want to mess around with the Result size +-- nextPage either otherwise +teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Client (Page RawTeamMember) +teamMembersForPagination tid start (fromRange -> max) = + case start of + Just u -> paginate Cql.selectTeamMembersFrom (paramsP LocalQuorum (tid, u) max) + Nothing -> paginate Cql.selectTeamMembers (paramsP LocalQuorum (Identity tid) max) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs new file mode 100644 index 00000000000..7ef181c87af --- /dev/null +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -0,0 +1,153 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Cassandra.TeamFeatures (interpretTeamFeatureStoreToCassandra) where + +import Cassandra +import Data.Id +import Data.Proxy +import Galley.Cassandra.Instances () +import Galley.Cassandra.Store +import Galley.Data.TeamFeatures +import Galley.Effects.TeamFeatureStore (TeamFeatureStore (..)) +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import Wire.API.Team.Feature + +getFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + m (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig _ tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mStatusValue <- (>>= runIdentity) <$> retry x1 q + pure $ TeamFeatureStatusNoConfig <$> mStatusValue + where + select :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatusValue)) + select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" + +setFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) m. + ( MonadClient m, + FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStatus a -> + m (TeamFeatureStatus a) +setFeatureStatusNoConfig _ tid status = do + let flag = tfwoStatus status + retry x5 $ write insert (params LocalQuorum (tid, flag)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue) () + insert = fromString $ "insert into team_features (team_id, " <> statusCol @a <> ") values (?, ?)" + +getApplockFeatureStatus :: + forall m. + (MonadClient m) => + TeamId -> + m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) +getApplockFeatureStatus tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mTuple <- retry x1 q + pure $ + mTuple >>= \(mbStatusValue, mbEnforce, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureAppLockConfig <$> mbEnforce <*> mbTimeout) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe EnforceAppLock, Maybe Int32) + select = + fromString $ + "select " <> statusCol @'TeamFeatureAppLock <> ", app_lock_enforce, app_lock_inactivity_timeout_secs " + <> "from team_features where team_id = ?" + +setApplockFeatureStatus :: + (MonadClient m) => + TeamId -> + TeamFeatureStatus 'TeamFeatureAppLock -> + m (TeamFeatureStatus 'TeamFeatureAppLock) +setApplockFeatureStatus tid status = do + let statusValue = tfwcStatus status + enforce = applockEnforceAppLock . tfwcConfig $ status + timeout = applockInactivityTimeoutSecs . tfwcConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, enforce, timeout)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, EnforceAppLock, Int32) () + insert = + fromString $ + "insert into team_features (team_id, " + <> statusCol @'TeamFeatureAppLock + <> ", app_lock_enforce, app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" + +getSelfDeletingMessagesStatus :: + forall m. + (MonadClient m) => + TeamId -> + m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) +getSelfDeletingMessagesStatus tid = do + let q = query1 select (params LocalQuorum (Identity tid)) + mTuple <- retry x1 q + pure $ + mTuple >>= \(mbStatusValue, mbTimeout) -> + TeamFeatureStatusWithConfig <$> mbStatusValue <*> (TeamFeatureSelfDeletingMessagesConfig <$> mbTimeout) + where + select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Int32) + select = + fromString $ + "select " + <> statusCol @'TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl " + <> "from team_features where team_id = ?" + +setSelfDeletingMessagesStatus :: + (MonadClient m) => + TeamId -> + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) +setSelfDeletingMessagesStatus tid status = do + let statusValue = tfwcStatus status + timeout = sdmEnforcedTimeoutSeconds . tfwcConfig $ status + retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) + pure status + where + insert :: PrepQuery W (TeamId, TeamFeatureStatusValue, Int32) () + insert = + fromString $ + "insert into team_features (team_id, " + <> statusCol @'TeamFeatureSelfDeletingMessages + <> ", self_deleting_messages_ttl) " + <> "values (?, ?, ?)" + +interpretTeamFeatureStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (TeamFeatureStore ': r) a -> + Sem r a +interpretTeamFeatureStoreToCassandra = interpret $ \case + GetFeatureStatusNoConfig' p tid -> embedClient $ getFeatureStatusNoConfig p tid + SetFeatureStatusNoConfig' p tid value -> embedClient $ setFeatureStatusNoConfig p tid value + GetApplockFeatureStatus tid -> embedClient $ getApplockFeatureStatus tid + SetApplockFeatureStatus tid value -> embedClient $ setApplockFeatureStatus tid value + GetSelfDeletingMessagesStatus tid -> embedClient $ getSelfDeletingMessagesStatus tid + SetSelfDeletingMessagesStatus tid value -> embedClient $ setSelfDeletingMessagesStatus tid value diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs new file mode 100644 index 00000000000..2a12e347371 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -0,0 +1,139 @@ +-- 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 . + +-- | See also: "Galley.API.TeamNotifications". +-- +-- This module is a clone of "Gundeck.Notification.Data". +-- +-- FUTUREWORK: this is a work-around because it only solves *some* problems with team events. +-- We should really use a scalable message queue instead. +module Galley.Cassandra.TeamNotifications + ( interpretTeamNotificationStoreToCassandra, + ) +where + +import Cassandra +import qualified Data.Aeson as JSON +import Data.Id +import Data.List1 (List1) +import Data.Range (Range, fromRange) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) +import qualified Data.Sequence as Seq +import Galley.Cassandra.Store +import Galley.Data.TeamNotifications +import Galley.Effects.TeamNotificationStore +import Gundeck.Types.Notification +import Imports +import Polysemy +import qualified Polysemy.Reader as P + +interpretTeamNotificationStoreToCassandra :: + Members '[Embed IO, P.Reader ClientState] r => + Sem (TeamNotificationStore ': r) a -> + Sem r a +interpretTeamNotificationStoreToCassandra = interpret $ \case + CreateTeamNotification tid nid objs -> embedClient $ add tid nid objs + GetTeamNotifications tid mnid lim -> embedClient $ fetch tid mnid lim + +-- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned +add :: + TeamId -> + NotificationId -> + List1 JSON.Object -> + Client () +add tid nid (Blob . JSON.encode -> payload) = + write cqlInsert (params LocalQuorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 + where + cqlInsert :: PrepQuery W (TeamId, NotificationId, Blob, Int32) () + cqlInsert = + "INSERT INTO team_notifications \ + \(team, id, payload) VALUES \ + \(?, ?, ?) \ + \USING TTL ?" + +notificationTTLSeconds :: Int32 +notificationTTLSeconds = 24192200 + +fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Client ResultPage +fetch tid since (fromRange -> size) = do + -- We always need to look for one more than requested in order to correctly + -- report whether there are more results. + let size' = bool (+ 1) (+ 2) (isJust since) size + page1 <- case TimeUuid . toUUID <$> since of + Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity tid) size') & retry x1 + Just s -> paginate cqlSince (paramsP LocalQuorum (tid, s) size') & retry x1 + -- Collect results, requesting more pages until we run out of data + -- or have found size + 1 notifications (not including the 'since'). + let isize = fromIntegral size' :: Int + (ns, more) <- collect Seq.empty isize page1 + -- Drop the extra element from the end as well. Keep the inclusive start + -- value in the response (if a 'since' was given and found). + -- This can probably simplified a lot further, but we need to understand + -- 'Seq' in order to do that. If you find a bug, this may be a good + -- place to start looking. + return $! case Seq.viewl (trim (isize - 1) ns) of + EmptyL -> ResultPage Seq.empty False + (x :< xs) -> ResultPage (x <| xs) more + where + collect :: + Seq QueuedNotification -> + Int -> + Page (TimeUuid, Blob) -> + Client (Seq QueuedNotification, Bool) + collect acc num page = + let ns = splitAt num $ foldr toNotif [] (result page) + nseq = Seq.fromList (fst ns) + more = hasMore page + num' = num - Seq.length nseq + acc' = acc >< nseq + in if not more || num' == 0 + then return (acc', more || not (null (snd ns))) + else liftClient (nextPage page) >>= collect acc' num' + trim :: Int -> Seq a -> Seq a + trim l ns + | Seq.length ns <= l = ns + | otherwise = case Seq.viewr ns of + EmptyR -> ns + xs :> _ -> xs + cqlStart :: PrepQuery R (Identity TeamId) (TimeUuid, Blob) + cqlStart = + "SELECT id, payload \ + \FROM team_notifications \ + \WHERE team = ? \ + \ORDER BY id ASC" + cqlSince :: PrepQuery R (TeamId, TimeUuid) (TimeUuid, Blob) + cqlSince = + "SELECT id, payload \ + \FROM team_notifications \ + \WHERE team = ? AND id >= ? \ + \ORDER BY id ASC" + +------------------------------------------------------------------------------- +-- Conversions + +toNotif :: (TimeUuid, Blob) -> [QueuedNotification] -> [QueuedNotification] +toNotif (i, b) ns = + maybe + ns + (\p1 -> queuedNotification notifId p1 : ns) + ( JSON.decode' (fromBlob b) + -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse + -- errors than if it's data provided by a client. it would still be better to have an + -- error entry in the log file and crash, rather than ignore the error and continue. + ) + where + notifId = Id (fromTimeUuid i) diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs deleted file mode 100644 index 4d2e02de642..00000000000 --- a/services/galley/src/Galley/Data.hs +++ /dev/null @@ -1,1274 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Galley.Data - ( ResultSet, - ResultSetType (..), - PageWithState (..), - mkResultSet, - resultSetType, - resultSetResult, - schemaVersion, - - -- * Teams - addTeamMember, - updateTeamMember, - createTeam, - removeTeamMember, - listBillingTeamMembers, - team, - Galley.Data.teamName, - teamConversation, - teamConversations, - teamIdsFrom, - teamIdsForPagination, - teamIdsOf, - teamMember, - withTeamMembersWithChunks, - teamMembersWithLimit, - teamMembersForFanout, - teamMembersCollectedWithPagination, - teamMembersLimited, - userTeams, - usersTeams, - oneUserTeam, - Galley.Data.teamBinding, - teamCreationTime, - deleteTeam, - removeTeamConv, - updateTeam, - updateTeamStatus, - - -- * Conversations - Conversation (..), - convMetadata, - convAccessData, - acceptConnect, - conversation, - conversationIdsFrom, - localConversationIdsOf, - remoteConversationStatus, - localConversationIdsPageFrom, - localConversationIdRowsForPagination, - localConversations, - conversationMeta, - conversationsRemote, - createConnectConversation, - createConnectConversationWithRemote, - createConversation, - createLegacyOne2OneConversation, - createOne2OneConversation, - createSelfConversation, - isConvAlive, - updateConversation, - updateConversationAccess, - updateConversationReceiptMode, - updateConversationMessageTimer, - deleteConversation, - lookupReceiptMode, - remoteConversationIdsPageFrom, - - -- * Conversation Members - addMember, - addMembers, - addLocalMembersToRemoteConv, - member, - members, - lookupRemoteMembers, - removeMember, - removeLocalMembersFromLocalConv, - removeRemoteMembersFromLocalConv, - removeLocalMembersFromRemoteConv, - updateSelfMember, - updateSelfMemberLocalConv, - updateSelfMemberRemoteConv, - updateOtherMember, - updateOtherMemberLocalConv, - updateOtherMemberRemoteConv, - ToUserRole (..), - toQualifiedUserRole, - filterRemoteConvMembers, - - -- * Conversation Codes - lookupCode, - deleteCode, - insertCode, - - -- * Clients - eraseClients, - lookupClients, - lookupClients', - updateClient, - - -- * Utilities - localOne2OneConvId, - newMember, - - -- * Defaults - defRole, - defRegularConvAccess, - ) -where - -import Brig.Types.Code -import Cassandra -import Cassandra.Util -import Control.Arrow (second) -import Control.Exception (ErrorCall (ErrorCall)) -import Control.Lens hiding ((<|)) -import Control.Monad.Catch (throwM) -import Control.Monad.Extra (ifM) -import Data.ByteString.Conversion hiding (parser) -import Data.Domain (Domain) -import Data.Id as Id -import Data.Json.Util (UTCTimeMillis (..)) -import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) -import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.List.Split (chunksOf) -import qualified Data.Map.Strict as Map -import Data.Misc (Milliseconds) -import qualified Data.Monoid -import Data.Qualified -import Data.Range -import qualified Data.Set as Set -import qualified Data.UUID.Tagged as U -import Data.UUID.V4 (nextRandom) -import Galley.App -import Galley.Data.Instances () -import Galley.Data.LegalHold (isTeamLegalholdWhitelisted) -import qualified Galley.Data.Queries as Cql -import Galley.Data.Types as Data -import Galley.Types hiding (Conversation) -import Galley.Types.Bot (newServiceRef) -import Galley.Types.Clients (Clients) -import qualified Galley.Types.Clients as Clients -import Galley.Types.Conversations.Members -import Galley.Types.Conversations.Roles -import Galley.Types.Teams hiding - ( Event, - EventType (..), - self, - teamConversations, - teamMembers, - ) -import qualified Galley.Types.Teams as Teams -import Galley.Types.Teams.Intra -import Galley.Types.UserList -import Galley.Validation -import Imports hiding (Set, max) -import qualified System.Logger.Class as Log -import qualified UnliftIO -import Wire.API.Team.Member - --- We use this newtype to highlight the fact that the 'Page' wrapped in here --- can not reliably used for paging. --- --- The reason for this is that Cassandra returns 'hasMore' as true if the --- page size requested is equal to result size. To work around this we --- actually request for one additional element and drop the last value if --- necessary. This means however that 'nextPage' does not work properly as --- we would miss a value on every page size. --- Thus, and since we don't want to expose the ResultSet constructor --- because it gives access to `nextPage`, we give accessors to the results --- and a more typed `hasMore` (ResultSetComplete | ResultSetTruncated) -data ResultSet a = ResultSet - { resultSetResult :: [a], - resultSetType :: ResultSetType - } - deriving stock (Show, Functor, Foldable, Traversable) - --- | A more descriptive type than using a simple bool to represent `hasMore` -data ResultSetType - = ResultSetComplete - | ResultSetTruncated - deriving stock (Eq, Show) - -mkResultSet :: Page a -> ResultSet a -mkResultSet page = ResultSet (result page) typ - where - typ - | hasMore page = ResultSetTruncated - | otherwise = ResultSetComplete - -schemaVersion :: Int32 -schemaVersion = 53 - --- | Insert a conversation code -insertCode :: Code -> Galley r () -insertCode c = do - let k = codeKey c - let v = codeValue c - let cnv = codeConversation c - let t = round (codeTTL c) - let s = codeScope c - retry x5 (write Cql.insertCode (params Quorum (k, v, cnv, s, t))) - --- | Lookup a conversation by code. -lookupCode :: Key -> Scope -> Galley r (Maybe Code) -lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 Cql.lookupCode (params Quorum (k, s))) - --- | Delete a code associated with the given conversation key -deleteCode :: Key -> Scope -> Galley r () -deleteCode k s = retry x5 $ write Cql.deleteCode (params Quorum (k, s)) - --- Teams -------------------------------------------------------------------- - -team :: TeamId -> Galley r (Maybe TeamData) -team tid = - fmap toTeam <$> retry x1 (query1 Cql.selectTeam (params Quorum (Identity tid))) - where - toTeam (u, n, i, k, d, s, st, b) = - let t = newTeam tid u n i (fromMaybe NonBinding b) & teamIconKey .~ k - status = if d then PendingDelete else fromMaybe Active s - in TeamData t status (writeTimeToUTC <$> st) - -teamName :: TeamId -> Galley r (Maybe Text) -teamName tid = - fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamName (params Quorum (Identity tid))) - -teamIdsOf :: UserId -> Range 1 32 (List TeamId) -> Galley r [TeamId] -teamIdsOf usr (fromList . fromRange -> tids) = - map runIdentity <$> retry x1 (query Cql.selectUserTeamsIn (params Quorum (usr, tids))) - -teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (ResultSet TeamId) -teamIdsFrom usr range (fromRange -> max) = - mkResultSet . fmap runIdentity . strip <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) (max + 1)) - where - strip p = p {result = take (fromIntegral max) (result p)} - -teamIdsForPagination :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Galley r (Page TeamId) -teamIdsForPagination usr range (fromRange -> max) = - fmap runIdentity <$> case range of - Just c -> paginate Cql.selectUserTeamsFrom (paramsP Quorum (usr, c) max) - Nothing -> paginate Cql.selectUserTeams (paramsP Quorum (Identity usr) max) - -teamConversation :: TeamId -> ConvId -> Galley r (Maybe TeamConversation) -teamConversation t c = - fmap (newTeamConversation c . runIdentity) - <$> retry x1 (query1 Cql.selectTeamConv (params Quorum (t, c))) - -teamConversations :: TeamId -> Galley r [TeamConversation] -teamConversations t = - map (uncurry newTeamConversation) - <$> retry x1 (query Cql.selectTeamConvs (params Quorum (Identity t))) - -teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page TeamConversation) -teamConversationsForPagination tid start (fromRange -> max) = - fmap (uncurry newTeamConversation) <$> case start of - Just c -> paginate Cql.selectTeamConvsFrom (paramsP Quorum (tid, c) max) - Nothing -> paginate Cql.selectTeamConvs (paramsP Quorum (Identity tid) max) - -teamMembersForFanout :: TeamId -> Galley r TeamMemberList -teamMembersForFanout t = fanoutLimit >>= teamMembersWithLimit t - -teamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> Galley r TeamMemberList -teamMembersWithLimit t (fromRange -> limit) = do - -- NOTE: We use +1 as size and then trim it due to the semantics of C* when getting a page with the exact same size - pageTuple <- retry x1 (paginate Cql.selectTeamMembers (paramsP Quorum (Identity t) (limit + 1))) - ms <- mapM (newTeamMember' t) . take (fromIntegral limit) $ result pageTuple - pure $ - if hasMore pageTuple - then newTeamMemberList ms ListTruncated - else newTeamMemberList ms ListComplete - --- This function has a bit of a difficult type to work with because we don't have a pure function of type --- (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> TeamMember so we --- cannot fmap over the ResultSet. We don't want to mess around with the Result size nextPage either otherwise -teamMembersForPagination :: TeamId -> Maybe UserId -> Range 1 HardTruncationLimit Int32 -> Galley r (Page (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus)) -teamMembersForPagination tid start (fromRange -> max) = - case start of - Just u -> paginate Cql.selectTeamMembersFrom (paramsP Quorum (tid, u) max) - Nothing -> paginate Cql.selectTeamMembers (paramsP Quorum (Identity tid) max) - --- NOTE: Use this function with care... should only be required when deleting a team! --- Maybe should be left explicitly for the caller? -teamMembersCollectedWithPagination :: TeamId -> Galley r [TeamMember] -teamMembersCollectedWithPagination tid = do - mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) - collectTeamMembersPaginated [] mems - where - collectTeamMembersPaginated acc mems = do - tMembers <- mapM (newTeamMember' tid) (result mems) - if (null $ result mems) - then collectTeamMembersPaginated (tMembers ++ acc) =<< liftClient (nextPage mems) - else return (tMembers ++ acc) - --- Lookup only specific team members: this is particularly useful for large teams when --- needed to look up only a small subset of members (typically 2, user to perform the action --- and the target user) -teamMembersLimited :: TeamId -> [UserId] -> Galley r [TeamMember] -teamMembersLimited t u = - mapM (newTeamMember' t) - =<< retry x1 (query Cql.selectTeamMembers' (params Quorum (t, u))) - -teamMember :: TeamId -> UserId -> Galley r (Maybe TeamMember) -teamMember t u = newTeamMember'' u =<< retry x1 (query1 Cql.selectTeamMember (params Quorum (t, u))) - where - newTeamMember'' :: - UserId -> - Maybe (Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> - Galley r (Maybe TeamMember) - newTeamMember'' _ Nothing = pure Nothing - newTeamMember'' uid (Just (perms, minvu, minvt, mulhStatus)) = - Just <$> newTeamMember' t (uid, perms, minvu, minvt, mulhStatus) - -userTeams :: UserId -> Galley r [TeamId] -userTeams u = - map runIdentity - <$> retry x1 (query Cql.selectUserTeams (params Quorum (Identity u))) - -usersTeams :: [UserId] -> Galley r (Map UserId TeamId) -usersTeams uids = liftClient $ do - pairs :: [(UserId, TeamId)] <- - catMaybes - <$> UnliftIO.pooledMapConcurrentlyN 8 (\uid -> (uid,) <$$> oneUserTeamC uid) uids - pure $ foldl' (\m (k, v) -> Map.insert k v m) Map.empty pairs - -oneUserTeam :: UserId -> Galley r (Maybe TeamId) -oneUserTeam = liftClient . oneUserTeamC - -oneUserTeamC :: UserId -> Client (Maybe TeamId) -oneUserTeamC u = - fmap runIdentity - <$> retry x1 (query1 Cql.selectOneUserTeam (params Quorum (Identity u))) - -teamCreationTime :: TeamId -> Galley r (Maybe TeamCreationTime) -teamCreationTime t = - checkCreation . fmap runIdentity - <$> retry x1 (query1 Cql.selectTeamBindingWritetime (params Quorum (Identity t))) - where - checkCreation (Just (Just ts)) = Just $ TeamCreationTime ts - checkCreation _ = Nothing - -teamBinding :: TeamId -> Galley r (Maybe TeamBinding) -teamBinding t = - fmap (fromMaybe NonBinding . runIdentity) - <$> retry x1 (query1 Cql.selectTeamBinding (params Quorum (Identity t))) - -createTeam :: - Maybe TeamId -> - UserId -> - Range 1 256 Text -> - Range 1 256 Text -> - Maybe (Range 1 256 Text) -> - TeamBinding -> - Galley r Team -createTeam t uid (fromRange -> n) (fromRange -> i) k b = do - tid <- maybe (Id <$> liftIO nextRandom) return t - retry x5 $ write Cql.insertTeam (params Quorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) - pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) - where - initialStatus Binding = PendingActive -- Team becomes Active after User account activation - initialStatus NonBinding = Active - -deleteTeam :: TeamId -> Galley r () -deleteTeam tid = do - -- TODO: delete service_whitelist records that mention this team - retry x5 $ write Cql.markTeamDeleted (params Quorum (PendingDelete, tid)) - mems <- teamMembersForPagination tid Nothing (unsafeRange 2000) - removeTeamMembers mems - cnvs <- teamConversationsForPagination tid Nothing (unsafeRange 2000) - removeConvs cnvs - retry x5 $ write Cql.deleteTeam (params Quorum (Deleted, tid)) - where - removeConvs :: Page TeamConversation -> Galley r () - removeConvs cnvs = do - for_ (result cnvs) $ removeTeamConv tid . view conversationId - unless (null $ result cnvs) $ - removeConvs =<< liftClient (nextPage cnvs) - - removeTeamMembers :: - Page - ( UserId, - Permissions, - Maybe UserId, - Maybe UTCTimeMillis, - Maybe UserLegalHoldStatus - ) -> - Galley r () - removeTeamMembers mems = do - mapM_ (removeTeamMember tid . view _1) (result mems) - unless (null $ result mems) $ - removeTeamMembers =<< liftClient (nextPage mems) - -addTeamMember :: TeamId -> TeamMember -> Galley r () -addTeamMember t m = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery - Cql.insertTeamMember - ( t, - m ^. userId, - m ^. permissions, - m ^? invitation . _Just . _1, - m ^? invitation . _Just . _2 - ) - addPrepQuery Cql.insertUserTeam (m ^. userId, t) - when (m `hasPermission` SetBilling) $ - addPrepQuery Cql.insertBillingTeamMember (t, m ^. userId) - -updateTeamMember :: - -- | Old permissions, used for maintaining 'billing_team_member' table - Permissions -> - TeamId -> - UserId -> - -- | New permissions - Permissions -> - Galley r () -updateTeamMember oldPerms tid uid newPerms = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.updatePermissions (newPerms, tid, uid) - - when (SetBilling `Set.member` acquiredPerms) $ - addPrepQuery Cql.insertBillingTeamMember (tid, uid) - - when (SetBilling `Set.member` lostPerms) $ - addPrepQuery Cql.deleteBillingTeamMember (tid, uid) - where - permDiff = Set.difference `on` view Teams.self - acquiredPerms = newPerms `permDiff` oldPerms - lostPerms = oldPerms `permDiff` newPerms - -removeTeamMember :: TeamId -> UserId -> Galley r () -removeTeamMember t m = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.deleteTeamMember (t, m) - addPrepQuery Cql.deleteUserTeam (m, t) - addPrepQuery Cql.deleteBillingTeamMember (t, m) - -listBillingTeamMembers :: TeamId -> Galley r [UserId] -listBillingTeamMembers tid = - fmap runIdentity - <$> retry x1 (query Cql.listBillingTeamMembers (params Quorum (Identity tid))) - -removeTeamConv :: TeamId -> ConvId -> Galley r () -removeTeamConv tid cid = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.markConvDeleted (Identity cid) - addPrepQuery Cql.deleteTeamConv (tid, cid) - deleteConversation cid - -updateTeamStatus :: TeamId -> TeamStatus -> Galley r () -updateTeamStatus t s = retry x5 $ write Cql.updateTeamStatus (params Quorum (s, t)) - -updateTeam :: TeamId -> TeamUpdateData -> Galley r () -updateTeam tid u = retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ (u ^. nameUpdate) $ \n -> - addPrepQuery Cql.updateTeamName (fromRange n, tid) - for_ (u ^. iconUpdate) $ \i -> - addPrepQuery Cql.updateTeamIcon (fromRange i, tid) - for_ (u ^. iconKeyUpdate) $ \k -> - addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) - --- Conversations ------------------------------------------------------------ - -isConvAlive :: ConvId -> Galley r Bool -isConvAlive cid = do - result <- retry x1 (query1 Cql.isConvDeleted (params Quorum (Identity cid))) - case runIdentity <$> result of - Nothing -> pure False - Just Nothing -> pure True - Just (Just True) -> pure False - Just (Just False) -> pure True - -conversation :: ConvId -> Galley r (Maybe Conversation) -conversation conv = liftClient $ do - cdata <- UnliftIO.async $ retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - remoteMems <- UnliftIO.async $ lookupRemoteMembersC conv - mbConv <- - toConv conv - <$> membersC conv - <*> UnliftIO.wait remoteMems - <*> UnliftIO.wait cdata - return mbConv >>= conversationGC - -{- "Garbage collect" the conversation, i.e. the conversation may be - marked as deleted, in which case we delete it and return Nothing -} -conversationGC :: - Maybe Conversation -> - Client (Maybe Conversation) -conversationGC conv = case join (convDeleted <$> conv) of - (Just True) -> do - sequence_ $ deleteConversationC . convId <$> conv - return Nothing - _ -> return conv - -localConversations :: [ConvId] -> Galley r [Conversation] -localConversations [] = return [] -localConversations ids = do - cs <- liftClient $ do - convs <- UnliftIO.async fetchConvs - mems <- UnliftIO.async $ memberLists ids - remoteMems <- UnliftIO.async $ remoteMemberLists ids - zipWith4 toConv ids - <$> UnliftIO.wait mems - <*> UnliftIO.wait remoteMems - <*> UnliftIO.wait convs - foldrM flatten [] (zip ids cs) - where - fetchConvs = do - cs <- retry x1 $ query Cql.selectConvs (params Quorum (Identity ids)) - let m = Map.fromList $ map (\(c, t, u, n, a, r, i, d, mt, rm) -> (c, (t, u, n, a, r, i, d, mt, rm))) cs - return $ map (`Map.lookup` m) ids - flatten (i, c) cc = case c of - Nothing -> do - Log.warn $ Log.msg ("No conversation for: " <> toByteString i) - return cc - Just c' -> return (c' : cc) - -toConv :: - ConvId -> - [LocalMember] -> - [RemoteMember] -> - Maybe (ConvType, UserId, Maybe (Set Access), Maybe AccessRole, Maybe Text, Maybe TeamId, Maybe Bool, Maybe Milliseconds, Maybe ReceiptMode) -> - Maybe Conversation -toConv cid mms remoteMems conv = - f mms <$> conv - where - f ms (cty, uid, acc, role, nme, ti, del, timer, rm) = Conversation cid cty uid nme (defAccess cty acc) (maybeRole cty role) ms remoteMems ti del timer rm - -conversationMeta :: Domain -> ConvId -> Galley r (Maybe ConversationMetadata) -conversationMeta _localDomain conv = - fmap toConvMeta - <$> retry x1 (query1 Cql.selectConv (params Quorum (Identity conv))) - where - toConvMeta (t, c, a, r, n, i, _, mt, rm) = - ConversationMetadata - t - c - (defAccess t a) - (maybeRole t r) - n - i - mt - rm - --- | Deprecated, use 'localConversationIdsPageFrom' -conversationIdsFrom :: - UserId -> - Maybe ConvId -> - Range 1 1000 Int32 -> - Galley r (ResultSet ConvId) -conversationIdsFrom usr start (fromRange -> max) = - mkResultSet . strip . fmap runIdentity <$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) - Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) - where - strip p = p {result = take (fromIntegral max) (result p)} - -localConversationIdsPageFrom :: - UserId -> - Maybe PagingState -> - Range 1 1000 Int32 -> - Galley r (PageWithState ConvId) -localConversationIdsPageFrom usr pagingState (fromRange -> max) = - fmap runIdentity <$> paginateWithState Cql.selectUserConvs (paramsPagingState Quorum (Identity usr) max pagingState) - -remoteConversationIdsPageFrom :: UserId -> Maybe PagingState -> Int32 -> Galley r (PageWithState (Qualified ConvId)) -remoteConversationIdsPageFrom usr pagingState max = - uncurry (flip Qualified) <$$> paginateWithState Cql.selectUserRemoteConvs (paramsPagingState Quorum (Identity usr) max pagingState) - -localConversationIdRowsForPagination :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley r (Page ConvId) -localConversationIdRowsForPagination usr start (fromRange -> max) = - runIdentity - <$$> case start of - Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) max) - Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) max) - --- | Takes a list of conversation ids and returns those found for the given --- user. -localConversationIdsOf :: UserId -> [ConvId] -> Galley r [ConvId] -localConversationIdsOf usr cids = do - runIdentity <$$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) - --- | Takes a list of remote conversation ids and fetches member status flags --- for the given user -remoteConversationStatus :: - UserId -> - [Remote ConvId] -> - Galley r (Map (Remote ConvId) MemberStatus) -remoteConversationStatus uid = - liftClient - . fmap mconcat - . UnliftIO.pooledMapConcurrentlyN 8 (remoteConversationStatusOnDomainC uid) - . bucketRemote - -remoteConversationStatusOnDomainC :: UserId -> Remote [ConvId] -> Client (Map (Remote ConvId) MemberStatus) -remoteConversationStatusOnDomainC uid rconvs = - Map.fromList . map toPair - <$> query Cql.selectRemoteConvMemberStatuses (params Quorum (uid, tDomain rconvs, tUnqualified rconvs)) - where - toPair (conv, omus, omur, oar, oarr, hid, hidr) = - ( qualifyAs rconvs conv, - toMemberStatus (omus, omur, oar, oarr, hid, hidr) - ) - -conversationsRemote :: UserId -> Galley r [Remote ConvId] -conversationsRemote usr = do - uncurry toRemoteUnsafe <$$> retry x1 (query Cql.selectUserRemoteConvs (params Quorum (Identity usr))) - -createConversation :: - Local UserId -> - Maybe (Range 1 256 Text) -> - [Access] -> - AccessRole -> - ConvSizeChecked UserList UserId -> - Maybe ConvTeamInfo -> - -- | Message timer - Maybe Milliseconds -> - Maybe ReceiptMode -> - RoleName -> - Galley r Conversation -createConversation lusr name acc role others tinfo mtimer recpt othersConversationRole = do - conv <- Id <$> liftIO nextRandom - let lconv = qualifyAs lusr conv - usr = tUnqualified lusr - retry x5 $ case tinfo of - Nothing -> - write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) - Just ti -> batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.insertConv (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Just (cnvTeamId ti), mtimer, recpt) - addPrepQuery Cql.insertTeamConv (cnvTeamId ti, conv, cnvManaged ti) - let newUsers = fmap (,othersConversationRole) (fromConvSize others) - (lmems, rmems) <- addMembers lconv (ulAddLocal (tUnqualified lusr, roleNameWireAdmin) newUsers) - pure $ newConv conv RegularConv usr lmems rmems acc role name (cnvTeamId <$> tinfo) mtimer recpt - -createSelfConversation :: Local UserId -> Maybe (Range 1 256 Text) -> Galley r Conversation -createSelfConversation lusr name = do - let usr = tUnqualified lusr - conv = selfConv usr - lconv = qualifyAs lusr conv - retry x5 $ - write Cql.insertConv (params Quorum (conv, SelfConv, usr, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - (lmems, rmems) <- addMembers lconv (UserList [tUnqualified lusr] []) - pure $ newConv conv SelfConv usr lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing - -createConnectConversation :: - Local x -> - U.UUID U.V4 -> - U.UUID U.V4 -> - Maybe (Range 1 256 Text) -> - Galley r Conversation -createConnectConversation loc a b name = do - let conv = localOne2OneConvId a b - lconv = qualifyAs loc conv - a' = Id . U.unpack $ a - retry x5 $ - write Cql.insertConv (params Quorum (conv, ConnectConv, a', privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - (lmems, rmems) <- addMembers lconv (UserList [a'] []) - pure $ newConv conv ConnectConv a' lmems rmems [PrivateAccess] privateRole name Nothing Nothing Nothing - -createConnectConversationWithRemote :: - Local ConvId -> - Local UserId -> - UserList UserId -> - Galley r () -createConnectConversationWithRemote lconvId creator m = do - retry x5 $ - write Cql.insertConv (params Quorum (tUnqualified lconvId, ConnectConv, tUnqualified creator, privateOnly, privateRole, Nothing, Nothing, Nothing, Nothing)) - -- We add only one member, second one gets added later, - -- when the other user accepts the connection request. - void $ addMembers lconvId m - -createLegacyOne2OneConversation :: - Local x -> - U.UUID U.V4 -> - U.UUID U.V4 -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Galley r Conversation -createLegacyOne2OneConversation loc a b name ti = do - let conv = localOne2OneConvId a b - lconv = qualifyAs loc conv - a' = Id (U.unpack a) - b' = Id (U.unpack b) - createOne2OneConversation - lconv - (qualifyAs loc a') - (qUntagged (qualifyAs loc b')) - name - ti - -createOne2OneConversation :: - Local ConvId -> - Local UserId -> - Qualified UserId -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Galley r Conversation -createOne2OneConversation lconv self other name mtid = do - retry x5 $ case mtid of - Nothing -> write Cql.insertConv (params Quorum (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Nothing, Nothing, Nothing)) - Just tid -> batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.insertConv (tUnqualified lconv, One2OneConv, tUnqualified self, privateOnly, privateRole, fromRange <$> name, Just tid, Nothing, Nothing) - addPrepQuery Cql.insertTeamConv (tid, tUnqualified lconv, False) - (lmems, rmems) <- addMembers lconv (toUserList self [qUntagged self, other]) - pure $ newConv (tUnqualified lconv) One2OneConv (tUnqualified self) lmems rmems [PrivateAccess] privateRole name mtid Nothing Nothing - -updateConversation :: ConvId -> Range 1 256 Text -> Galley r () -updateConversation cid name = retry x5 $ write Cql.updateConvName (params Quorum (fromRange name, cid)) - -updateConversationAccess :: ConvId -> ConversationAccessData -> Galley r () -updateConversationAccess cid (ConversationAccessData acc role) = - retry x5 $ - write Cql.updateConvAccess (params Quorum (Set (toList acc), role, cid)) - -updateConversationReceiptMode :: ConvId -> ReceiptMode -> Galley r () -updateConversationReceiptMode cid receiptMode = retry x5 $ write Cql.updateConvReceiptMode (params Quorum (receiptMode, cid)) - -lookupReceiptMode :: ConvId -> Galley r (Maybe ReceiptMode) -lookupReceiptMode cid = join . fmap runIdentity <$> retry x1 (query1 Cql.selectReceiptMode (params Quorum (Identity cid))) - -updateConversationMessageTimer :: ConvId -> Maybe Milliseconds -> Galley r () -updateConversationMessageTimer cid mtimer = retry x5 $ write Cql.updateConvMessageTimer (params Quorum (mtimer, cid)) - -deleteConversation :: ConvId -> Galley r () -deleteConversation = liftClient . deleteConversationC - -deleteConversationC :: ConvId -> Client () -deleteConversationC cid = do - retry x5 $ write Cql.markConvDeleted (params Quorum (Identity cid)) - - localMembers <- membersC cid - for_ (nonEmpty localMembers) $ \ms -> - removeLocalMembersFromLocalConvC cid (lmId <$> ms) - - remoteMembers <- lookupRemoteMembersC cid - for_ (nonEmpty remoteMembers) $ \ms -> - removeRemoteMembersFromLocalConvC cid (rmId <$> ms) - - retry x5 $ write Cql.deleteConv (params Quorum (Identity cid)) - -acceptConnect :: ConvId -> Galley r () -acceptConnect cid = retry x5 $ write Cql.updateConvType (params Quorum (One2OneConv, cid)) - --- | We deduce the conversation ID by adding the 4 components of the V4 UUID --- together pairwise, and then setting the version bits (v4) and variant bits --- (variant 2). This means that we always know what the UUID is for a --- one-to-one conversation which hopefully makes them unique. -localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId -localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b - -newConv :: - ConvId -> - ConvType -> - UserId -> - [LocalMember] -> - [RemoteMember] -> - [Access] -> - AccessRole -> - Maybe (Range 1 256 Text) -> - Maybe TeamId -> - Maybe Milliseconds -> - Maybe ReceiptMode -> - Conversation -newConv cid ct usr mems rMems acc role name tid mtimer rMode = - Conversation - { convId = cid, - convType = ct, - convCreator = usr, - convName = fromRange <$> name, - convAccess = acc, - convAccessRole = role, - convLocalMembers = mems, - convRemoteMembers = rMems, - convTeam = tid, - convDeleted = Nothing, - convMessageTimer = mtimer, - convReceiptMode = rMode - } - -convMetadata :: Conversation -> ConversationMetadata -convMetadata c = - ConversationMetadata - (convType c) - (convCreator c) - (convAccess c) - (convAccessRole c) - (convName c) - (convTeam c) - (convMessageTimer c) - (convReceiptMode c) - -convAccessData :: Conversation -> ConversationAccessData -convAccessData conv = - ConversationAccessData - (Set.fromList (convAccess conv)) - (convAccessRole conv) - -defAccess :: ConvType -> Maybe (Set Access) -> [Access] -defAccess SelfConv Nothing = [PrivateAccess] -defAccess ConnectConv Nothing = [PrivateAccess] -defAccess One2OneConv Nothing = [PrivateAccess] -defAccess RegularConv Nothing = defRegularConvAccess -defAccess SelfConv (Just (Set [])) = [PrivateAccess] -defAccess ConnectConv (Just (Set [])) = [PrivateAccess] -defAccess One2OneConv (Just (Set [])) = [PrivateAccess] -defAccess RegularConv (Just (Set [])) = defRegularConvAccess -defAccess _ (Just (Set (x : xs))) = x : xs - -maybeRole :: ConvType -> Maybe AccessRole -> AccessRole -maybeRole SelfConv _ = privateRole -maybeRole ConnectConv _ = privateRole -maybeRole One2OneConv _ = privateRole -maybeRole RegularConv Nothing = defRole -maybeRole RegularConv (Just r) = r - -defRole :: AccessRole -defRole = ActivatedAccessRole - -defRegularConvAccess :: [Access] -defRegularConvAccess = [InviteAccess] - -privateRole :: AccessRole -privateRole = PrivateAccessRole - -privateOnly :: Set Access -privateOnly = Set [PrivateAccess] - --- Conversation Members ----------------------------------------------------- - -member :: - ConvId -> - UserId -> - Galley r (Maybe LocalMember) -member cnv usr = - (toMember =<<) - <$> retry x1 (query1 Cql.selectMember (params Quorum (cnv, usr))) - -remoteMemberLists :: [ConvId] -> Client [[RemoteMember]] -remoteMemberLists convs = do - mems <- retry x1 $ query Cql.selectRemoteMembers (params Quorum (Identity convs)) - let convMembers = foldr (insert . mkMem) Map.empty mems - return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs - where - insert (conv, mem) acc = - let f = (Just . maybe [mem] (mem :)) - in Map.alter f conv acc - mkMem (cnv, domain, usr, role) = (cnv, toRemoteMember usr domain role) - -toRemoteMember :: UserId -> Domain -> RoleName -> RemoteMember -toRemoteMember u d = RemoteMember (toRemoteUnsafe d u) - -memberLists :: [ConvId] -> Client [[LocalMember]] -memberLists convs = do - mems <- retry x1 $ query Cql.selectMembers (params Quorum (Identity convs)) - let convMembers = foldr (\m acc -> insert (mkMem m) acc) mempty mems - return $ map (\c -> fromMaybe [] (Map.lookup c convMembers)) convs - where - insert (_, Nothing) acc = acc - insert (conv, Just mem) acc = - let f = (Just . maybe [mem] (mem :)) - in Map.alter f conv acc - mkMem (cnv, usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn) = - (cnv, toMember (usr, srv, prv, st, omus, omur, oar, oarr, hid, hidr, crn)) - -members :: ConvId -> Galley r [LocalMember] -members = liftClient . membersC - -membersC :: ConvId -> Client [LocalMember] -membersC = fmap concat . liftClient . memberLists . pure - -lookupRemoteMembers :: ConvId -> Galley r [RemoteMember] -lookupRemoteMembers = liftClient . lookupRemoteMembersC - -lookupRemoteMembersC :: ConvId -> Client [RemoteMember] -lookupRemoteMembersC conv = join <$> remoteMemberLists [conv] - --- | Add a member to a local conversation, as an admin. -addMember :: Local ConvId -> Local UserId -> Galley r [LocalMember] -addMember c u = fst <$> addMembers c (UserList [tUnqualified u] []) - -class ToUserRole a where - toUserRole :: a -> (UserId, RoleName) - -instance ToUserRole (UserId, RoleName) where - toUserRole = id - -instance ToUserRole UserId where - toUserRole uid = (uid, roleNameWireAdmin) - -toQualifiedUserRole :: ToUserRole a => Qualified a -> (Qualified UserId, RoleName) -toQualifiedUserRole = requalify . fmap toUserRole - where - requalify (Qualified (a, role) dom) = (Qualified a dom, role) - --- | Add members to a local conversation. --- Conversation is local, so we can add any member to it (including remote ones). --- When the role is not specified, it defaults to admin. --- Please make sure the conversation doesn't exceed the maximum size! -addMembers :: ToUserRole a => Local ConvId -> UserList a -> Galley r ([LocalMember], [RemoteMember]) -addMembers (tUnqualified -> conv) (fmap toUserRole -> UserList lusers rusers) = do - -- batch statement with 500 users are known to be above the batch size limit - -- and throw "Batch too large" errors. Therefor we chunk requests and insert - -- sequentially. (parallelizing would not aid performance as the partition - -- key, i.e. the convId, is on the same cassandra node) - -- chunk size 32 was chosen to lead to batch statements - -- below the batch threshold - -- With chunk size of 64: - -- [galley] Server warning: Batch for [galley_test.member, galley_test.user] is of size 7040, exceeding specified threshold of 5120 by 1920. - -- - for_ (List.chunksOf 32 lusers) $ \chunk -> do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \(u, r) -> do - -- User is local, too, so we add it to both the member and the user table - addPrepQuery Cql.insertMember (conv, u, Nothing, Nothing, r) - addPrepQuery Cql.insertUserConv (u, conv) - - for_ (List.chunksOf 32 rusers) $ \chunk -> do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \(qUntagged -> Qualified (uid, role) domain) -> do - -- User is remote, so we only add it to the member_remote_user - -- table, but the reverse mapping has to be done on the remote - -- backend; so we assume an additional call to their backend has - -- been (or will be) made separately. See Galley.API.Update.addMembers - addPrepQuery Cql.insertRemoteMember (conv, domain, uid, role) - - pure (map newMemberWithRole lusers, map newRemoteMemberWithRole rusers) - --- | Set local users as belonging to a remote conversation. This is invoked by a --- remote galley when users from the current backend are added to conversations --- on the remote end. -addLocalMembersToRemoteConv :: Remote ConvId -> [UserId] -> Galley r () -addLocalMembersToRemoteConv _ [] = pure () -addLocalMembersToRemoteConv rconv users = do - -- FUTUREWORK: consider using pooledMapConcurrentlyN - for_ (List.chunksOf 32 users) $ \chunk -> - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ chunk $ \u -> - addPrepQuery - Cql.insertUserRemoteConv - (u, tDomain rconv, tUnqualified rconv) - -updateSelfMember :: - Local x -> - Qualified ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMember loc = foldQualified loc updateSelfMemberLocalConv updateSelfMemberRemoteConv - -updateSelfMemberLocalConv :: - Local ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMemberLocalConv lcid luid mup = do - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - for_ (mupOtrMuteStatus mup) $ \ms -> - addPrepQuery - Cql.updateOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, tUnqualified lcid, tUnqualified luid) - for_ (mupOtrArchive mup) $ \a -> - addPrepQuery - Cql.updateOtrMemberArchived - (a, mupOtrArchiveRef mup, tUnqualified lcid, tUnqualified luid) - for_ (mupHidden mup) $ \h -> - addPrepQuery - Cql.updateMemberHidden - (h, mupHiddenRef mup, tUnqualified lcid, tUnqualified luid) - -updateSelfMemberRemoteConv :: - Remote ConvId -> - Local UserId -> - MemberUpdate -> - Galley r () -updateSelfMemberRemoteConv (qUntagged -> Qualified cid domain) luid mup = do - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - for_ (mupOtrMuteStatus mup) $ \ms -> - addPrepQuery - Cql.updateRemoteOtrMemberMutedStatus - (ms, mupOtrMuteRef mup, domain, cid, tUnqualified luid) - for_ (mupOtrArchive mup) $ \a -> - addPrepQuery - Cql.updateRemoteOtrMemberArchived - (a, mupOtrArchiveRef mup, domain, cid, tUnqualified luid) - for_ (mupHidden mup) $ \h -> - addPrepQuery - Cql.updateRemoteMemberHidden - (h, mupHiddenRef mup, domain, cid, tUnqualified luid) - -updateOtherMember :: - Local x -> - Qualified ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMember loc = foldQualified loc updateOtherMemberLocalConv updateOtherMemberRemoteConv - -updateOtherMemberLocalConv :: - Local ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMemberLocalConv lcid quid omu = - do - let addQuery r - | tDomain lcid == qDomain quid = - addPrepQuery - Cql.updateMemberConvRoleName - (r, tUnqualified lcid, qUnqualified quid) - | otherwise = - addPrepQuery - Cql.updateRemoteMemberConvRoleName - (r, tUnqualified lcid, qDomain quid, qUnqualified quid) - retry x5 . batch $ do - setType BatchUnLogged - setConsistency Quorum - traverse_ addQuery (omuConvRoleName omu) - --- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQCORE-887 -updateOtherMemberRemoteConv :: - Remote ConvId -> - Qualified UserId -> - OtherMemberUpdate -> - Galley r () -updateOtherMemberRemoteConv _ _ _ = pure () - --- | Select only the members of a remote conversation from a list of users. --- Return the filtered list and a boolean indicating whether the all the input --- users are members. -filterRemoteConvMembers :: - [UserId] -> - Qualified ConvId -> - Galley r ([UserId], Bool) -filterRemoteConvMembers users (Qualified conv dom) = - liftClient $ - fmap Data.Monoid.getAll - . foldMap (\muser -> (muser, Data.Monoid.All (not (null muser)))) - <$> UnliftIO.pooledMapConcurrentlyN 8 filterMember users - where - filterMember :: UserId -> Client [UserId] - filterMember user = - fmap (map runIdentity) - . retry x1 - $ query Cql.selectRemoteConvMembers (params Quorum (user, dom, conv)) - -removeLocalMembersFromLocalConv :: ConvId -> NonEmpty UserId -> Galley r () -removeLocalMembersFromLocalConv cnv = liftClient . removeLocalMembersFromLocalConvC cnv - -removeLocalMembersFromLocalConvC :: ConvId -> NonEmpty UserId -> Client () -removeLocalMembersFromLocalConvC cnv victims = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \victim -> do - addPrepQuery Cql.removeMember (cnv, victim) - addPrepQuery Cql.deleteUserConv (victim, cnv) - -removeRemoteMembersFromLocalConv :: ConvId -> NonEmpty (Remote UserId) -> Galley r () -removeRemoteMembersFromLocalConv cnv = liftClient . removeRemoteMembersFromLocalConvC cnv - -removeRemoteMembersFromLocalConvC :: ConvId -> NonEmpty (Remote UserId) -> Client () -removeRemoteMembersFromLocalConvC cnv victims = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \(qUntagged -> Qualified uid domain) -> - addPrepQuery Cql.removeRemoteMember (cnv, domain, uid) - -removeLocalMembersFromRemoteConv :: - -- | The conversation to remove members from - Remote ConvId -> - -- | Members to remove local to this backend - [UserId] -> - Galley r () -removeLocalMembersFromRemoteConv _ [] = pure () -removeLocalMembersFromRemoteConv (qUntagged -> Qualified conv convDomain) victims = - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - for_ victims $ \u -> addPrepQuery Cql.deleteUserRemoteConv (u, convDomain, conv) - -removeMember :: UserId -> ConvId -> Galley r () -removeMember usr cnv = retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery Cql.removeMember (cnv, usr) - addPrepQuery Cql.deleteUserConv (usr, cnv) - -newMember :: UserId -> LocalMember -newMember u = newMemberWithRole (u, roleNameWireAdmin) - -newMemberWithRole :: (UserId, RoleName) -> LocalMember -newMemberWithRole (u, r) = - LocalMember - { lmId = u, - lmService = Nothing, - lmStatus = defMemberStatus, - lmConvRoleName = r - } - -newRemoteMemberWithRole :: Remote (UserId, RoleName) -> RemoteMember -newRemoteMemberWithRole ur@(qUntagged -> (Qualified (u, r) _)) = - RemoteMember - { rmId = qualifyAs ur u, - rmConvRoleName = r - } - -toMemberStatus :: - ( -- otr muted - Maybe MutedStatus, - Maybe Text, - -- otr archived - Maybe Bool, - Maybe Text, - -- hidden - Maybe Bool, - Maybe Text - ) -> - MemberStatus -toMemberStatus (omus, omur, oar, oarr, hid, hidr) = - MemberStatus - { msOtrMutedStatus = omus, - msOtrMutedRef = omur, - msOtrArchived = fromMaybe False oar, - msOtrArchivedRef = oarr, - msHidden = fromMaybe False hid, - msHiddenRef = hidr - } - -toMember :: - ( UserId, - Maybe ServiceId, - Maybe ProviderId, - Maybe Cql.MemberStatus, - -- otr muted - Maybe MutedStatus, - Maybe Text, - -- otr archived - Maybe Bool, - Maybe Text, - -- hidden - Maybe Bool, - Maybe Text, - -- conversation role name - Maybe RoleName - ) -> - Maybe LocalMember -toMember (usr, srv, prv, Just 0, omus, omur, oar, oarr, hid, hidr, crn) = - Just $ - LocalMember - { lmId = usr, - lmService = newServiceRef <$> srv <*> prv, - lmStatus = toMemberStatus (omus, omur, oar, oarr, hid, hidr), - lmConvRoleName = fromMaybe roleNameWireAdmin crn - } -toMember _ = Nothing - --- Clients ------------------------------------------------------------------ - -updateClient :: Bool -> UserId -> ClientId -> Galley r () -updateClient add usr cls = do - let q = if add then Cql.addMemberClient else Cql.rmMemberClient - retry x5 $ write (q cls) (params Quorum (Identity usr)) - --- Do, at most, 16 parallel lookups of up to 128 users each -lookupClients :: [UserId] -> Galley r Clients -lookupClients = liftClient . lookupClients' - --- This is only used by tests -lookupClients' :: [UserId] -> Client Clients -lookupClients' users = - Clients.fromList . concat . concat - <$> forM (chunksOf 2048 users) (UnliftIO.mapConcurrently getClients . chunksOf 128) - where - getClients us = - map (second fromSet) - <$> retry x1 (query Cql.selectClients (params Quorum (Identity us))) - -eraseClients :: UserId -> Galley r () -eraseClients user = retry x5 (write Cql.rmClients (params Quorum (Identity user))) - --- Internal utilities - --- | Construct 'TeamMember' from database tuple. --- If FeatureLegalHoldWhitelistTeamsAndImplicitConsent is enabled set UserLegalHoldDisabled --- if team is whitelisted. --- --- Throw an exception if one of invitation timestamp and inviter is 'Nothing' and the --- other is 'Just', which can only be caused by inconsistent database content. -newTeamMember' :: TeamId -> (UserId, Permissions, Maybe UserId, Maybe UTCTimeMillis, Maybe UserLegalHoldStatus) -> Galley r TeamMember -newTeamMember' tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatus -> lhStatus) = do - mk minvu minvt >>= maybeGrant - where - maybeGrant :: TeamMember -> Galley r TeamMember - maybeGrant m = - ifM - (isTeamLegalholdWhitelisted tid) - (pure (grantImplicitConsent m)) - (pure m) - - grantImplicitConsent :: TeamMember -> TeamMember - grantImplicitConsent = - legalHoldStatus %~ \case - UserLegalHoldNoConsent -> UserLegalHoldDisabled - -- the other cases don't change; we just enumerate them to catch future changes in - -- 'UserLegalHoldStatus' better. - UserLegalHoldDisabled -> UserLegalHoldDisabled - UserLegalHoldPending -> UserLegalHoldPending - UserLegalHoldEnabled -> UserLegalHoldEnabled - - mk (Just invu) (Just invt) = pure $ TeamMember uid perms (Just (invu, invt)) lhStatus - mk Nothing Nothing = pure $ TeamMember uid perms Nothing lhStatus - mk _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." - --- | Invoke the given action with a list of TeamMemberRows IDs --- which are looked up based on: -withTeamMembersWithChunks :: - TeamId -> - ([TeamMember] -> Galley r ()) -> - Galley r () -withTeamMembersWithChunks tid action = do - mems <- teamMembersForPagination tid Nothing (unsafeRange hardTruncationLimit) - handleMembers mems - where - handleMembers mems = do - tMembers <- mapM (newTeamMember' tid) (result mems) - action tMembers - when (hasMore mems) $ - handleMembers =<< liftClient (nextPage mems) -{-# INLINE withTeamMembersWithChunks #-} diff --git a/services/galley/src/Galley/Data/Conversation.hs b/services/galley/src/Galley/Data/Conversation.hs new file mode 100644 index 00000000000..b1e149b6513 --- /dev/null +++ b/services/galley/src/Galley/Data/Conversation.hs @@ -0,0 +1,101 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Conversation + ( -- * Data Conversation types + Conversation (..), + NewConversation, + + -- * Utilities + isSelfConv, + isO2OConv, + isTeamConv, + isConvDeleted, + selfConv, + localOne2OneConvId, + convMetadata, + convAccessData, + defRole, + maybeRole, + privateRole, + defRegularConvAccess, + ) +where + +import Data.Id +import qualified Data.Set as Set +import qualified Data.UUID.Tagged as U +import Galley.Cassandra.Instances () +import Galley.Data.Conversation.Types +import Imports hiding (Set) +import Wire.API.Conversation hiding (Conversation) + +isSelfConv :: Conversation -> Bool +isSelfConv = (SelfConv ==) . convType + +isO2OConv :: Conversation -> Bool +isO2OConv = (One2OneConv ==) . convType + +isTeamConv :: Conversation -> Bool +isTeamConv = isJust . convTeam + +isConvDeleted :: Conversation -> Bool +isConvDeleted = fromMaybe False . convDeleted + +selfConv :: UserId -> ConvId +selfConv uid = Id (toUUID uid) + +-- | We deduce the conversation ID by adding the 4 components of the V4 UUID +-- together pairwise, and then setting the version bits (v4) and variant bits +-- (variant 2). This means that we always know what the UUID is for a +-- one-to-one conversation which hopefully makes them unique. +localOne2OneConvId :: U.UUID U.V4 -> U.UUID U.V4 -> ConvId +localOne2OneConvId a b = Id . U.unpack $ U.addv4 a b + +convMetadata :: Conversation -> ConversationMetadata +convMetadata c = + ConversationMetadata + (convType c) + (convCreator c) + (convAccess c) + (convAccessRole c) + (convName c) + (convTeam c) + (convMessageTimer c) + (convReceiptMode c) + +convAccessData :: Conversation -> ConversationAccessData +convAccessData conv = + ConversationAccessData + (Set.fromList (convAccess conv)) + (convAccessRole conv) + +defRole :: AccessRole +defRole = ActivatedAccessRole + +maybeRole :: ConvType -> Maybe AccessRole -> AccessRole +maybeRole SelfConv _ = privateRole +maybeRole ConnectConv _ = privateRole +maybeRole One2OneConv _ = privateRole +maybeRole RegularConv Nothing = defRole +maybeRole RegularConv (Just r) = r + +privateRole :: AccessRole +privateRole = PrivateAccessRole + +defRegularConvAccess :: [Access] +defRegularConvAccess = [InviteAccess] diff --git a/services/galley/src/Galley/Data/Conversation/Types.hs b/services/galley/src/Galley/Data/Conversation/Types.hs new file mode 100644 index 00000000000..6fb47c221da --- /dev/null +++ b/services/galley/src/Galley/Data/Conversation/Types.hs @@ -0,0 +1,61 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Conversation.Types where + +import Data.Id +import Data.Misc +import Data.Range +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Galley.Validation +import Imports +import Wire.API.Conversation hiding (Conversation) +import Wire.API.Conversation.Role + +-- | Internal conversation type, corresponding directly to database schema. +-- Should never be sent to users (and therefore doesn't have 'FromJSON' or +-- 'ToJSON' instances). +data Conversation = Conversation + { convId :: ConvId, + convType :: ConvType, + convCreator :: UserId, + convName :: Maybe Text, + convAccess :: [Access], + convAccessRole :: AccessRole, + convLocalMembers :: [LocalMember], + convRemoteMembers :: [RemoteMember], + convTeam :: Maybe TeamId, + convDeleted :: Maybe Bool, + -- | Global message timer + convMessageTimer :: Maybe Milliseconds, + convReceiptMode :: Maybe ReceiptMode + } + deriving (Show) + +data NewConversation = NewConversation + { ncType :: ConvType, + ncCreator :: UserId, + ncAccess :: [Access], + ncAccessRole :: AccessRole, + ncName :: Maybe (Range 1 256 Text), + ncTeam :: Maybe TeamId, + ncMessageTimer :: Maybe Milliseconds, + ncReceiptMode :: Maybe ReceiptMode, + ncUsers :: ConvSizeChecked UserList UserId, + ncRole :: RoleName + } diff --git a/services/galley/src/Galley/Data/Scope.hs b/services/galley/src/Galley/Data/Scope.hs new file mode 100644 index 00000000000..e966ca284ee --- /dev/null +++ b/services/galley/src/Galley/Data/Scope.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Data.Scope where + +import Cassandra hiding (Value) +import Imports + +data Scope = ReusableCode + deriving (Eq, Show, Generic) + +instance Cql Scope where + ctype = Tagged IntColumn + + toCql ReusableCode = CqlInt 1 + + fromCql (CqlInt 1) = return ReusableCode + fromCql _ = Left "unknown Scope" diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index f47bf123648..a8c21ead628 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -17,32 +17,16 @@ module Galley.Data.Services ( -- * BotMember - BotMember, - fromBotMember, + BotMember (..), newBotMember, botMemId, botMemService, - addBotMember, - - -- * Service - insertService, - lookupService, - deleteService, ) where -import Cassandra -import Control.Lens import Data.Id -import Data.Qualified -import Data.Time.Clock -import Galley.App -import Galley.Data (newMember) -import Galley.Data.Instances () -import Galley.Data.Queries import Galley.Types hiding (Conversation) import Galley.Types.Bot -import Galley.Types.Conversations.Roles import Imports -- BotMember ------------------------------------------------------------------ @@ -66,47 +50,3 @@ botMemId = BotId . lmId . fromBotMember botMemService :: BotMember -> ServiceRef botMemService = fromJust . lmService . fromBotMember - -addBotMember :: Qualified UserId -> ServiceRef -> BotId -> ConvId -> UTCTime -> Galley r (Event, BotMember) -addBotMember qorig s bot cnv now = do - retry x5 . batch $ do - setType BatchLogged - setConsistency Quorum - addPrepQuery insertUserConv (botUserId bot, cnv) - addPrepQuery insertBot (cnv, bot, sid, pid) - return (e, BotMember mem) - where - pid = s ^. serviceRefProvider - sid = s ^. serviceRefId - -- FUTUREWORK: support adding bots to a remote conversation - qcnv = Qualified cnv localDomain - localDomain = qDomain qorig - -- FUTUREWORK: support remote bots - e = Event MemberJoin qcnv qorig now (EdMembersJoin . SimpleMembers $ (fmap toSimpleMember [botUserId bot])) - mem = (newMember (botUserId bot)) {lmService = Just s} - - toSimpleMember :: UserId -> SimpleMember - toSimpleMember u = SimpleMember (Qualified u localDomain) roleNameWireAdmin - --- Service -------------------------------------------------------------------- - -insertService :: MonadClient m => Service -> m () -insertService s = do - let sid = s ^. serviceRef . serviceRefId - let pid = s ^. serviceRef . serviceRefProvider - let tok = s ^. serviceToken - let url = s ^. serviceUrl - let fps = Set (s ^. serviceFingerprints) - let ena = s ^. serviceEnabled - retry x5 $ write insertSrv (params Quorum (pid, sid, url, tok, fps, ena)) - -lookupService :: MonadClient m => ServiceRef -> m (Maybe Service) -lookupService s = - fmap toService - <$> retry x1 (query1 selectSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) - where - toService (url, tok, Set fps, ena) = - newService s url tok fps & set serviceEnabled ena - -deleteService :: MonadClient m => ServiceRef -> m () -deleteService s = retry x5 (write rmSrv (params Quorum (s ^. serviceRefProvider, s ^. serviceRefId))) diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 93109ac3144..e7ab337d0f5 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -17,27 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Data.TeamFeatures - ( getFeatureStatusNoConfig, - setFeatureStatusNoConfig, - getApplockFeatureStatus, - setApplockFeatureStatus, - HasStatusCol (..), - ) -where +module Galley.Data.TeamFeatures (HasStatusCol (..)) where -import Cassandra -import Data.Id -import Galley.Data.Instances () import Imports import Wire.API.Team.Feature - ( TeamFeatureName (..), - TeamFeatureStatus, - TeamFeatureStatusNoConfig (..), - TeamFeatureStatusValue (..), - TeamFeatureStatusWithConfig (..), - ) -import qualified Wire.API.Team.Feature as Public -- | Because not all so called team features are actually team-level features, -- not all of them have a corresponding column in the database. Therefore, @@ -66,75 +47,4 @@ instance HasStatusCol 'TeamFeatureFileSharing where statusCol = "file_sharing" instance HasStatusCol 'TeamFeatureConferenceCalling where statusCol = "conference_calling" -getFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) m. - ( MonadClient m, - Public.FeatureHasNoConfig a, - HasStatusCol a - ) => - TeamId -> - m (Maybe (TeamFeatureStatus a)) -getFeatureStatusNoConfig tid = do - let q = query1 select (params Quorum (Identity tid)) - mStatusValue <- (>>= runIdentity) <$> retry x1 q - pure $ TeamFeatureStatusNoConfig <$> mStatusValue - where - select :: PrepQuery R (Identity TeamId) (Identity (Maybe TeamFeatureStatusValue)) - select = fromString $ "select " <> statusCol @a <> " from team_features where team_id = ?" - -setFeatureStatusNoConfig :: - forall (a :: Public.TeamFeatureName) m. - ( MonadClient m, - Public.FeatureHasNoConfig a, - HasStatusCol a - ) => - TeamId -> - TeamFeatureStatus a -> - m (TeamFeatureStatus a) -setFeatureStatusNoConfig tid status = do - let flag = Public.tfwoStatus status - retry x5 $ write update (params Quorum (flag, tid)) - pure status - where - update :: PrepQuery W (TeamFeatureStatusValue, TeamId) () - update = fromString $ "update team_features set " <> statusCol @a <> " = ? where team_id = ?" - -getApplockFeatureStatus :: - forall m. - (MonadClient m) => - TeamId -> - m (Maybe (TeamFeatureStatus 'Public.TeamFeatureAppLock)) -getApplockFeatureStatus tid = do - let q = query1 select (params Quorum (Identity tid)) - mTuple <- retry x1 q - pure $ - mTuple >>= \(mbStatusValue, mbEnforce, mbTimeout) -> - TeamFeatureStatusWithConfig <$> mbStatusValue <*> (Public.TeamFeatureAppLockConfig <$> mbEnforce <*> mbTimeout) - where - select :: PrepQuery R (Identity TeamId) (Maybe TeamFeatureStatusValue, Maybe Public.EnforceAppLock, Maybe Int32) - select = - fromString $ - "select " <> statusCol @'Public.TeamFeatureAppLock <> ", app_lock_enforce, app_lock_inactivity_timeout_secs " - <> "from team_features where team_id = ?" - -setApplockFeatureStatus :: - (MonadClient m) => - TeamId -> - TeamFeatureStatus 'Public.TeamFeatureAppLock -> - m (TeamFeatureStatus 'Public.TeamFeatureAppLock) -setApplockFeatureStatus tid status = do - let statusValue = Public.tfwcStatus status - enforce = Public.applockEnforceAppLock . Public.tfwcConfig $ status - timeout = Public.applockInactivityTimeoutSecs . Public.tfwcConfig $ status - retry x5 $ write update (params Quorum (statusValue, enforce, timeout, tid)) - pure status - where - update :: PrepQuery W (TeamFeatureStatusValue, Public.EnforceAppLock, Int32, TeamId) () - update = - fromString $ - "update team_features set " - <> statusCol @'Public.TeamFeatureAppLock - <> " = ?, " - <> "app_lock_enforce = ?, " - <> "app_lock_inactivity_timeout_secs = ? " - <> "where team_id = ?" +instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_deleting_messages_status" diff --git a/services/galley/src/Galley/Data/TeamNotifications.hs b/services/galley/src/Galley/Data/TeamNotifications.hs index d5c7689538f..faeff5edd97 100644 --- a/services/galley/src/Galley/Data/TeamNotifications.hs +++ b/services/galley/src/Galley/Data/TeamNotifications.hs @@ -23,21 +23,9 @@ -- -- FUTUREWORK: this is a work-around because it only solves *some* problems with team events. -- We should really use a scalable message queue instead. -module Galley.Data.TeamNotifications - ( ResultPage (..), - add, - fetch, - ) -where +module Galley.Data.TeamNotifications (ResultPage (..)) where -import Cassandra as C -import qualified Data.Aeson as JSON -import Data.Id -import Data.List1 (List1) -import Data.Range (Range, fromRange) -import Data.Sequence (Seq, ViewL (..), ViewR (..), (<|), (><)) -import qualified Data.Sequence as Seq -import Galley.App +import Data.Sequence (Seq) import Gundeck.Types.Notification import Imports @@ -49,92 +37,3 @@ data ResultPage = ResultPage -- last notification in 'resultSeq'. resultHasMore :: !Bool } - --- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned -add :: - TeamId -> - NotificationId -> - List1 JSON.Object -> - Galley r () -add tid nid (Blob . JSON.encode -> payload) = - write cqlInsert (params Quorum (tid, nid, payload, notificationTTLSeconds)) & retry x5 - where - cqlInsert :: PrepQuery W (TeamId, NotificationId, Blob, Int32) () - cqlInsert = - "INSERT INTO team_notifications \ - \(team, id, payload) VALUES \ - \(?, ?, ?) \ - \USING TTL ?" - -notificationTTLSeconds :: Int32 -notificationTTLSeconds = 24192200 - -fetch :: TeamId -> Maybe NotificationId -> Range 1 10000 Int32 -> Galley r ResultPage -fetch tid since (fromRange -> size) = do - -- We always need to look for one more than requested in order to correctly - -- report whether there are more results. - let size' = bool (+ 1) (+ 2) (isJust since) size - page1 <- case TimeUuid . toUUID <$> since of - Nothing -> paginate cqlStart (paramsP Quorum (Identity tid) size') & retry x1 - Just s -> paginate cqlSince (paramsP Quorum (tid, s) size') & retry x1 - -- Collect results, requesting more pages until we run out of data - -- or have found size + 1 notifications (not including the 'since'). - let isize = fromIntegral size' :: Int - (ns, more) <- collect Seq.empty isize page1 - -- Drop the extra element from the end as well. Keep the inclusive start - -- value in the response (if a 'since' was given and found). - -- This can probably simplified a lot further, but we need to understand - -- 'Seq' in order to do that. If you find a bug, this may be a good - -- place to start looking. - return $! case Seq.viewl (trim (isize - 1) ns) of - EmptyL -> ResultPage Seq.empty False - (x :< xs) -> ResultPage (x <| xs) more - where - collect :: - Seq QueuedNotification -> - Int -> - Page (TimeUuid, Blob) -> - Galley r (Seq QueuedNotification, Bool) - collect acc num page = - let ns = splitAt num $ foldr toNotif [] (result page) - nseq = Seq.fromList (fst ns) - more = hasMore page - num' = num - Seq.length nseq - acc' = acc >< nseq - in if not more || num' == 0 - then return (acc', more || not (null (snd ns))) - else liftClient (nextPage page) >>= collect acc' num' - trim :: Int -> Seq a -> Seq a - trim l ns - | Seq.length ns <= l = ns - | otherwise = case Seq.viewr ns of - EmptyR -> ns - xs :> _ -> xs - cqlStart :: PrepQuery R (Identity TeamId) (TimeUuid, Blob) - cqlStart = - "SELECT id, payload \ - \FROM team_notifications \ - \WHERE team = ? \ - \ORDER BY id ASC" - cqlSince :: PrepQuery R (TeamId, TimeUuid) (TimeUuid, Blob) - cqlSince = - "SELECT id, payload \ - \FROM team_notifications \ - \WHERE team = ? AND id >= ? \ - \ORDER BY id ASC" - -------------------------------------------------------------------------------- --- Conversions - -toNotif :: (TimeUuid, Blob) -> [QueuedNotification] -> [QueuedNotification] -toNotif (i, b) ns = - maybe - ns - (\p1 -> queuedNotification notifId p1 : ns) - ( JSON.decode' (fromBlob b) - -- FUTUREWORK: this is from the database, so it's slightly more ok to ignore parse - -- errors than if it's data provided by a client. it would still be better to have an - -- error entry in the log file and crash, rather than ignore the error and continue. - ) - where - notifId = Id (fromTimeUuid i) diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 0bfee9b74b9..3aae3e50eed 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -33,54 +33,17 @@ module Galley.Data.Types where import Brig.Types.Code -import Cassandra hiding (Value) import qualified Data.ByteString as BS import Data.ByteString.Conversion import Data.Id -import Data.Misc (Milliseconds) import Data.Range import qualified Data.Text.Ascii as Ascii -import Galley.Types (Access, AccessRole, ConvType (..), LocalMember, ReceiptMode) -import Galley.Types.Conversations.Members (RemoteMember) +import Galley.Data.Conversation +import Galley.Data.Scope import Imports import OpenSSL.EVP.Digest (digestBS, getDigestByName) import OpenSSL.Random (randBytes) --- | Internal conversation type, corresponding directly to database schema. --- Should never be sent to users (and therefore doesn't have 'FromJSON' or --- 'ToJSON' instances). -data Conversation = Conversation - { convId :: ConvId, - convType :: ConvType, - convCreator :: UserId, - convName :: Maybe Text, - convAccess :: [Access], - convAccessRole :: AccessRole, - convLocalMembers :: [LocalMember], - convRemoteMembers :: [RemoteMember], - convTeam :: Maybe TeamId, - convDeleted :: Maybe Bool, - -- | Global message timer - convMessageTimer :: Maybe Milliseconds, - convReceiptMode :: Maybe ReceiptMode - } - deriving (Show) - -isSelfConv :: Conversation -> Bool -isSelfConv = (SelfConv ==) . convType - -isO2OConv :: Conversation -> Bool -isO2OConv = (One2OneConv ==) . convType - -isTeamConv :: Conversation -> Bool -isTeamConv = isJust . convTeam - -isConvDeleted :: Conversation -> Bool -isConvDeleted = fromMaybe False . convDeleted - -selfConv :: UserId -> ConvId -selfConv uid = Id (toUUID uid) - -------------------------------------------------------------------------------- -- Code @@ -93,17 +56,6 @@ data Code = Code } deriving (Eq, Show, Generic) -data Scope = ReusableCode - deriving (Eq, Show, Generic) - -instance Cql Scope where - ctype = Tagged IntColumn - - toCql ReusableCode = CqlInt 1 - - fromCql (CqlInt 1) = return ReusableCode - fromCql _ = Left "unknown Scope" - toCode :: Key -> Scope -> (Value, Int32, ConvId) -> Code toCode k s (val, ttl, cnv) = Code diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 78aceb69541..f56cde0885b 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -19,37 +19,35 @@ module Galley.Effects ( -- * Effects needed in Galley GalleyEffects1, - -- * Internal services - Intra, - interpretIntra, - - -- * Brig + -- * Effects to access the Intra API + BotAccess, BrigAccess, - interpretBrig, - - -- * Federator FederatorAccess, - interpretFederator, - - -- * Spar - SparAccess, - interpretSpar, - - -- * Gundeck GundeckAccess, - interpretGundeck, + SparAccess, -- * External services ExternalAccess, - interpretExternal, - - -- * Bot API - BotAccess, - interpretBot, -- * Fire-and-forget async FireAndForget, - interpretFireAndForget, + + -- * Store effects + ClientStore, + CodeStore, + ConversationStore, + CustomBackendStore, + LegalHoldStore, + MemberStore, + SearchVisibilityStore, + ServiceStore, + TeamFeatureStore, + TeamMemberStore, + TeamNotificationStore, + TeamStore, + + -- * Paging effects + ListItems, -- * Polysemy re-exports Member, @@ -57,53 +55,64 @@ module Galley.Effects ) where +import Data.Id +import Data.Qualified +import Galley.API.Error +import Galley.Cassandra.Paging +import Galley.Effects.BotAccess +import Galley.Effects.BrigAccess +import Galley.Effects.ClientStore +import Galley.Effects.CodeStore +import Galley.Effects.ConversationStore +import Galley.Effects.CustomBackendStore +import Galley.Effects.ExternalAccess +import Galley.Effects.FederatorAccess import Galley.Effects.FireAndForget -import Imports +import Galley.Effects.GundeckAccess +import Galley.Effects.LegalHoldStore +import Galley.Effects.ListItems +import Galley.Effects.MemberStore +import Galley.Effects.SearchVisibilityStore +import Galley.Effects.ServiceStore +import Galley.Effects.SparAccess +import Galley.Effects.TeamFeatureStore +import Galley.Effects.TeamMemberStore +import Galley.Effects.TeamNotificationStore +import Galley.Effects.TeamStore +import qualified Network.Wai.Utilities as Wai import Polysemy +import Polysemy.Error +import Polysemy.Internal -data Intra m a - -interpretIntra :: Sem (Intra ': r) a -> Sem r a -interpretIntra = interpret $ \case - -data BrigAccess m a - -interpretBrig :: Sem (BrigAccess ': r) a -> Sem r a -interpretBrig = interpret $ \case - -data GundeckAccess m a - -interpretGundeck :: Sem (GundeckAccess ': r) a -> Sem r a -interpretGundeck = interpret $ \case - -data ExternalAccess m a - -interpretExternal :: Sem (ExternalAccess ': r) a -> Sem r a -interpretExternal = interpret $ \case - -data FederatorAccess m a - -interpretFederator :: Sem (FederatorAccess ': r) a -> Sem r a -interpretFederator = interpret $ \case - -data SparAccess m a - -interpretSpar :: Sem (SparAccess ': r) a -> Sem r a -interpretSpar = interpret $ \case - -data BotAccess m a - -interpretBot :: Sem (BotAccess ': r) a -> Sem r a -interpretBot = interpret $ \case - --- All the possible high-level effects. -type GalleyEffects1 = +type NonErrorGalleyEffects1 = '[ BrigAccess, GundeckAccess, SparAccess, ExternalAccess, FederatorAccess, BotAccess, - Intra, - FireAndForget + FireAndForget, + ClientStore, + CodeStore, + ConversationStore, + CustomBackendStore, + LegalHoldStore, + MemberStore, + SearchVisibilityStore, + ServiceStore, + TeamFeatureStore, + TeamNotificationStore, + TeamStore, + TeamMemberStore InternalPaging, + ListItems CassandraPaging ConvId, + ListItems CassandraPaging (Remote ConvId), + ListItems LegacyPaging ConvId, + ListItems LegacyPaging TeamId, + ListItems InternalPaging TeamId ] + +-- All the possible high-level effects. +type GalleyEffects1 = + Append + NonErrorGalleyEffects1 + (Append AllErrorEffects '[Error Wai.Error]) diff --git a/services/galley/src/Galley/Effects/BotAccess.hs b/services/galley/src/Galley/Effects/BotAccess.hs new file mode 100644 index 00000000000..819fde49082 --- /dev/null +++ b/services/galley/src/Galley/Effects/BotAccess.hs @@ -0,0 +1,26 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.BotAccess where + +import Data.Id +import Polysemy + +data BotAccess m a where + DeleteBot :: ConvId -> BotId -> BotAccess m () + +makeSem ''BotAccess diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs new file mode 100644 index 00000000000..5741e3b8b15 --- /dev/null +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -0,0 +1,113 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.BrigAccess + ( -- * Brig access effect + BrigAccess (..), + + -- * Connections + getConnectionsUnqualified, + getConnectionsUnqualifiedBidi, + getConnections, + putConnectionInternal, + + -- * Users + reauthUser, + lookupActivatedUsers, + getUser, + getUsers, + deleteUser, + getContactList, + getRichInfoMultiUser, + + -- * Teams + getSize, + + -- * Clients + lookupClients, + lookupClientsFull, + notifyClientsAboutLegalHoldRequest, + getLegalHoldAuthToken, + addLegalHoldClientToUser, + removeLegalHoldClientFromUser, + ) +where + +import Brig.Types.Client +import Brig.Types.Connection +import Brig.Types.Intra +import Brig.Types.User +import Data.Id +import Data.Misc +import Data.Qualified +import Galley.External.LegalHoldService.Types +import Imports +import Network.HTTP.Types.Status +import Polysemy +import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Team.Size +import Wire.API.User.Client +import Wire.API.User.RichInfo + +data BrigAccess m a where + GetConnectionsUnqualified :: + [UserId] -> + Maybe [UserId] -> + Maybe Relation -> + BrigAccess m [ConnectionStatus] + GetConnectionsUnqualifiedBidi :: + [UserId] -> + [UserId] -> + Maybe Relation -> + Maybe Relation -> + BrigAccess m ([ConnectionStatus], [ConnectionStatus]) + GetConnections :: + [UserId] -> + Maybe [Qualified UserId] -> + Maybe Relation -> + BrigAccess m [ConnectionStatusV2] + PutConnectionInternal :: UpdateConnectionsInternal -> BrigAccess m Status + ReauthUser :: UserId -> ReAuthUser -> BrigAccess m Bool + LookupActivatedUsers :: [UserId] -> BrigAccess m [User] + GetUsers :: [UserId] -> BrigAccess m [UserAccount] + DeleteUser :: UserId -> BrigAccess m () + GetContactList :: UserId -> BrigAccess m [UserId] + GetRichInfoMultiUser :: [UserId] -> BrigAccess m [(UserId, RichInfo)] + GetSize :: TeamId -> BrigAccess m TeamSize + LookupClients :: [UserId] -> BrigAccess m UserClients + LookupClientsFull :: [UserId] -> BrigAccess m UserClientsFull + NotifyClientsAboutLegalHoldRequest :: + UserId -> + UserId -> + LastPrekey -> + BrigAccess m () + GetLegalHoldAuthToken :: + UserId -> + Maybe PlainTextPassword -> + BrigAccess m OpaqueAuthToken + AddLegalHoldClientToUser :: + UserId -> + ConnId -> + [Prekey] -> + LastPrekey -> + BrigAccess m ClientId + RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () + +makeSem ''BrigAccess + +getUser :: Member BrigAccess r => UserId -> Sem r (Maybe UserAccount) +getUser = fmap listToMaybe . getUsers . pure diff --git a/services/galley/src/Galley/Effects/ClientStore.hs b/services/galley/src/Galley/Effects/ClientStore.hs new file mode 100644 index 00000000000..451716d66a5 --- /dev/null +++ b/services/galley/src/Galley/Effects/ClientStore.hs @@ -0,0 +1,44 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ClientStore + ( -- * ClientStore Effect + ClientStore (..), + + -- * Create client + createClient, + + -- * Get client + getClients, + + -- * Delete client + deleteClient, + deleteClients, + ) +where + +import Data.Id +import Galley.Types.Clients +import Polysemy + +data ClientStore m a where + GetClients :: [UserId] -> ClientStore m Clients + CreateClient :: UserId -> ClientId -> ClientStore m () + DeleteClient :: UserId -> ClientId -> ClientStore m () + DeleteClients :: UserId -> ClientStore m () + +makeSem ''ClientStore diff --git a/services/galley/src/Galley/Effects/CodeStore.hs b/services/galley/src/Galley/Effects/CodeStore.hs new file mode 100644 index 00000000000..d06105ce5f4 --- /dev/null +++ b/services/galley/src/Galley/Effects/CodeStore.hs @@ -0,0 +1,50 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.CodeStore + ( -- * Code store effect + CodeStore (..), + + -- * Create code + createCode, + + -- * Read code + getCode, + + -- * Delete code + deleteCode, + + -- * Code generation + makeKey, + generateCode, + ) +where + +import Brig.Types.Code +import Data.Id +import Galley.Data.Types +import Imports +import Polysemy + +data CodeStore m a where + CreateCode :: Code -> CodeStore m () + GetCode :: Key -> Scope -> CodeStore m (Maybe Code) + DeleteCode :: Key -> Scope -> CodeStore m () + MakeKey :: ConvId -> CodeStore m Key + GenerateCode :: ConvId -> Scope -> Timeout -> CodeStore m Code + +makeSem ''CodeStore diff --git a/services/galley/src/Galley/Effects/ConversationStore.hs b/services/galley/src/Galley/Effects/ConversationStore.hs new file mode 100644 index 00000000000..c1ee62e5d64 --- /dev/null +++ b/services/galley/src/Galley/Effects/ConversationStore.hs @@ -0,0 +1,112 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ConversationStore + ( -- * ConversationStore Effect + ConversationStore (..), + + -- * Create conversation + createConversation, + createConnectConversation, + createConnectConversationWithRemote, + createLegacyOne2OneConversation, + createOne2OneConversation, + createSelfConversation, + + -- * Read conversation + getConversation, + getConversations, + getConversationMetadata, + isConversationAlive, + getRemoteConversationStatus, + selectConversations, + + -- * Update conversation + setConversationType, + setConversationName, + setConversationAccess, + setConversationReceiptMode, + setConversationMessageTimer, + acceptConnectConversation, + + -- * Delete conversation + deleteConversation, + ) +where + +import Data.Id +import Data.Misc +import Data.Qualified +import Data.Range +import Data.UUID.Tagged +import Galley.Data.Conversation +import Galley.Types.Conversations.Members +import Galley.Types.UserList +import Imports +import Polysemy +import Wire.API.Conversation hiding (Conversation, Member) + +data ConversationStore m a where + CreateConversation :: NewConversation -> ConversationStore m Conversation + CreateConnectConversation :: + UUID V4 -> + UUID V4 -> + Maybe (Range 1 256 Text) -> + ConversationStore m Conversation + CreateConnectConversationWithRemote :: + ConvId -> + UserId -> + UserList UserId -> + ConversationStore m Conversation + CreateLegacyOne2OneConversation :: + Local x -> + UUID V4 -> + UUID V4 -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + ConversationStore m Conversation + CreateOne2OneConversation :: + ConvId -> + Local UserId -> + Qualified UserId -> + Maybe (Range 1 256 Text) -> + Maybe TeamId -> + ConversationStore m Conversation + CreateSelfConversation :: + Local UserId -> + Maybe (Range 1 256 Text) -> + ConversationStore m Conversation + DeleteConversation :: ConvId -> ConversationStore m () + GetConversation :: ConvId -> ConversationStore m (Maybe Conversation) + GetConversations :: [ConvId] -> ConversationStore m [Conversation] + GetConversationMetadata :: ConvId -> ConversationStore m (Maybe ConversationMetadata) + IsConversationAlive :: ConvId -> ConversationStore m Bool + GetRemoteConversationStatus :: + UserId -> + [Remote ConvId] -> + ConversationStore m (Map (Remote ConvId) MemberStatus) + SelectConversations :: UserId -> [ConvId] -> ConversationStore m [ConvId] + SetConversationType :: ConvId -> ConvType -> ConversationStore m () + SetConversationName :: ConvId -> Range 1 256 Text -> ConversationStore m () + SetConversationAccess :: ConvId -> ConversationAccessData -> ConversationStore m () + SetConversationReceiptMode :: ConvId -> ReceiptMode -> ConversationStore m () + SetConversationMessageTimer :: ConvId -> Maybe Milliseconds -> ConversationStore m () + +makeSem ''ConversationStore + +acceptConnectConversation :: Member ConversationStore r => ConvId -> Sem r () +acceptConnectConversation cid = setConversationType cid One2OneConv diff --git a/services/galley/src/Galley/Effects/CustomBackendStore.hs b/services/galley/src/Galley/Effects/CustomBackendStore.hs new file mode 100644 index 00000000000..cd3fc723009 --- /dev/null +++ b/services/galley/src/Galley/Effects/CustomBackendStore.hs @@ -0,0 +1,36 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.CustomBackendStore + ( CustomBackendStore (..), + getCustomBackend, + setCustomBackend, + deleteCustomBackend, + ) +where + +import Data.Domain (Domain) +import Galley.Types +import Imports +import Polysemy + +data CustomBackendStore m a where + GetCustomBackend :: Domain -> CustomBackendStore m (Maybe CustomBackend) + SetCustomBackend :: Domain -> CustomBackend -> CustomBackendStore m () + DeleteCustomBackend :: Domain -> CustomBackendStore m () + +makeSem ''CustomBackendStore diff --git a/services/galley/src/Galley/Effects/ExternalAccess.hs b/services/galley/src/Galley/Effects/ExternalAccess.hs new file mode 100644 index 00000000000..81889aed8af --- /dev/null +++ b/services/galley/src/Galley/Effects/ExternalAccess.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ExternalAccess + ( -- * External access effect + ExternalAccess (..), + deliver, + deliverAsync, + deliverAndDeleteAsync, + ) +where + +import Data.Id +import Galley.Data.Services +import Imports +import Polysemy +import Wire.API.Event.Conversation + +data ExternalAccess m a where + Deliver :: Foldable f => f (BotMember, Event) -> ExternalAccess m [BotMember] + DeliverAsync :: Foldable f => f (BotMember, Event) -> ExternalAccess m () + DeliverAndDeleteAsync :: Foldable f => ConvId -> f (BotMember, Event) -> ExternalAccess m () + +makeSem ''ExternalAccess diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs new file mode 100644 index 00000000000..9a31cd3e097 --- /dev/null +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -0,0 +1,60 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.FederatorAccess + ( -- * Federator access effect + FederatorAccess (..), + runFederated, + runFederatedEither, + runFederatedConcurrently, + runFederatedConcurrently_, + ) +where + +import Data.Qualified +import Galley.Intra.Federator.Types +import Imports +import Polysemy +import Wire.API.Federation.Client +import Wire.API.Federation.GRPC.Types + +data FederatorAccess m a where + RunFederated :: + forall (c :: Component) a m x. + Remote x -> + FederatedRPC c a -> + FederatorAccess m a + RunFederatedEither :: + forall (c :: Component) a m x. + Remote x -> + FederatedRPC c a -> + FederatorAccess m (Either FederationError a) + RunFederatedConcurrently :: + forall (c :: Component) f a m x. + (Foldable f, Functor f) => + f (Remote x) -> + (Remote [x] -> FederatedRPC c a) -> + FederatorAccess m [Remote a] + +makeSem ''FederatorAccess + +runFederatedConcurrently_ :: + (Foldable f, Functor f, Member FederatorAccess r) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c ()) -> + Sem r () +runFederatedConcurrently_ xs = void . runFederatedConcurrently xs diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/services/galley/src/Galley/Effects/FireAndForget.hs index 4b614862a35..73ff93d3778 100644 --- a/services/galley/src/Galley/Effects/FireAndForget.hs +++ b/services/galley/src/Galley/Effects/FireAndForget.hs @@ -37,6 +37,10 @@ makeSem ''FireAndForget fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () fireAndForget = fireAndForgetOne +-- | Run actions in separate threads and ignore results. +-- +-- /Note/: this will also ignore any state and error effects contained in the +-- 'FireAndForget' action. Use with care. interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a interpretFireAndForget = interpretFinal @IO $ \case FireAndForgetOne action -> do diff --git a/services/galley/src/Galley/Effects/GundeckAccess.hs b/services/galley/src/Galley/Effects/GundeckAccess.hs new file mode 100644 index 00000000000..1f035ff1a87 --- /dev/null +++ b/services/galley/src/Galley/Effects/GundeckAccess.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.GundeckAccess + ( -- * Gundeck access effect + GundeckAccess (..), + push, + push1, + ) +where + +import qualified Galley.Intra.Push as G +import Imports +import Polysemy + +data GundeckAccess m a where + Push :: Foldable f => f G.Push -> GundeckAccess m () + +makeSem ''GundeckAccess + +-- | Asynchronously send a single push, chunking it into multiple +-- requests if there are more than 128 recipients. +push1 :: Member GundeckAccess r => G.Push -> Sem r () +push1 x = push [x] diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs new file mode 100644 index 00000000000..28b70fcf1f8 --- /dev/null +++ b/services/galley/src/Galley/Effects/LegalHoldStore.hs @@ -0,0 +1,52 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.LegalHoldStore + ( LegalHoldStore (..), + createSettings, + getSettings, + removeSettings, + insertPendingPrekeys, + selectPendingPrekeys, + dropPendingPrekeys, + setUserLegalHoldStatus, + setTeamLegalholdWhitelisted, + unsetTeamLegalholdWhitelisted, + isTeamLegalholdWhitelisted, + ) +where + +import Data.Id +import Data.LegalHold +import Galley.External.LegalHoldService.Types +import Imports +import Polysemy +import Wire.API.User.Client.Prekey + +data LegalHoldStore m a where + CreateSettings :: LegalHoldService -> LegalHoldStore m () + GetSettings :: TeamId -> LegalHoldStore m (Maybe LegalHoldService) + RemoveSettings :: TeamId -> LegalHoldStore m () + InsertPendingPrekeys :: UserId -> [Prekey] -> LegalHoldStore m () + SelectPendingPrekeys :: UserId -> LegalHoldStore m (Maybe ([Prekey], LastPrekey)) + DropPendingPrekeys :: UserId -> LegalHoldStore m () + SetUserLegalHoldStatus :: TeamId -> UserId -> UserLegalHoldStatus -> LegalHoldStore m () + SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () + UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () + IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool + +makeSem ''LegalHoldStore diff --git a/services/galley/src/Galley/Effects/ListItems.hs b/services/galley/src/Galley/Effects/ListItems.hs new file mode 100644 index 00000000000..0fe007f4963 --- /dev/null +++ b/services/galley/src/Galley/Effects/ListItems.hs @@ -0,0 +1,37 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ListItems + ( ListItems (..), + listItems, + ) +where + +import Data.Id +import Galley.Effects.Paging +import Imports +import Polysemy + +-- | General pagination-aware list-by-user effect +data ListItems p i m a where + ListItems :: + UserId -> + Maybe (PagingState p i) -> + PagingBounds p i -> + ListItems p i m (Page p i) + +makeSem ''ListItems diff --git a/services/galley/src/Galley/Effects/MemberStore.hs b/services/galley/src/Galley/Effects/MemberStore.hs new file mode 100644 index 00000000000..80688a48935 --- /dev/null +++ b/services/galley/src/Galley/Effects/MemberStore.hs @@ -0,0 +1,72 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.MemberStore + ( -- * Member store effect + MemberStore (..), + + -- * Create members + createMember, + createMembers, + createMembersInRemoteConversation, + createBotMember, + + -- * Read members + getLocalMember, + getLocalMembers, + getRemoteMembers, + selectRemoteMembers, + + -- * Update members + setSelfMember, + setOtherMember, + + -- * Delete members + deleteMembers, + deleteMembersInRemoteConversation, + ) +where + +import Data.Id +import Data.Qualified +import Galley.Data.Services +import Galley.Types.Bot +import Galley.Types.Conversations.Members +import Galley.Types.ToUserRole +import Galley.Types.UserList +import Imports +import Polysemy +import Wire.API.Conversation.Member hiding (Member) + +data MemberStore m a where + CreateMembers :: ToUserRole u => ConvId -> UserList u -> MemberStore m ([LocalMember], [RemoteMember]) + CreateMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () + CreateBotMember :: ServiceRef -> BotId -> ConvId -> MemberStore m BotMember + GetLocalMember :: ConvId -> UserId -> MemberStore m (Maybe LocalMember) + GetLocalMembers :: ConvId -> MemberStore m [LocalMember] + GetRemoteMembers :: ConvId -> MemberStore m [RemoteMember] + SelectRemoteMembers :: [UserId] -> Remote ConvId -> MemberStore m ([UserId], Bool) + SetSelfMember :: Qualified ConvId -> Local UserId -> MemberUpdate -> MemberStore m () + SetOtherMember :: Local ConvId -> Qualified UserId -> OtherMemberUpdate -> MemberStore m () + DeleteMembers :: ConvId -> UserList UserId -> MemberStore m () + DeleteMembersInRemoteConversation :: Remote ConvId -> [UserId] -> MemberStore m () + +makeSem ''MemberStore + +-- | Add a member to a local conversation, as an admin. +createMember :: Member MemberStore r => Local ConvId -> Local UserId -> Sem r [LocalMember] +createMember c u = fst <$> createMembers (tUnqualified c) (UserList [tUnqualified u] []) diff --git a/services/galley/src/Galley/Effects/Paging.hs b/services/galley/src/Galley/Effects/Paging.hs new file mode 100644 index 00000000000..8fec9b20f6a --- /dev/null +++ b/services/galley/src/Galley/Effects/Paging.hs @@ -0,0 +1,72 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.Paging + ( -- * General paging types + Page, + PagingState, + PagingBounds, + Paging (..), + + -- * Utilities + withChunks, + + -- * Simple paging + SimplePaging, + ) +where + +import Imports + +type family Page p a :: (page :: *) | page -> p a + +type family PagingState p a = (ps :: *) + +type family PagingBounds p a :: * + +class Paging p where + pageItems :: Page p a -> [a] + pageHasMore :: Page p a -> Bool + pageState :: Page p a -> PagingState p a + +data SimplePaging + +type instance Page SimplePaging a = [a] + +type instance PagingState SimplePaging a = () + +type instance PagingBounds SimplePaging a = Int32 + +instance Paging SimplePaging where + pageItems = id + pageHasMore _ = False + pageState _ = () + +withChunks :: + (Paging p, Monad m) => + (Maybe (PagingState p i) -> m (Page p i)) -> + ([i] -> m ()) -> + m () +withChunks pager action = do + page <- pager Nothing + go page + where + go page = do + action (pageItems page) + when (pageHasMore page) $ do + page' <- pager (Just (pageState page)) + go page' diff --git a/services/galley/src/Galley/Effects/RemoteConversationListStore.hs b/services/galley/src/Galley/Effects/RemoteConversationListStore.hs new file mode 100644 index 00000000000..e1dec1ce376 --- /dev/null +++ b/services/galley/src/Galley/Effects/RemoteConversationListStore.hs @@ -0,0 +1,43 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.RemoteConversationListStore + ( RemoteConversationListStore (..), + listRemoteConversations, + getRemoteConversationStatus, + ) +where + +import Data.Id +import Data.Qualified +import Galley.Effects.Paging +import Galley.Types.Conversations.Members +import Imports +import Polysemy + +data RemoteConversationListStore p m a where + ListRemoteConversations :: + UserId -> + Maybe (PagingState p (Remote ConvId)) -> + Int32 -> + RemoteConversationListStore p m (Page p (Remote ConvId)) + GetRemoteConversationStatus :: + UserId -> + [Remote ConvId] -> + RemoteConversationListStore p m (Map (Remote ConvId) MemberStatus) + +makeSem ''RemoteConversationListStore diff --git a/services/galley/src/Galley/Effects/SearchVisibilityStore.hs b/services/galley/src/Galley/Effects/SearchVisibilityStore.hs new file mode 100644 index 00000000000..28a9b394c32 --- /dev/null +++ b/services/galley/src/Galley/Effects/SearchVisibilityStore.hs @@ -0,0 +1,35 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.SearchVisibilityStore + ( SearchVisibilityStore (..), + getSearchVisibility, + setSearchVisibility, + resetSearchVisibility, + ) +where + +import Data.Id +import Galley.Types.Teams.SearchVisibility +import Polysemy + +data SearchVisibilityStore m a where + GetSearchVisibility :: TeamId -> SearchVisibilityStore m TeamSearchVisibility + SetSearchVisibility :: TeamId -> TeamSearchVisibility -> SearchVisibilityStore m () + ResetSearchVisibility :: TeamId -> SearchVisibilityStore m () + +makeSem ''SearchVisibilityStore diff --git a/services/galley/src/Galley/Effects/ServiceStore.hs b/services/galley/src/Galley/Effects/ServiceStore.hs new file mode 100644 index 00000000000..f9305e75090 --- /dev/null +++ b/services/galley/src/Galley/Effects/ServiceStore.hs @@ -0,0 +1,42 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.ServiceStore + ( -- * Service effect + ServiceStore (..), + + -- * Create service + createService, + + -- * Read service + getService, + + -- * Delete service + deleteService, + ) +where + +import Galley.Types.Bot +import Imports +import Polysemy + +data ServiceStore m a where + CreateService :: Service -> ServiceStore m () + GetService :: ServiceRef -> ServiceStore m (Maybe Service) + DeleteService :: ServiceRef -> ServiceStore m () + +makeSem ''ServiceStore diff --git a/services/galley/src/Galley/Effects/SparAccess.hs b/services/galley/src/Galley/Effects/SparAccess.hs new file mode 100644 index 00000000000..b8479858aa7 --- /dev/null +++ b/services/galley/src/Galley/Effects/SparAccess.hs @@ -0,0 +1,26 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.SparAccess where + +import Data.Id +import Polysemy + +data SparAccess m a where + DeleteTeam :: TeamId -> SparAccess m () + +makeSem ''SparAccess diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs new file mode 100644 index 00000000000..d2910980f20 --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -0,0 +1,86 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamFeatureStore + ( TeamFeatureStore (..), + getFeatureStatusNoConfig, + setFeatureStatusNoConfig, + getApplockFeatureStatus, + setApplockFeatureStatus, + getSelfDeletingMessagesStatus, + setSelfDeletingMessagesStatus, + ) +where + +import Data.Id +import Data.Proxy +import Galley.Data.TeamFeatures +import Imports +import Polysemy +import Wire.API.Team.Feature + +data TeamFeatureStore m a where + -- the proxy argument makes sure that makeSem below generates type-inference-friendly code + GetFeatureStatusNoConfig' :: + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus a)) + -- the proxy argument makes sure that makeSem below generates type-inference-friendly code + SetFeatureStatusNoConfig' :: + forall (a :: TeamFeatureName) m. + ( FeatureHasNoConfig a, + HasStatusCol a + ) => + Proxy a -> + TeamId -> + TeamFeatureStatus a -> + TeamFeatureStore m (TeamFeatureStatus a) + GetApplockFeatureStatus :: + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureAppLock)) + SetApplockFeatureStatus :: + TeamId -> + TeamFeatureStatus 'TeamFeatureAppLock -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureAppLock) + GetSelfDeletingMessagesStatus :: + TeamId -> + TeamFeatureStore m (Maybe (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages)) + SetSelfDeletingMessagesStatus :: + TeamId -> + TeamFeatureStatus 'TeamFeatureSelfDeletingMessages -> + TeamFeatureStore m (TeamFeatureStatus 'TeamFeatureSelfDeletingMessages) + +makeSem ''TeamFeatureStore + +getFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + TeamId -> + Sem r (Maybe (TeamFeatureStatus a)) +getFeatureStatusNoConfig = getFeatureStatusNoConfig' (Proxy @a) + +setFeatureStatusNoConfig :: + forall (a :: TeamFeatureName) r. + (Member TeamFeatureStore r, FeatureHasNoConfig a, HasStatusCol a) => + TeamId -> + TeamFeatureStatus a -> + Sem r (TeamFeatureStatus a) +setFeatureStatusNoConfig = setFeatureStatusNoConfig' (Proxy @a) diff --git a/services/galley/src/Galley/Effects/TeamMemberStore.hs b/services/galley/src/Galley/Effects/TeamMemberStore.hs new file mode 100644 index 00000000000..618d349ec1f --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamMemberStore.hs @@ -0,0 +1,40 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamMemberStore + ( -- * Team member store effect + TeamMemberStore (..), + + -- * Team member pagination + listTeamMembers, + ) +where + +import Data.Id +import Galley.Effects.Paging +import Galley.Types.Teams +import Imports +import Polysemy + +data TeamMemberStore p m a where + ListTeamMembers :: + TeamId -> + Maybe (PagingState p TeamMember) -> + PagingBounds p TeamMember -> + TeamMemberStore p m (Page p TeamMember) + +makeSem ''TeamMemberStore diff --git a/services/galley/src/Galley/Effects/TeamNotificationStore.hs b/services/galley/src/Galley/Effects/TeamNotificationStore.hs new file mode 100644 index 00000000000..5e553315d44 --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamNotificationStore.hs @@ -0,0 +1,41 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamNotificationStore where + +import qualified Data.Aeson as JSON +import Data.Id +import Data.List1 (List1) +import Data.Range +import Galley.Data.TeamNotifications +import Gundeck.Types.Notification +import Imports +import Polysemy + +data TeamNotificationStore m a where + CreateTeamNotification :: + TeamId -> + NotificationId -> + List1 JSON.Object -> + TeamNotificationStore m () + GetTeamNotifications :: + TeamId -> + Maybe NotificationId -> + Range 1 10000 Int32 -> + TeamNotificationStore m ResultPage + +makeSem ''TeamNotificationStore diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs new file mode 100644 index 00000000000..541d87f39dc --- /dev/null +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -0,0 +1,119 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Effects.TeamStore + ( -- * Team store effect + TeamStore (..), + + -- * Teams + + -- ** Create teams + createTeam, + + -- ** Read teams + getTeam, + getTeamName, + getTeamBinding, + getTeamsBindings, + getTeamConversation, + getTeamConversations, + getTeamCreationTime, + listTeams, + selectTeams, + getUserTeams, + getUsersTeams, + getOneUserTeam, + + -- ** Update teams + deleteTeamConversation, + setTeamData, + setTeamStatus, + + -- ** Delete teams + deleteTeam, + + -- * Team Members + + -- ** Create team members + createTeamMember, + + -- ** Read team members + getTeamMember, + getTeamMembersWithLimit, + getTeamMembers, + getBillingTeamMembers, + selectTeamMembers, + + -- ** Update team members + setTeamMemberPermissions, + + -- ** Delete team members + deleteTeamMember, + ) +where + +import Data.Id +import Data.Range +import Galley.Effects.ListItems +import Galley.Effects.Paging +import Galley.Types.Teams +import Galley.Types.Teams.Intra +import Imports +import Polysemy + +data TeamStore m a where + CreateTeamMember :: TeamId -> TeamMember -> TeamStore m () + SetTeamMemberPermissions :: Permissions -> TeamId -> UserId -> Permissions -> TeamStore m () + CreateTeam :: + Maybe TeamId -> + UserId -> + Range 1 256 Text -> + Range 1 256 Text -> + Maybe (Range 1 256 Text) -> + TeamBinding -> + TeamStore m Team + DeleteTeamMember :: TeamId -> UserId -> TeamStore m () + GetBillingTeamMembers :: TeamId -> TeamStore m [UserId] + GetTeam :: TeamId -> TeamStore m (Maybe TeamData) + GetTeamName :: TeamId -> TeamStore m (Maybe Text) + GetTeamConversation :: TeamId -> ConvId -> TeamStore m (Maybe TeamConversation) + GetTeamConversations :: TeamId -> TeamStore m [TeamConversation] + SelectTeams :: UserId -> [TeamId] -> TeamStore m [TeamId] + GetTeamMember :: TeamId -> UserId -> TeamStore m (Maybe TeamMember) + GetTeamMembersWithLimit :: TeamId -> Range 1 HardTruncationLimit Int32 -> TeamStore m TeamMemberList + GetTeamMembers :: TeamId -> TeamStore m [TeamMember] + SelectTeamMembers :: TeamId -> [UserId] -> TeamStore m [TeamMember] + GetUserTeams :: UserId -> TeamStore m [TeamId] + GetUsersTeams :: [UserId] -> TeamStore m (Map UserId TeamId) + GetOneUserTeam :: UserId -> TeamStore m (Maybe TeamId) + GetTeamsBindings :: [TeamId] -> TeamStore m [TeamBinding] + GetTeamBinding :: TeamId -> TeamStore m (Maybe TeamBinding) + GetTeamCreationTime :: TeamId -> TeamStore m (Maybe TeamCreationTime) + DeleteTeam :: TeamId -> TeamStore m () + DeleteTeamConversation :: TeamId -> ConvId -> TeamStore m () + SetTeamData :: TeamId -> TeamUpdateData -> TeamStore m () + SetTeamStatus :: TeamId -> TeamStatus -> TeamStore m () + +makeSem ''TeamStore + +listTeams :: + Member (ListItems p TeamId) r => + UserId -> + Maybe (PagingState p TeamId) -> + PagingBounds p TeamId -> + Sem r (Page p TeamId) +listTeams = listItems diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs new file mode 100644 index 00000000000..bff564836eb --- /dev/null +++ b/services/galley/src/Galley/Env.hs @@ -0,0 +1,100 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Env where + +import Cassandra +import Control.Lens hiding ((.=)) +import Data.ByteString.Conversion (toByteString') +import Data.Id +import Data.Metrics.Middleware +import Data.Misc (Fingerprint, Rsa) +import Data.Range +import qualified Galley.Aws as Aws +import Galley.Options +import qualified Galley.Queue as Q +import qualified Galley.Types.Teams as Teams +import Imports +import Network.HTTP.Client +import Network.HTTP.Client.OpenSSL +import OpenSSL.EVP.Digest +import OpenSSL.Session as Ssl +import qualified OpenSSL.X509.SystemStore as Ssl +import Ssl.Util +import System.Logger +import Util.Options + +data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) + deriving (Eq, Ord, Show) + +-- | Main application environment. +data Env = Env + { _reqId :: RequestId, + _monitor :: Metrics, + _options :: Opts, + _applog :: Logger, + _manager :: Manager, + _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? + _brig :: Endpoint, -- FUTUREWORK: see _federator + _cstate :: ClientState, + _deleteQueue :: Q.Queue DeleteItem, + _extEnv :: ExtEnv, + _aEnv :: Maybe Aws.Env + } + +-- | Environment specific to the communication with external +-- service providers. +data ExtEnv = ExtEnv + { _extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ()) + } + +makeLenses ''Env + +makeLenses ''ExtEnv + +-- TODO: somewhat duplicates Brig.App.initExtGetManager +initExtEnv :: IO ExtEnv +initExtEnv = do + ctx <- Ssl.context + Ssl.contextSetVerificationMode ctx Ssl.VerifyNone + Ssl.contextAddOption ctx SSL_OP_NO_SSLv2 + Ssl.contextAddOption ctx SSL_OP_NO_SSLv3 + Ssl.contextAddOption ctx SSL_OP_NO_TLSv1 + Ssl.contextSetCiphers ctx rsaCiphers + Ssl.contextLoadSystemCerts ctx + mgr <- + newManager + (opensslManagerSettings (pure ctx)) + { managerResponseTimeout = responseTimeoutMicro 10000000, + managerConnCount = 100 + } + Just sha <- getDigestByName "SHA256" + return $ ExtEnv (mgr, mkVerify sha) + where + mkVerify sha fprs = + let pinset = map toByteString' fprs + in verifyRsaFingerprint sha pinset + +reqIdMsg :: RequestId -> Msg -> Msg +reqIdMsg = ("request" .=) . unRequestId +{-# INLINE reqIdMsg #-} + +currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 +currentFanoutLimit o = do + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) + let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) + unsafeRange (min maxTeamSize optFanoutLimit) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index eb2024ee2d7..e325f3da587 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -15,12 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.External - ( deliver, - deliverAndDeleteAsync, - deliverAsync, - ) -where +module Galley.External (interpretExternalAccess) where import Bilge.Request import Bilge.Retry (httpHandlers) @@ -29,58 +24,59 @@ import Control.Retry import Data.ByteString.Conversion.To import Data.Id import Data.Misc -import Galley.App +import Galley.Cassandra.Services import Galley.Data.Services (BotMember, botMemId, botMemService) -import qualified Galley.Data.Services as Data import Galley.Effects +import Galley.Effects.ExternalAccess (ExternalAccess (..)) +import Galley.Env import Galley.Intra.User +import Galley.Intra.Util import Galley.Types (Event) import Galley.Types.Bot import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status (status410) +import Polysemy +import qualified Polysemy.Reader as P import Ssl.Util (withVerifiedSslConnection) import qualified System.Logger.Class as Log import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString import UnliftIO (Async, async, waitCatch) +interpretExternalAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (ExternalAccess ': r) a -> + Sem r a +interpretExternalAccess = interpret $ \case + Deliver pp -> embedIntra $ deliver (toList pp) + DeliverAsync pp -> embedIntra $ deliverAsync (toList pp) + DeliverAndDeleteAsync cid pp -> embedIntra $ deliverAndDeleteAsync cid (toList pp) + -- | Like deliver, but ignore orphaned bots and return immediately. -- -- FUTUREWORK: Check if this can be removed. -deliverAsync :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r () -deliverAsync = liftGalley0 . void . forkIO . void . deliver0 +deliverAsync :: [(BotMember, Event)] -> IntraM () +deliverAsync = void . forkIO . void . deliver -- | Like deliver, but remove orphaned bots and return immediately. -deliverAndDeleteAsync :: - Members '[ExternalAccess, BotAccess] r => - ConvId -> - [(BotMember, Event)] -> - Galley r () -deliverAndDeleteAsync cnv pushes = liftGalley0 . void . forkIO $ do - gone <- liftGalley0 $ deliver0 pushes - mapM_ (deleteBot0 cnv . botMemId) gone - --- | Deliver events to external (bot) services. --- --- Returns those bots which are found to be orphaned by the external --- service, e.g. when the service tells us that it no longer knows about the --- bot. -deliver :: Member ExternalAccess r => [(BotMember, Event)] -> Galley r [BotMember] -deliver = liftGalley0 . deliver0 +deliverAndDeleteAsync :: ConvId -> [(BotMember, Event)] -> IntraM () +deliverAndDeleteAsync cnv pushes = void . forkIO $ do + gone <- deliver pushes + mapM_ (deleteBot cnv . botMemId) gone -deliver0 :: [(BotMember, Event)] -> Galley0 [BotMember] -deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) +deliver :: [(BotMember, Event)] -> IntraM [BotMember] +deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) where - exec :: (BotMember, Event) -> Galley0 Bool + exec :: (BotMember, Event) -> IntraM Bool exec (b, e) = - Data.lookupService (botMemService b) >>= \case + lookupService (botMemService b) >>= \case Nothing -> return False Just s -> do deliver1 s b e return True - eval :: [BotMember] -> (BotMember, Async Bool) -> Galley r [BotMember] + eval :: [BotMember] -> (BotMember, Async Bool) -> IntraM [BotMember] eval gone (b, a) = do let s = botMemService b r <- waitCatch a @@ -119,7 +115,7 @@ deliver0 pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) -- Internal ------------------------------------------------------------------- -deliver1 :: Service -> BotMember -> Event -> Galley0 () +deliver1 :: Service -> BotMember -> Event -> IntraM () deliver1 s bm e | s ^. serviceEnabled = do let t = toByteString' (s ^. serviceToken) @@ -149,7 +145,7 @@ urlPort (HttpsUrl u) = do p <- a ^. authorityPortL return (fromIntegral (p ^. portNumberL)) -sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> Galley r () +sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> IntraM () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 133b4cf4134..affafacf2ee 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -26,9 +24,6 @@ module Galley.External.LegalHoldService -- * helpers validateServiceKey, - - -- * types - OpaqueAuthToken (..), ) where @@ -49,7 +44,9 @@ import Data.Id import Data.Misc import Galley.API.Error import Galley.App -import qualified Galley.Data.LegalHold as LegalHoldData +import Galley.Effects.LegalHoldStore as LegalHoldData +import Galley.Env +import Galley.External.LegalHoldService.Types import Imports import qualified Network.HTTP.Client as Http import Network.HTTP.Types @@ -58,6 +55,8 @@ import qualified OpenSSL.EVP.PKey as SSL import qualified OpenSSL.PEM as SSL import qualified OpenSSL.RSA as SSL import qualified OpenSSL.Session as SSL +import Polysemy +import Polysemy.Error import Ssl.Util import qualified Ssl.Util as SSL import qualified System.Logger.Class as Log @@ -67,14 +66,18 @@ import URI.ByteString (uriPath) -- api -- | Get /status from legal hold service; throw 'Wai.Error' if things go wrong. -checkLegalHoldServiceStatus :: Fingerprint Rsa -> HttpsUrl -> Galley r () +checkLegalHoldServiceStatus :: + Member (Error LegalHoldError) r => + Fingerprint Rsa -> + HttpsUrl -> + Galley r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder if | Bilge.statusCode resp < 400 -> pure () | otherwise -> do Log.info . Log.msg $ showResponse resp - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = @@ -83,13 +86,17 @@ checkLegalHoldServiceStatus fpr url = do . Bilge.expect2xx -- | @POST /initiate@. -requestNewDevice :: TeamId -> UserId -> Galley r NewLegalHoldClient +requestNewDevice :: + Members '[Error LegalHoldError, LegalHoldStore] r => + TeamId -> + UserId -> + Galley r NewLegalHoldClient requestNewDevice tid uid = do resp <- makeLegalHoldServiceRequest tid reqParams case eitherDecode (responseBody resp) of Left e -> do Log.info . Log.msg $ "Error decoding NewLegalHoldClient: " <> e - throwM legalHoldServiceBadResponse + liftSem $ throw LegalHoldServiceBadResponse Right client -> pure client where reqParams = @@ -102,6 +109,7 @@ requestNewDevice tid uid = do -- | @POST /confirm@ -- Confirm that a device has been linked to a user and provide an authorization token confirmLegalHold :: + Members '[Error LegalHoldError, LegalHoldStore] r => ClientId -> TeamId -> UserId -> @@ -121,6 +129,7 @@ confirmLegalHold clientId tid uid legalHoldAuthToken = do -- | @POST /remove@ -- Inform the LegalHold Service that a user's legalhold has been disabled. removeLegalHold :: + Members '[Error LegalHoldError, LegalHoldStore] r => TeamId -> UserId -> Galley r () @@ -140,11 +149,15 @@ removeLegalHold tid uid = do -- | Lookup legal hold service settings for a team and make a request to the service. Pins -- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can -- authenticate the request. -makeLegalHoldServiceRequest :: TeamId -> (Http.Request -> Http.Request) -> Galley r (Http.Response LC8.ByteString) +makeLegalHoldServiceRequest :: + Members '[Error LegalHoldError, LegalHoldStore] r => + TeamId -> + (Http.Request -> Http.Request) -> + Galley r (Http.Response LC8.ByteString) makeLegalHoldServiceRequest tid reqBuilder = do - maybeLHSettings <- LegalHoldData.getSettings tid + maybeLHSettings <- liftSem $ LegalHoldData.getSettings tid lhSettings <- case maybeLHSettings of - Nothing -> throwM legalHoldServiceNotRegistered + Nothing -> liftSem $ throw LegalHoldServiceNotRegistered Just lhSettings -> pure lhSettings let LegalHoldService { legalHoldServiceUrl = baseUrl, @@ -237,14 +250,3 @@ validateServiceKey pem = (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) - --- Types - --- | When receiving tokens from other services which are 'just passing through' --- it's error-prone useless extra work to parse and render them from JSON over and over again. --- We'll just wrap them with this to give some level of typesafety and a reasonable JSON --- instance -newtype OpaqueAuthToken = OpaqueAuthToken - { opaqueAuthTokenToText :: Text - } - deriving newtype (Eq, Show, FromJSON, ToJSON, ToByteString) diff --git a/services/galley/src/Galley/External/LegalHoldService/Types.hs b/services/galley/src/Galley/External/LegalHoldService/Types.hs new file mode 100644 index 00000000000..8a3f671bcf5 --- /dev/null +++ b/services/galley/src/Galley/External/LegalHoldService/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.External.LegalHoldService.Types + ( OpaqueAuthToken (..), + + -- * Re-exports + LegalHoldService, + ) +where + +import Brig.Types.Team.LegalHold +import Data.Aeson +import Data.ByteString.Conversion.To +import Imports + +-- | When receiving tokens from other services which are 'just passing through' +-- it's error-prone useless extra work to parse and render them from JSON over and over again. +-- We'll just wrap them with this to give some level of typesafety and a reasonable JSON +-- instance +newtype OpaqueAuthToken = OpaqueAuthToken + { opaqueAuthTokenToText :: Text + } + deriving newtype (Eq, Show, FromJSON, ToJSON, ToByteString) diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index f0a941d0a39..52a783513c7 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -38,24 +38,26 @@ import Data.Misc import qualified Data.Set as Set import Data.Text.Encoding import Galley.API.Error -import Galley.App import Galley.Effects -import Galley.External.LegalHoldService +import Galley.Env +import Galley.External.LegalHoldService.Types import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Polysemy +import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P import qualified System.Logger.Class as Logger import Wire.API.User.Client (UserClients, UserClientsFull, filterClients, filterClientsFull) -- | Calls 'Brig.API.internalListClientsH'. -lookupClients :: Member BrigAccess r => [UserId] -> Galley r UserClients +lookupClients :: [UserId] -> IntraM UserClients lookupClients uids = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ - method POST . host brigHost . port brigPort + call Brig $ + method POST . path "/i/clients" . json (UserSet $ Set.fromList uids) . expect2xx @@ -64,14 +66,12 @@ lookupClients uids = do -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: - Member BrigAccess r => [UserId] -> - Galley r UserClientsFull + IntraM UserClientsFull lookupClientsFull uids = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ - method POST . host brigHost . port brigPort + call Brig $ + method POST . path "/i/clients/full" . json (UserSet $ Set.fromList uids) . expect2xx @@ -80,52 +80,44 @@ lookupClientsFull uids = do -- | Calls 'Brig.API.legalHoldClientRequestedH'. notifyClientsAboutLegalHoldRequest :: - Member BrigAccess r => UserId -> UserId -> LastPrekey -> - Galley r () + IntraM () notifyClientsAboutLegalHoldRequest requesterUid targetUid lastPrekey' = do - (brigHost, brigPort) <- brigReq - void . callBrig $ + void . call Brig $ method POST - . host brigHost - . port brigPort . paths ["i", "clients", "legalhold", toByteString' targetUid, "request"] . json (LegalHoldClientRequest requesterUid lastPrekey') . expect2xx -- | Calls 'Brig.User.API.Auth.legalHoldLoginH'. getLegalHoldAuthToken :: - Member BrigAccess r => + Members '[Embed IO, P.TinyLog, P.Reader Env] r => UserId -> Maybe PlainTextPassword -> - Galley r OpaqueAuthToken + Sem r OpaqueAuthToken getLegalHoldAuthToken uid pw = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ + embedIntra . call Brig $ method POST - . host brigHost - . port brigPort . path "/i/legalhold-login" . queryItem "persist" "true" . json (LegalHoldLogin uid pw Nothing) . expect2xx case getCookieValue "zuid" r of Nothing -> do - Logger.warn $ Logger.msg @Text "Response from login missing auth cookie" - throwM internalError + P.warn $ Logger.msg @Text "Response from login missing auth cookie" + embed $ throwM internalError Just c -> pure . OpaqueAuthToken . decodeUtf8 $ c -- | Calls 'Brig.API.addClientInternalH'. addLegalHoldClientToUser :: - Member BrigAccess r => UserId -> ConnId -> [Prekey] -> LastPrekey -> - Galley r ClientId + IntraM ClientId addLegalHoldClientToUser uid connId prekeys lastPrekey' = do clientId <$> brigAddClient uid connId lhClient where @@ -143,28 +135,21 @@ addLegalHoldClientToUser uid connId prekeys lastPrekey' = do -- | Calls 'Brig.API.removeLegalHoldClientH'. removeLegalHoldClientFromUser :: - Member BrigAccess r => UserId -> - Galley r () + IntraM () removeLegalHoldClientFromUser targetUid = do - (brigHost, brigPort) <- brigReq - void . callBrig $ + void . call Brig $ method DELETE - . host brigHost - . port brigPort . paths ["i", "clients", "legalhold", toByteString' targetUid] . contentJson . expect2xx -- | Calls 'Brig.API.addClientInternalH'. -brigAddClient :: Member BrigAccess r => UserId -> ConnId -> NewClient -> Galley r Client +brigAddClient :: UserId -> ConnId -> NewClient -> IntraM Client brigAddClient uid connId client = do - (brigHost, brigPort) <- brigReq r <- - callBrig $ + call Brig $ method POST - . host brigHost - . port brigPort . header "Z-Connection" (toByteString' connId) . paths ["i", "clients", toByteString' uid] . contentJson diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs new file mode 100644 index 00000000000..26191832bfa --- /dev/null +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -0,0 +1,95 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Effects + ( interpretBrigAccess, + interpretSparAccess, + interpretBotAccess, + interpretGundeckAccess, + ) +where + +import Galley.Effects.BotAccess (BotAccess (..)) +import Galley.Effects.BrigAccess (BrigAccess (..)) +import Galley.Effects.GundeckAccess (GundeckAccess (..)) +import Galley.Effects.SparAccess (SparAccess (..)) +import Galley.Env +import Galley.Intra.Client +import qualified Galley.Intra.Push.Internal as G +import Galley.Intra.Spar +import Galley.Intra.Team +import Galley.Intra.User +import Galley.Intra.Util +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import qualified Polysemy.TinyLog as P +import qualified UnliftIO + +interpretBrigAccess :: + Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Sem (BrigAccess ': r) a -> + Sem r a +interpretBrigAccess = interpret $ \case + GetConnectionsUnqualified uids muids mrel -> + embedIntra $ getConnectionsUnqualified uids muids mrel + GetConnectionsUnqualifiedBidi uids1 uids2 mrel1 mrel2 -> + embedIntra $ + UnliftIO.concurrently + (getConnectionsUnqualified uids1 (Just uids2) mrel1) + (getConnectionsUnqualified uids2 (Just uids1) mrel2) + GetConnections uids mquids mrel -> + embedIntra $ + getConnections uids mquids mrel + PutConnectionInternal uc -> embedIntra $ putConnectionInternal uc + ReauthUser uid reauth -> embedIntra $ reAuthUser uid reauth + LookupActivatedUsers uids -> embedIntra $ lookupActivatedUsers uids + GetUsers uids -> embedIntra $ getUsers uids + DeleteUser uid -> embedIntra $ deleteUser uid + GetContactList uid -> embedIntra $ getContactList uid + GetRichInfoMultiUser uids -> embedIntra $ getRichInfoMultiUser uids + GetSize tid -> embedIntra $ getSize tid + LookupClients uids -> embedIntra $ lookupClients uids + LookupClientsFull uids -> embedIntra $ lookupClientsFull uids + NotifyClientsAboutLegalHoldRequest self other pk -> + embedIntra $ notifyClientsAboutLegalHoldRequest self other pk + GetLegalHoldAuthToken uid mpwd -> getLegalHoldAuthToken uid mpwd + AddLegalHoldClientToUser uid conn pks lpk -> + embedIntra $ addLegalHoldClientToUser uid conn pks lpk + RemoveLegalHoldClientFromUser uid -> + embedIntra $ removeLegalHoldClientFromUser uid + +interpretSparAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (SparAccess ': r) a -> + Sem r a +interpretSparAccess = interpret $ \case + DeleteTeam tid -> embedIntra $ deleteTeam tid + +interpretBotAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (BotAccess ': r) a -> + Sem r a +interpretBotAccess = interpret $ \case + DeleteBot cid bid -> embedIntra $ deleteBot cid bid + +interpretGundeckAccess :: + Members '[Embed IO, P.TinyLog, P.Reader Env] r => + Sem (GundeckAccess ': r) a -> + Sem r a +interpretGundeckAccess = interpret $ \case + Push ps -> embedIntra $ G.push ps diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs new file mode 100644 index 00000000000..cd08fb32572 --- /dev/null +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Federator (interpretFederatorAccess) where + +import Control.Monad.Except +import Data.Qualified +import Galley.Effects.FederatorAccess (FederatorAccess (..)) +import Galley.Env +import Galley.Intra.Federator.Types +import Imports +import Polysemy +import qualified Polysemy.Reader as P +import UnliftIO +import Wire.API.Federation.Client +import Wire.API.Federation.Error + +embedFederationM :: + Members '[Embed IO, P.Reader Env] r => + FederationM a -> + Sem r a +embedFederationM action = do + env <- P.ask + embed $ runFederationM env action + +interpretFederatorAccess :: + Members '[Embed IO, P.Reader Env] r => + Sem (FederatorAccess ': r) a -> + Sem r a +interpretFederatorAccess = interpret $ \case + RunFederated dom rpc -> embedFederationM $ runFederated dom rpc + RunFederatedEither dom rpc -> embedFederationM $ runFederatedEither dom rpc + RunFederatedConcurrently rs f -> embedFederationM $ runFederatedConcurrently rs f + +runFederatedEither :: + Remote x -> + FederatedRPC c a -> + FederationM (Either FederationError a) +runFederatedEither (tDomain -> remoteDomain) rpc = do + env <- ask + liftIO $ runFederationM env (runExceptT (executeFederated remoteDomain rpc)) + +runFederated :: + Remote x -> + FederatedRPC c a -> + FederationM a +runFederated dom rpc = + runFederatedEither dom rpc + >>= either (throwIO . federationErrorToWai) pure + +runFederatedConcurrently :: + (Foldable f, Functor f) => + f (Remote a) -> + (Remote [a] -> FederatedRPC c b) -> + FederationM [Remote b] +runFederatedConcurrently xs rpc = + pooledForConcurrentlyN 8 (bucketRemote xs) $ \r -> + qualifyAs r <$> runFederated r (rpc r) diff --git a/services/galley/src/Galley/Intra/Federator/Types.hs b/services/galley/src/Galley/Intra/Federator/Types.hs new file mode 100644 index 00000000000..40c0b892680 --- /dev/null +++ b/services/galley/src/Galley/Intra/Federator/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Federator.Types + ( FederatedRPC, + FederationM, + runFederationM, + ) +where + +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Except +import Galley.Env +import Galley.Options +import Imports +import Wire.API.Federation.Client +import Wire.API.Federation.GRPC.Types + +type FederatedRPC (c :: Component) = + FederatorClient c (ExceptT FederationClientFailure FederationM) + +newtype FederationM a = FederationM + {unFederationM :: ReaderT Env IO a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadReader Env, + MonadUnliftIO, + MonadThrow, + MonadCatch, + MonadMask + ) + +runFederationM :: Env -> FederationM a -> IO a +runFederationM env = flip runReaderT env . unFederationM + +instance HasFederatorConfig FederationM where + federatorEndpoint = view federator + federationDomain = view (options . optSettings . setFederationDomain) diff --git a/services/galley/src/Galley/Intra/Journal.hs b/services/galley/src/Galley/Intra/Journal.hs index 4cb9e07a3d7..f4bf8cd0c77 100644 --- a/services/galley/src/Galley/Intra/Journal.hs +++ b/services/galley/src/Galley/Intra/Journal.hs @@ -33,13 +33,15 @@ import Data.Proto import Data.Proto.Id import Data.ProtoLens (defMessage) import Data.Text (pack) +import Galley.API.Util import Galley.App import qualified Galley.Aws as Aws -import qualified Galley.Data as Data +import Galley.Effects.TeamStore import qualified Galley.Options as Opts import Galley.Types.Teams import Imports hiding (head) import Numeric.Natural +import Polysemy import Proto.TeamEvents (TeamEvent'EventData, TeamEvent'EventType (..)) import qualified Proto.TeamEvents_Fields as T import System.Logger (field, msg, val) @@ -49,7 +51,13 @@ import qualified System.Logger.Class as Log -- Team journal operations to SQS are a no-op when the service -- is started without journaling arguments -teamActivate :: TeamId -> Natural -> Maybe Currency.Alpha -> Maybe TeamCreationTime -> Galley r () +teamActivate :: + Member TeamStore r => + TeamId -> + Natural -> + Maybe Currency.Alpha -> + Maybe TeamCreationTime -> + Galley r () teamActivate tid teamSize cur time = do billingUserIds <- getBillingUserIds tid Nothing journalEvent TeamEvent'TEAM_ACTIVATE tid (Just $ evData teamSize billingUserIds cur) time @@ -88,31 +96,37 @@ evData memberCount billingUserIds cur = & T.maybe'currency .~ (pack . show <$> cur) -- FUTUREWORK: Remove this function and always get billing users ids using --- 'Data.listBillingTeamMembers'. This is required only until data is backfilled in the +-- 'getBillingTeamMembers'. This is required only until data is backfilled in the -- 'billing_team_user' table. -getBillingUserIds :: TeamId -> Maybe TeamMemberList -> Galley r [UserId] +getBillingUserIds :: + Member TeamStore r => + TeamId -> + Maybe TeamMemberList -> + Galley r [UserId] getBillingUserIds tid maybeMemberList = do enableIndexedBillingTeamMembers <- view (options . Opts.optSettings . Opts.setEnableIndexedBillingTeamMembers . to (fromMaybe False)) case maybeMemberList of Nothing -> if enableIndexedBillingTeamMembers - then fetchFromDB - else handleList enableIndexedBillingTeamMembers =<< Data.teamMembersForFanout tid + then liftSem $ fetchFromDB + else do + mems <- getTeamMembersForFanout tid + handleList enableIndexedBillingTeamMembers mems Just list -> handleList enableIndexedBillingTeamMembers list where - fetchFromDB :: Galley r [UserId] - fetchFromDB = Data.listBillingTeamMembers tid + fetchFromDB :: Member TeamStore r => Sem r [UserId] + fetchFromDB = getBillingTeamMembers tid filterFromMembers :: TeamMemberList -> Galley r [UserId] filterFromMembers list = pure $ map (view userId) $ filter (`hasPermission` SetBilling) (list ^. teamMembers) - handleList :: Bool -> TeamMemberList -> Galley r [UserId] + handleList :: Member TeamStore r => Bool -> TeamMemberList -> Galley r [UserId] handleList enableIndexedBillingTeamMembers list = case list ^. teamMemberListType of ListTruncated -> if enableIndexedBillingTeamMembers - then fetchFromDB + then liftSem $ fetchFromDB else do Log.warn $ field "team" (toByteString tid) diff --git a/services/galley/src/Galley/Intra/Push.hs b/services/galley/src/Galley/Intra/Push.hs index 15f67076140..71292655ac5 100644 --- a/services/galley/src/Galley/Intra/Push.hs +++ b/services/galley/src/Galley/Intra/Push.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE StrictData #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -25,9 +23,6 @@ module Galley.Intra.Push newConversationEventPush, newPush1, newPushLocal1, - push, - push1, - pushSome, PushEvent (..), -- * Push Configuration @@ -51,211 +46,5 @@ module Galley.Intra.Push ) where -import Bilge hiding (options) -import Bilge.RPC -import Bilge.Retry -import Control.Lens (makeLenses, set, view, (.~), (^.)) -import Control.Monad.Catch -import Control.Retry -import Data.Aeson (Object) -import Data.Domain -import Data.Id (ConnId, UserId) -import Data.Json.Util -import Data.List.Extra (chunksOf) -import Data.List.NonEmpty (nonEmpty) -import Data.List1 -import Data.Misc -import Data.Qualified -import Data.Range -import qualified Data.Set as Set -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Lazy as LT -import Galley.App -import Galley.Effects -import Galley.Options -import Galley.Types -import qualified Galley.Types.Teams as Teams -import Gundeck.Types.Push.V2 (RecipientClients (..)) +import Galley.Intra.Push.Internal import qualified Gundeck.Types.Push.V2 as Gundeck -import Imports hiding (forkIO) -import Network.HTTP.Types.Method -import Safe (headDef, tailDef) -import System.Logger.Class hiding (new) -import UnliftIO.Async (mapConcurrently) -import UnliftIO.Concurrent (forkIO) -import Util.Options -import qualified Wire.API.Event.FeatureConfig as FeatureConfig - -data PushEvent - = ConvEvent Event - | TeamEvent Teams.Event - | FeatureConfigEvent FeatureConfig.Event - -pushEventJson :: PushEvent -> Object -pushEventJson (ConvEvent e) = toJSONObject e -pushEventJson (TeamEvent e) = toJSONObject e -pushEventJson (FeatureConfigEvent e) = toJSONObject e - -type Recipient = RecipientBy UserId - -data RecipientBy user = Recipient - { _recipientUserId :: user, - _recipientClients :: RecipientClients - } - deriving stock (Functor, Foldable, Traversable) - -makeLenses ''RecipientBy - -recipient :: LocalMember -> Recipient -recipient = userRecipient . lmId - -userRecipient :: user -> RecipientBy user -userRecipient u = Recipient u RecipientClientsAll - -type Push = PushTo UserId - -data PushTo user = Push - { _pushConn :: Maybe ConnId, - _pushTransient :: Bool, - _pushRoute :: Gundeck.Route, - _pushNativePriority :: Maybe Gundeck.Priority, - _pushAsync :: Bool, - pushOrigin :: Maybe UserId, - _pushRecipients :: List1 (RecipientBy user), - pushJson :: Object, - pushRecipientListType :: Teams.ListType - } - deriving stock (Functor, Foldable, Traversable) - -makeLenses ''PushTo - -newPush1 :: Teams.ListType -> Maybe UserId -> PushEvent -> List1 Recipient -> Push -newPush1 recipientListType from e rr = - Push - { _pushConn = Nothing, - _pushTransient = False, - _pushRoute = Gundeck.RouteAny, - _pushNativePriority = Nothing, - _pushAsync = False, - pushRecipientListType = recipientListType, - pushJson = pushEventJson e, - pushOrigin = from, - _pushRecipients = rr - } - -newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push -newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr - -newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push -newPush _ _ _ [] = Nothing -newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) - -newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push -newPushLocal lt uid e rr = newPush lt (Just uid) e rr - -newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push -newConversationEventPush localDomain e users = - let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) - in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) - --- | Asynchronously send a single push, chunking it into multiple --- requests if there are more than 128 recipients. -push1 :: Member GundeckAccess r => Push -> Galley r () -push1 p = push (list1 p []) - -pushSome :: Member GundeckAccess r => [Push] -> Galley r () -pushSome [] = return () -pushSome (x : xs) = push (list1 x xs) - -push :: Member GundeckAccess r => List1 Push -> Galley r () -push ps = do - let (localPushes, remotePushes) = foldMap (bimap toList toList . splitPush) (toList ps) - traverse_ (pushLocal . List1) (nonEmpty localPushes) - traverse_ (pushRemote . List1) (nonEmpty remotePushes) - where - splitPush :: Push -> (Maybe (PushTo UserId), Maybe (PushTo UserId)) - splitPush p = - (mkPushTo localRecipients p, mkPushTo remoteRecipients p) - where - localRecipients = toList $ _pushRecipients p - remoteRecipients = [] -- FUTUREWORK: deal with remote sending - mkPushTo :: [RecipientBy a] -> PushTo b -> Maybe (PushTo a) - mkPushTo recipients p = - nonEmpty recipients <&> \nonEmptyRecipients -> - p {_pushRecipients = List1 nonEmptyRecipients} - --- | Asynchronously send multiple pushes, aggregating them into as --- few requests as possible, such that no single request targets --- more than 128 recipients. -pushLocal :: Member GundeckAccess r => List1 (PushTo UserId) -> Galley r () -pushLocal ps = do - limit <- fanoutLimit - opts <- view options - -- Do not fan out for very large teams - let (asyncs, sync) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) - forM_ (pushes asyncs) $ callAsync "gundeck" . gundeckReq opts - void . liftGalley0 $ mapConcurrently (call0 "gundeck" . gundeckReq opts) (pushes sync) - return () - where - pushes = fst . foldr chunk ([], 0) - chunk p (pss, !n) = - let r = recipientList p - nr = length r - in if n + nr > maxRecipients - then - let pss' = map (pure . toPush p) (chunksOf maxRecipients r) - in (pss' ++ pss, 0) - else - let hd = headDef [] pss - tl = tailDef [] pss - in ((toPush p r : hd) : tl, n + nr) - maxRecipients = 128 - recipientList p = map (toRecipient p) . toList $ _pushRecipients p - toPush p r = - let pload = Gundeck.singletonPayload (pushJson p) - in Gundeck.newPush (pushOrigin p) (unsafeRange (Set.fromList r)) pload - & Gundeck.pushOriginConnection .~ _pushConn p - & Gundeck.pushTransient .~ _pushTransient p - & maybe id (set Gundeck.pushNativePriority) (_pushNativePriority p) - toRecipient p r = - Gundeck.recipient (_recipientUserId r) (_pushRoute p) - & Gundeck.recipientClients .~ _recipientClients r - -- Ensure that under no circumstances we exceed the threshold - removeIfLargeFanout limit = - filter - ( \p -> - (pushRecipientListType p == Teams.ListComplete) - && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) - ) - --- instead of IdMapping, we could also just take qualified IDs -pushRemote :: List1 (PushTo UserId) -> Galley r () -pushRemote _ps = do - -- FUTUREWORK(federation, #1261): send these to the other backends - pure () - ------------------------------------------------------------------------------ --- Helpers - -gundeckReq :: Opts -> [Gundeck.Push] -> Request -> Request -gundeckReq o ps = - host (encodeUtf8 $ o ^. optGundeck . epHost) - . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) - . method POST - . path "/i/push/v2" - . json ps - . expect2xx - -callAsync :: Member GundeckAccess r => LT.Text -> (Request -> Request) -> Galley r () -callAsync n r = liftGalley0 . void . forkIO $ void (call0 n r) `catches` handlers - where - handlers = - [ Handler $ \(x :: RPCException) -> err (rpcExceptionMsg x), - Handler $ \(x :: SomeException) -> err $ "remote" .= n ~~ msg (show x) - ] - -call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LByteString)) -call0 n r = recovering x3 rpcHandlers (const (rpc n r)) - -x3 :: RetryPolicy -x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs new file mode 100644 index 00000000000..6c4c7aefbca --- /dev/null +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2021 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Intra.Push.Internal where + +import Bilge hiding (options) +import Control.Lens (makeLenses, set, view, (.~)) +import Data.Aeson (Object) +import Data.Domain +import Data.Id (ConnId, UserId) +import Data.Json.Util +import Data.List.Extra (chunksOf) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List1 +import Data.Qualified +import Data.Range +import qualified Data.Set as Set +import Galley.Env +import Galley.Intra.Util +import Galley.Types +import qualified Galley.Types.Teams as Teams +import Gundeck.Types.Push.V2 (RecipientClients (..)) +import qualified Gundeck.Types.Push.V2 as Gundeck +import Imports hiding (forkIO) +import Safe (headDef, tailDef) +import UnliftIO.Async (mapConcurrently) +import qualified Wire.API.Event.FeatureConfig as FeatureConfig + +data PushEvent + = ConvEvent Event + | TeamEvent Teams.Event + | FeatureConfigEvent FeatureConfig.Event + +pushEventJson :: PushEvent -> Object +pushEventJson (ConvEvent e) = toJSONObject e +pushEventJson (TeamEvent e) = toJSONObject e +pushEventJson (FeatureConfigEvent e) = toJSONObject e + +data RecipientBy user = Recipient + { _recipientUserId :: user, + _recipientClients :: RecipientClients + } + deriving stock (Functor, Foldable, Traversable) + +makeLenses ''RecipientBy + +type Recipient = RecipientBy UserId + +data PushTo user = Push + { _pushConn :: Maybe ConnId, + _pushTransient :: Bool, + _pushRoute :: Gundeck.Route, + _pushNativePriority :: Maybe Gundeck.Priority, + _pushAsync :: Bool, + pushOrigin :: Maybe UserId, + _pushRecipients :: List1 (RecipientBy user), + pushJson :: Object, + pushRecipientListType :: Teams.ListType + } + deriving stock (Functor, Foldable, Traversable) + +makeLenses ''PushTo + +type Push = PushTo UserId + +push :: Foldable f => f Push -> IntraM () +push ps = do + let pushes = foldMap (toList . mkPushTo) ps + traverse_ pushLocal (nonEmpty pushes) + where + mkPushTo :: PushTo a -> Maybe (PushTo a) + mkPushTo p = + nonEmpty (toList (_pushRecipients p)) <&> \nonEmptyRecipients -> + p {_pushRecipients = List1 nonEmptyRecipients} + +-- | Asynchronously send multiple pushes, aggregating them into as +-- few requests as possible, such that no single request targets +-- more than 128 recipients. +pushLocal :: NonEmpty (PushTo UserId) -> IntraM () +pushLocal ps = do + opts <- view options + let limit = currentFanoutLimit opts + -- Do not fan out for very large teams + let (asyncs, syncs) = partition _pushAsync (removeIfLargeFanout limit $ toList ps) + traverse_ (asyncCall Gundeck . json) (pushes asyncs) + void $ mapConcurrently (call Gundeck . json) (pushes syncs) + where + pushes = fst . foldr chunk ([], 0) + chunk p (pss, !n) = + let r = recipientList p + nr = length r + in if n + nr > maxRecipients + then + let pss' = map (pure . toPush p) (chunksOf maxRecipients r) + in (pss' ++ pss, 0) + else + let hd = headDef [] pss + tl = tailDef [] pss + in ((toPush p r : hd) : tl, n + nr) + maxRecipients = 128 + recipientList p = map (toRecipient p) . toList $ _pushRecipients p + toPush p r = + let pload = Gundeck.singletonPayload (pushJson p) + in Gundeck.newPush (pushOrigin p) (unsafeRange (Set.fromList r)) pload + & Gundeck.pushOriginConnection .~ _pushConn p + & Gundeck.pushTransient .~ _pushTransient p + & maybe id (set Gundeck.pushNativePriority) (_pushNativePriority p) + toRecipient p r = + Gundeck.recipient (_recipientUserId r) (_pushRoute p) + & Gundeck.recipientClients .~ _recipientClients r + -- Ensure that under no circumstances we exceed the threshold + removeIfLargeFanout limit = + filter + ( \p -> + (pushRecipientListType p == Teams.ListComplete) + && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) + ) + +recipient :: LocalMember -> Recipient +recipient = userRecipient . lmId + +userRecipient :: user -> RecipientBy user +userRecipient u = Recipient u RecipientClientsAll + +newPush1 :: Teams.ListType -> Maybe UserId -> PushEvent -> List1 Recipient -> Push +newPush1 recipientListType from e rr = + Push + { _pushConn = Nothing, + _pushTransient = False, + _pushRoute = Gundeck.RouteAny, + _pushNativePriority = Nothing, + _pushAsync = False, + pushRecipientListType = recipientListType, + pushJson = pushEventJson e, + pushOrigin = from, + _pushRecipients = rr + } + +newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push +newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr + +newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push +newPush _ _ _ [] = Nothing +newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) + +newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push +newPushLocal lt uid e rr = newPush lt (Just uid) e rr + +newConversationEventPush :: Domain -> Event -> [UserId] -> Maybe Push +newConversationEventPush localDomain e users = + let musr = guard (localDomain == qDomain (evtFrom e)) $> qUnqualified (evtFrom e) + in newPush Teams.ListComplete musr (ConvEvent e) (map userRecipient users) diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index c10f3109d38..ce9f569a60d 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -23,19 +23,14 @@ where import Bilge import Data.ByteString.Conversion import Data.Id -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method -- | Notify Spar that a team is being deleted. -deleteTeam :: Member SparAccess r => TeamId -> Galley r () +deleteTeam :: TeamId -> IntraM () deleteTeam tid = do - (h, p) <- sparReq - _ <- - callSpar $ - method DELETE . host h . port p - . paths ["i", "teams", toByteString' tid] - . expect2xx - pure () + void . call Spar $ + method DELETE + . paths ["i", "teams", toByteString' tid] + . expect2xx diff --git a/services/galley/src/Galley/Intra/Team.hs b/services/galley/src/Galley/Intra/Team.hs index 50cdcdd345f..a6b8d96af1a 100644 --- a/services/galley/src/Galley/Intra/Team.hs +++ b/services/galley/src/Galley/Intra/Team.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- Copyright (C) 2021 Wire Swiss GmbH -- -- This program is free software: you can redistribute it and/or modify it under -- the terms of the GNU Affero General Public License as published by the Free @@ -22,20 +22,17 @@ import Bilge.RPC import Brig.Types.Team import Data.ByteString.Conversion import Data.Id -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error -getSize :: Member BrigAccess r => TeamId -> Galley r TeamSize +getSize :: TeamId -> IntraM TeamSize getSize tid = do - (h, p) <- brigReq r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/teams", toByteString' tid, "size"] . expect2xx parseResponse (mkError status502 "server-error") r diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index faea13c43ea..0a08a634e0e 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -17,28 +17,23 @@ module Galley.Intra.User ( getConnections, - getConnectionsUnqualified0, getConnectionsUnqualified, putConnectionInternal, deleteBot, reAuthUser, lookupActivatedUsers, - getUser, getUsers, deleteUser, getContactList, chunkify, getRichInfoMultiUser, - - -- * Internal - deleteBot0, ) where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Brig.Types.Connection (Relation (..), UpdateConnectionsInternal (..), UserIds (..)) -import Brig.Types.Intra +import qualified Brig.Types.Intra as Brig import Brig.Types.User (User) import Control.Monad.Catch (throwM) import Data.ByteString.Char8 (pack) @@ -46,8 +41,6 @@ import qualified Data.ByteString.Char8 as BSC import Data.ByteString.Conversion import Data.Id import Data.Qualified -import Galley.App -import Galley.Effects import Galley.Intra.Util import Imports import Network.HTTP.Client (HttpExceptionContent (..)) @@ -65,24 +58,14 @@ import Wire.API.User.RichInfo (RichInfo) -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatusUnqualified'. getConnectionsUnqualified :: - Member BrigAccess r => - [UserId] -> - Maybe [UserId] -> - Maybe Relation -> - Galley r [ConnectionStatus] -getConnectionsUnqualified uFrom uTo rlt = - liftGalley0 $ getConnectionsUnqualified0 uFrom uTo rlt - -getConnectionsUnqualified0 :: [UserId] -> Maybe [UserId] -> Maybe Relation -> - Galley0 [ConnectionStatus] -getConnectionsUnqualified0 uFrom uTo rlt = do - (h, p) <- brigReq + IntraM [ConnectionStatus] +getConnectionsUnqualified uFrom uTo rlt = do r <- - call0 "brig" $ - method POST . host h . port p + call Brig $ + method POST . path "/i/users/connections-status" . maybe id rfilter rlt . json ConnectionsStatusRequest {csrFrom = uFrom, csrTo = uTo} @@ -97,53 +80,57 @@ getConnectionsUnqualified0 uFrom uTo rlt = do -- -- When a connection does not exist, it is skipped. -- Calls 'Brig.API.Internal.getConnectionsStatus'. -getConnections :: Member BrigAccess r => [UserId] -> Maybe [Qualified UserId] -> Maybe Relation -> Galley r [ConnectionStatusV2] +getConnections :: + [UserId] -> + Maybe [Qualified UserId] -> + Maybe Relation -> + IntraM [ConnectionStatusV2] getConnections [] _ _ = pure [] getConnections uFrom uTo rlt = do - (h, p) <- brigReq r <- - callBrig $ - method POST . host h . port p + call Brig $ + method POST . path "/i/users/connections-status/v2" . json (ConnectionsStatusRequestV2 uFrom uTo rlt) . expect2xx parseResponse (mkError status502 "server-error") r -putConnectionInternal :: Member BrigAccess r => UpdateConnectionsInternal -> Galley r Status +putConnectionInternal :: + UpdateConnectionsInternal -> + IntraM Status putConnectionInternal updateConn = do - (h, p) <- brigReq response <- - callBrig $ - method PUT . host h . port p + call Brig $ + method PUT . paths ["/i/connections/connection-update"] . json updateConn pure $ responseStatus response -deleteBot0 :: ConvId -> BotId -> Galley0 () -deleteBot0 cid bot = do - (h, p) <- brigReq +deleteBot :: + ConvId -> + BotId -> + IntraM () +deleteBot cid bot = do void $ - call0 "brig" $ - method DELETE . host h . port p + call Brig $ + method DELETE . path "/bot/self" . header "Z-Type" "bot" . header "Z-Bot" (toByteString' bot) . header "Z-Conversation" (toByteString' cid) . expect2xx --- | Calls 'Brig.Provider.API.botGetSelfH'. -deleteBot :: Member BotAccess r => ConvId -> BotId -> Galley r () -deleteBot cid bot = liftGalley0 $ deleteBot0 cid bot - -- | Calls 'Brig.User.API.Auth.reAuthUserH'. -reAuthUser :: Member BrigAccess r => UserId -> ReAuthUser -> Galley r Bool +reAuthUser :: + UserId -> + Brig.ReAuthUser -> + IntraM Bool reAuthUser uid auth = do - (h, p) <- brigReq let req = - method GET . host h . port p + method GET . paths ["/i/users", toByteString' uid, "reauthenticate"] . json auth - st <- statusCode . responseStatus <$> callBrig (check [status200, status403] . req) + st <- statusCode . responseStatus <$> call Brig (check [status200, status403] . req) return $ st == 200 check :: [Status] -> Request -> Request @@ -156,13 +143,12 @@ check allowed r = } -- | Calls 'Brig.API.listActivatedAccountsH'. -lookupActivatedUsers :: Member BrigAccess r => [UserId] -> Galley r [User] +lookupActivatedUsers :: [UserId] -> IntraM [User] lookupActivatedUsers = chunkify $ \uids -> do - (h, p) <- brigReq let users = BSC.intercalate "," $ toByteString' <$> uids r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . path "/i/users" . queryItem "ids" users . expect2xx @@ -183,49 +169,41 @@ chunkify doChunk keys = mconcat <$> (doChunk `mapM` chunks keys) chunks uids = case splitAt maxSize uids of (h, t) -> h : chunks t -- | Calls 'Brig.API.listActivatedAccountsH'. -getUser :: Member BrigAccess r => UserId -> Galley r (Maybe UserAccount) -getUser uid = listToMaybe <$> getUsers [uid] - --- | Calls 'Brig.API.listActivatedAccountsH'. -getUsers :: Member BrigAccess r => [UserId] -> Galley r [UserAccount] +getUsers :: [UserId] -> IntraM [Brig.UserAccount] getUsers = chunkify $ \uids -> do - (h, p) <- brigReq resp <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . path "/i/users" . queryItem "ids" (BSC.intercalate "," (toByteString' <$> uids)) . expect2xx pure . fromMaybe [] . responseJsonMaybe $ resp -- | Calls 'Brig.API.deleteUserNoVerifyH'. -deleteUser :: Member BrigAccess r => UserId -> Galley r () +deleteUser :: UserId -> IntraM () deleteUser uid = do - (h, p) <- brigReq void $ - callBrig $ - method DELETE . host h . port p + call Brig $ + method DELETE . paths ["/i/users", toByteString' uid] . expect2xx -- | Calls 'Brig.API.getContactListH'. -getContactList :: Member BrigAccess r => UserId -> Galley r [UserId] +getContactList :: UserId -> IntraM [UserId] getContactList uid = do - (h, p) <- brigReq r <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/users", toByteString' uid, "contacts"] . expect2xx cUsers <$> parseResponse (mkError status502 "server-error") r -- | Calls 'Brig.API.Internal.getRichInfoMultiH' -getRichInfoMultiUser :: Member BrigAccess r => [UserId] -> Galley r [(UserId, RichInfo)] +getRichInfoMultiUser :: [UserId] -> IntraM [(UserId, RichInfo)] getRichInfoMultiUser = chunkify $ \uids -> do - (h, p) <- brigReq resp <- - callBrig $ - method GET . host h . port p + call Brig $ + method GET . paths ["/i/users/rich-info"] . queryItem "ids" (toByteString' (List uids)) . expect2xx diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index a9dc8ff8820..203c6ab3901 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -16,56 +18,120 @@ -- with this program. If not, see . module Galley.Intra.Util - ( brigReq, - sparReq, - call0, - callBrig, - callSpar, - callBot, - x1, + ( IntraComponent (..), + IntraM, + embedIntra, + call, + asyncCall, ) where import Bilge hiding (getHeader, options, statusCode) import Bilge.RPC import Bilge.Retry -import Control.Lens (view) +import Cassandra (MonadClient (..), runClient) +import Control.Lens (locally, view, (^.)) +import Control.Monad.Catch import Control.Retry import qualified Data.ByteString.Lazy as LB import Data.Misc (portNumber) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT -import Galley.App -import Galley.Effects +import Galley.Env import Galley.Options -import Imports +import Imports hiding (log) +import Network.HTTP.Types +import Polysemy +import qualified Polysemy.Reader as P +import System.Logger +import qualified System.Logger.Class as LC import Util.Options -brigReq :: Galley r (ByteString, Word16) -brigReq = do - h <- encodeUtf8 <$> view (options . optBrig . epHost) - p <- portNumber . fromIntegral <$> view (options . optBrig . epPort) - return (h, p) +data IntraComponent = Brig | Spar | Gundeck + deriving (Show) + +componentName :: IntraComponent -> String +componentName Brig = "brig" +componentName Spar = "spar" +componentName Gundeck = "gundeck" + +componentRequest :: IntraComponent -> Opts -> Request -> Request +componentRequest Brig o = + host (encodeUtf8 (o ^. optBrig . epHost)) + . port (portNumber (fromIntegral (o ^. optBrig . epPort))) +componentRequest Spar o = + host (encodeUtf8 (o ^. optSpar . epHost)) + . port (portNumber (fromIntegral (o ^. optSpar . epPort))) +componentRequest Gundeck o = + host (encodeUtf8 $ o ^. optGundeck . epHost) + . port (portNumber $ fromIntegral (o ^. optGundeck . epPort)) + . method POST + . path "/i/push/v2" + . expect2xx -sparReq :: Galley r (ByteString, Word16) -sparReq = do - h <- encodeUtf8 <$> view (options . optSpar . epHost) - p <- portNumber . fromIntegral <$> view (options . optSpar . epPort) - return (h, p) +componentRetryPolicy :: IntraComponent -> RetryPolicy +componentRetryPolicy Brig = x1 +componentRetryPolicy Spar = x1 +componentRetryPolicy Gundeck = x3 --- gundeckReq lives in Galley.Intra.Push +embedIntra :: + Members '[Embed IO, P.Reader Env] r => + IntraM a -> + Sem r a +embedIntra action = do + env <- P.ask + embed $ runHttpT (env ^. manager) (runReaderT (unIntraM action) env) -call0 :: LT.Text -> (Request -> Request) -> Galley0 (Response (Maybe LB.ByteString)) -call0 n r = liftGalley0 $ recovering x1 rpcHandlers (const (rpc n r)) +newtype IntraM a = IntraM {unIntraM :: ReaderT Env Http a} + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadHttp, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader Env, + MonadUnliftIO + ) -callBrig :: Member BrigAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callBrig r = liftGalley0 $ call0 "brig" r +instance HasRequestId IntraM where + getRequestId = IntraM $ view reqId -callSpar :: Member SparAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callSpar r = liftGalley0 $ call0 "spar" r +instance MonadClient IntraM where + liftClient m = do + cs <- view cstate + liftIO $ runClient cs m + localState f = locally cstate f -callBot :: Member BotAccess r => (Request -> Request) -> Galley r (Response (Maybe LB.ByteString)) -callBot r = liftGalley0 $ call0 "brig" r +instance LC.MonadLogger IntraM where + log lvl m = do + env <- ask + log (env ^. applog) lvl (reqIdMsg (env ^. reqId) . m) + +call :: + IntraComponent -> + (Request -> Request) -> + IntraM (Response (Maybe LB.ByteString)) +call comp r = do + o <- view options + let r0 = componentRequest comp o + let n = LT.pack (componentName comp) + recovering (componentRetryPolicy comp) rpcHandlers (const (rpc n (r . r0))) + +asyncCall :: IntraComponent -> (Request -> Request) -> IntraM () +asyncCall comp req = void $ do + let n = LT.pack (componentName comp) + forkIO $ catches (void (call comp req)) (handlers n) + where + handlers n = + [ Handler $ \(x :: RPCException) -> LC.err (rpcExceptionMsg x), + Handler $ \(x :: SomeException) -> LC.err $ "remote" .= n ~~ msg (show x) + ] x1 :: RetryPolicy x1 = limitRetries 1 + +x3 :: RetryPolicy +x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 7218a22c37c..a6e2e751531 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -37,7 +37,7 @@ import Galley.API.Federation (federationSitemap) import qualified Galley.API.Internal as Internal import Galley.App import qualified Galley.App as App -import qualified Galley.Data as Data +import Galley.Cassandra import Galley.Options (Opts, optGalley) import qualified Galley.Queue as Q import Imports @@ -82,7 +82,7 @@ mkApp o = do e <- App.createEnv m o let l = e ^. App.applog runClient (e ^. cstate) $ - versionCheck Data.schemaVersion + versionCheck schemaVersion let finalizer = do Log.info l $ Log.msg @Text "Galley application finished." Log.flush l diff --git a/services/galley/src/Galley/Types/ToUserRole.hs b/services/galley/src/Galley/Types/ToUserRole.hs new file mode 100644 index 00000000000..d68b87d514e --- /dev/null +++ b/services/galley/src/Galley/Types/ToUserRole.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Galley.Types.ToUserRole where + +import Data.Id +import Wire.API.Conversation.Role + +class ToUserRole a where + toUserRole :: a -> (UserId, RoleName) + +instance ToUserRole (UserId, RoleName) where + toUserRole x = x + +instance ToUserRole UserId where + toUserRole uid = (uid, roleNameWireAdmin) diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index a533cdbd513..b3aad0e32df 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -25,18 +25,21 @@ module Galley.Validation where import Control.Lens -import Control.Monad.Catch import Data.Range import Galley.API.Error -import Galley.App import Galley.Options import Imports +import Polysemy +import Polysemy.Error -rangeChecked :: Within a n m => a -> Galley r (Range n m a) +rangeChecked :: (Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) rangeChecked = either throwErr return . checkedEither {-# INLINE rangeChecked #-} -rangeCheckedMaybe :: Within a n m => Maybe a -> Galley r (Maybe (Range n m a)) +rangeCheckedMaybe :: + (Member (Error InvalidInput) r, Within a n m) => + Maybe a -> + Sem r (Maybe (Range n m a)) rangeCheckedMaybe Nothing = return Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -45,14 +48,17 @@ rangeCheckedMaybe (Just a) = Just <$> rangeChecked a newtype ConvSizeChecked f a = ConvSizeChecked {fromConvSize :: f a} deriving (Functor, Foldable, Traversable) -checkedConvSize :: Foldable f => f a -> Galley r (ConvSizeChecked f a) -checkedConvSize x = do - o <- view options +checkedConvSize :: + (Member (Error InvalidInput) r, Foldable f) => + Opts -> + f a -> + Sem r (ConvSizeChecked f a) +checkedConvSize o x = do let minV :: Integer = 0 limit = o ^. optSettings . setMaxConvSize - 1 if length x <= fromIntegral limit then return (ConvSizeChecked x) else throwErr (errorMsg minV limit "") -throwErr :: String -> Galley r a -throwErr = throwM . invalidRange . fromString +throwErr :: Member (Error InvalidInput) r => String -> Sem r a +throwErr = throw . InvalidRange . fromString diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3c2cf9e9184..3bdb964a400 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -46,6 +46,7 @@ import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LBS import qualified Data.Code as Code import Data.Domain (Domain (Domain), domainText) +import Data.Either.Extra (eitherToMaybe) import Data.Id import Data.Json.Util (toBase64Text, toUTCTimeMillis) import Data.List.NonEmpty (NonEmpty (..)) @@ -86,7 +87,7 @@ import Wire.API.Conversation.Action import qualified Wire.API.Federation.API.Brig as FederatedBrig import Wire.API.Federation.API.Galley ( Api (onConversationUpdated), - ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuOrigUserId), + ConversationUpdate (cuAction, cuAlreadyPresentUsers, cuConvId, cuOrigUserId), GetConversationsResponse (..), RemoteConvMembers (..), RemoteConversation (..), @@ -583,9 +584,12 @@ postCryptoMessage5 = do where listToByteString = BS.intercalate "," . map toByteString' --- | Sets up a conversation on Backend A known as "owning backend". One of the --- users from Backend A will send the message, it is expected that message will --- be sent successfully. +-- | Sets up a conversation on Backend A known as "owning backend". All user's +-- on this backend have names begining with 'A'. The conversation has a couple +-- of users from backend B and one user from backend C. +-- +-- One of the users from Backend A will send the message, it is expected that +-- message will be sent successfully. postMessageQualifiedLocalOwningBackendSuccess :: TestM () postMessageQualifiedLocalOwningBackendSuccess = do -- WS receive timeout @@ -595,66 +599,123 @@ postMessageQualifiedLocalOwningBackendSuccess = do -- Domain which owns the converstaion owningDomain <- viewFederationDomain - (aliceOwningDomain, aliceClient) <- randomUserWithClientQualified (someLastPrekeys !! 0) - (bobOwningDomain, bobClient) <- randomUserWithClientQualified (someLastPrekeys !! 1) - bobClient2 <- randomClient (qUnqualified bobOwningDomain) (someLastPrekeys !! 2) - (chadOwningDomain, chadClient) <- randomUserWithClientQualified (someLastPrekeys !! 3) - deeId <- randomId - deeClient <- liftIO $ generate arbitrary - let remoteDomain = Domain "far-away.example.com" - deeRemote = Qualified deeId remoteDomain + (alice, aliceClient) <- randomUserWithClientQualified (someLastPrekeys !! 0) + (alex, alexClient) <- randomUserWithClientQualified (someLastPrekeys !! 1) + alexClient2 <- randomClient (qUnqualified alex) (someLastPrekeys !! 2) + (amy, amyClient) <- randomUserWithClientQualified (someLastPrekeys !! 3) - let aliceUnqualified = qUnqualified aliceOwningDomain - bobUnqualified = qUnqualified bobOwningDomain - chadUnqualified = qUnqualified chadOwningDomain + let bDomain = Domain "b.far-away.example.com" + cDomain = Domain "c.far-away.example.com" + randomQuidAndClients d n = (,) <$> randomQualifiedId d <*> liftIO (replicateM n $ generate arbitrary) + (bob, [bobClient]) <- randomQuidAndClients bDomain 1 + (bart, [bartClient1, bartClient2]) <- randomQuidAndClients bDomain 2 + (carl, [carlClient]) <- randomQuidAndClients cDomain 1 - connectLocalQualifiedUsers aliceUnqualified (list1 bobOwningDomain [chadOwningDomain]) - connectWithRemoteUser aliceUnqualified deeRemote + let aliceU = qUnqualified alice + alexU = qUnqualified alex + amyU = qUnqualified amy + + connectLocalQualifiedUsers aliceU (list1 alex [amy]) + forM_ [bob, bart, carl] $ connectWithRemoteUser aliceU - -- FUTUREWORK: Do this test with more than one remote domains resp <- postConvWithRemoteUsers - aliceUnqualified - defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} + aliceU + defNewConv {newConvQualifiedUsers = [alex, amy, bob, bart, carl]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp - WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do + WS.bracketAsClientRN cannon [(alexU, alexClient), (alexU, alexClient2), (amyU, amyClient)] $ \[wsAlex1, wsAlex2, wsAmy] -> do let message = - [ (bobOwningDomain, bobClient, "text-for-bob"), - (bobOwningDomain, bobClient2, "text-for-bob2"), - (chadOwningDomain, chadClient, "text-for-chad"), - (deeRemote, deeClient, "text-for-dee") + [ (alex, alexClient, "text-for-alex"), + (alex, alexClient2, "text-for-alex2"), + (amy, amyClient, "text-for-amy"), + (bob, bobClient, "text-for-bob"), + (bart, bartClient1, "text-for-bart1"), + (bart, bartClient2, "text-for-bart2"), + (carl, carlClient, "text-for-carl") ] - let brigApi = + let mkPubClient c = PubClient c Nothing + brigApi d = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> - pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) + pure $ + if + | d == bDomain -> + UserMap . Map.fromList $ + [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), + (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) + ] + | d == cDomain -> UserMap (Map.singleton (qUnqualified carl) (Set.singleton (PubClient carlClient Nothing))) + | otherwise -> mempty } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> pure () } - (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi + (resp2, requests) <- postProteusMessageQualifiedWithMockFederator aliceU aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do const 201 === statusCode assertMismatchQualified mempty mempty mempty mempty - + let encodedTextForAlex1 = toBase64Text "text-for-alex" + encodedTextForAlex2 = toBase64Text "text-for-alex2" + encodedTextForAmy = toBase64Text "text-for-amy" + encodedTextForBob = toBase64Text "text-for-bob" + encodedTextForBart1 = toBase64Text "text-for-bart1" + encodedTextForBart2 = toBase64Text "text-for-bart2" + encodedTextForCarl = toBase64Text "text-for-carl" + encodedData = toBase64Text "data" liftIO $ do - let expectedRequests = - [ (F.Brig, "get-user-clients"), - (F.Galley, "on-message-sent") - ] - forM_ (zip requests expectedRequests) $ \(req, (component, rpcPath)) -> do - F.domain req @?= domainText (qDomain deeRemote) - fmap F.component (F.request req) @?= Just component - fmap F.path (F.request req) @?= Just ("/federation/" <> rpcPath) - let encodedTextForBob = toBase64Text "text-for-bob" - encodedTextForChad = toBase64Text "text-for-chad" - encodedData = toBase64Text "data" - WS.assertMatch_ t wsBob (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient bobClient encodedTextForBob) - WS.assertMatch_ t wsChad (wsAssertOtr' encodedData convId aliceOwningDomain aliceClient chadClient encodedTextForChad) + let matchReq domain component r = F.domain r == domainText domain && (F.component <$> F.request r) == Just component + filterReq domain component = filter (matchReq domain component) requests + bBrigReq <- assertOne $ filterReq bDomain F.Brig + bGalleyReq <- assertOne $ filterReq bDomain F.Galley + cBrigReq <- assertOne $ filterReq cDomain F.Brig + cGalleyReq <- assertOne $ filterReq cDomain F.Galley + + (F.path <$> F.request bBrigReq) @?= Just "/federation/get-user-clients" + (sort . FederatedBrig.gucUsers <$> parseFedRequest bBrigReq) @?= Right (sort $ qUnqualified <$> [bob, bart]) + (F.path <$> F.request cBrigReq) @?= Just "/federation/get-user-clients" + parseFedRequest cBrigReq @?= Right (FederatedBrig.GetUserClients [qUnqualified carl]) + + (F.path <$> F.request bGalleyReq) @?= Just "/federation/on-message-sent" + bActualNotif <- assertRight $ parseFedRequest bGalleyReq + let bExpectedNotif = + FederatedGalley.RemoteMessage + { rmTime = FederatedGalley.rmTime bActualNotif, + rmData = Just $ toBase64Text "data", + rmSender = alice, + rmSenderClient = aliceClient, + rmConversation = qUnqualified convId, + rmPriority = Nothing, + rmPush = True, + rmTransient = False, + rmRecipients = + UserClientMap $ + Map.fromList + [ (qUnqualified bob, Map.singleton bobClient encodedTextForBob), + ( qUnqualified bart, + Map.fromList + [ (bartClient1, encodedTextForBart1), + (bartClient2, encodedTextForBart2) + ] + ) + ] + } + bActualNotif @?= bExpectedNotif + (F.path <$> F.request cGalleyReq) @?= Just "/federation/on-message-sent" + cActualNotif <- assertRight $ parseFedRequest cGalleyReq + let cExpectedNotif = + bExpectedNotif + { FederatedGalley.rmRecipients = + UserClientMap $ Map.fromList [(qUnqualified carl, Map.singleton carlClient encodedTextForCarl)] + } + cActualNotif @?= cExpectedNotif + + WS.assertMatch_ t wsAlex1 (wsAssertOtr' encodedData convId alice aliceClient alexClient encodedTextForAlex1) + WS.assertMatch_ t wsAlex2 (wsAssertOtr' encodedData convId alice aliceClient alexClient2 encodedTextForAlex2) + WS.assertMatch_ t wsAmy (wsAssertOtr' encodedData convId alice aliceClient amyClient encodedTextForAmy) -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is @@ -694,12 +755,12 @@ postMessageQualifiedLocalOwningBackendMissingClients = do let message = [(chadOwningDomain, chadClient, "text-for-chad")] -- FUTUREWORK: Mock federator and ensure that message is not propagated to remotes WS.bracketR2 cannon bobUnqualified chadUnqualified $ \(wsBob, wsChad) -> do - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = emptyFederatedGalley + galleyApi _ = emptyFederatedGalley (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi @@ -771,7 +832,7 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do ] -- FUTUREWORK: Mock federator and ensure that a message to Dee is sent - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \getUserClients -> let lookupClients uid @@ -780,7 +841,7 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do | otherwise = Nothing in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ FederatedBrig.gucUsers getUserClients } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> pure () } @@ -851,11 +912,11 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do defNewConv {newConvQualifiedUsers = [bobOwningDomain, chadOwningDomain, deeRemote]} let convId = (`Qualified` owningDomain) . decodeConvId $ resp - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = emptyFederatedGalley + galleyApi _ = emptyFederatedGalley -- Missing Bob, chadClient2 and Dee let message = [(chadOwningDomain, chadClient, "text-for-chad")] @@ -984,12 +1045,12 @@ postMessageQualifiedLocalOwningBackendFailedToSendClients = do (deeRemote, deeClient, "text-for-dee") ] - let brigApi = + let brigApi _ = emptyFederatedBrig { FederatedBrig.getUserClients = \_ -> pure $ UserMap (Map.singleton (qUnqualified deeRemote) (Set.singleton (PubClient deeClient Nothing))) } - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.onMessageSent = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } @@ -1023,13 +1084,13 @@ postMessageQualifiedRemoteOwningBackendFailure = do let remoteDomain = Domain "far-away.example.com" convId = Qualified convIdUnqualified remoteDomain - let galleyApi = + let galleyApi _ = emptyFederatedGalley { FederatedGalley.sendMessage = \_ _ -> throwError err503 {errBody = "Down for maintenance."} } (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll emptyFederatedBrig galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId [] "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi pure resp2 !!! do const 533 === statusCode @@ -1063,13 +1124,13 @@ postMessageQualifiedRemoteOwningBackendSuccess = do Message.mssFailedToSend = mempty } message = [(bobOwningDomain, bobClient, "text-for-bob"), (deeRemote, deeClient, "text-for-dee")] - galleyApi = + galleyApi _ = emptyFederatedGalley { FederatedGalley.sendMessage = \_ _ -> pure (FederatedGalley.MessageSendResponse (Right mss)) } (resp2, _requests) <- - postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll emptyFederatedBrig galleyApi + postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll (const emptyFederatedBrig) galleyApi pure resp2 !!! do const 201 === statusCode @@ -2001,8 +2062,8 @@ testDeleteTeamConversationWithRemoteMembers = do connectWithRemoteUser alice remoteBob - let brigApi = emptyFederatedBrig - galleyApi = + let brigApi _ = emptyFederatedBrig + galleyApi _ = emptyFederatedGalley { onConversationUpdated = \_domain _update -> pure () } @@ -2015,20 +2076,13 @@ testDeleteTeamConversationWithRemoteMembers = do !!! const 200 === statusCode liftIO $ do - let convUpdates = mapMaybe parseFedRequest received - convUpdate <- case (filter ((== ConversationActionDelete) . cuAction) convUpdates) of + let convUpdates = mapMaybe (eitherToMaybe . parseFedRequest) received + convUpdate <- case filter ((== ConversationActionDelete) . cuAction) convUpdates of [] -> assertFailure "No ConversationUpdate requests received" [convDelete] -> pure convDelete _ -> assertFailure "Multiple ConversationUpdate requests received" cuAlreadyPresentUsers convUpdate @?= [bobId] cuOrigUserId convUpdate @?= qalice - where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Maybe a - parseFedRequest fr = - case F.request fr of - Just r -> - (decode . cs) (F.body r) - Nothing -> Nothing testGetQualifiedLocalConv :: TestM () testGetQualifiedLocalConv = do @@ -3144,24 +3198,35 @@ removeUser = do c <- view tsCannon [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] + let bDomain = Domain "b.example.com" bart <- randomQualifiedId bDomain + berta <- randomQualifiedId bDomain + let cDomain = Domain "c.example.com" carl <- randomQualifiedId cDomain + let dDomain = Domain "d.example.com" + dwight <- randomQualifiedId dDomain + dory <- randomQualifiedId dDomain + connectUsers alice' (list1 alexDel' [amy']) connectWithRemoteUser alice' bart + connectWithRemoteUser alice' berta connectWithRemoteUser alexDel' bart connectWithRemoteUser alice' carl connectWithRemoteUser alexDel' carl + connectWithRemoteUser alice' dwight + connectWithRemoteUser alexDel' dory convA1 <- decodeConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing - convA2 <- decodeConvId <$> postConv alice' [alexDel', amy'] (Just "gossip2") [] Nothing Nothing + convA2 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, amy, berta, dwight]} convA3 <- decodeConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing convA4 <- decodeConvId <$> postConvWithRemoteUsers alice' defNewConv {newConvQualifiedUsers = [alexDel, bart, carl]} convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in + convD1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Dory will be in let qconvA1 = Qualified convA1 (qDomain alexDel) qconvA2 = Qualified convA2 (qDomain alexDel) @@ -3183,36 +3248,92 @@ removeUser = do FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] FederatedGalley.onConversationCreated fedGalleyClient bDomain $ nc convB2 bart [alexDel] FederatedGalley.onConversationCreated fedGalleyClient cDomain $ nc convC1 carl [alexDel] + FederatedGalley.onConversationCreated fedGalleyClient dDomain $ nc convD1 dory [alexDel] WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do + let handler :: F.FederatedRequest -> IO F.OutwardResponse + handler freq@(Domain . F.domain -> domain) + | domain == dDomain = + pure + ( F.OutwardResponseError + ( F.OutwardError + F.ConnectionRefused + "mocked: dDomain is unavailable" + ) + ) + | domain `elem` [bDomain, cDomain] = + case F.path <$> F.request freq of + (Just "/federation/leave-conversation") -> + pure (F.OutwardResponseBody (cs (encode (FederatedGalley.LeaveConversationResponse (Right ()))))) + (Just "federation/on-conversation-updated") -> + pure (F.OutwardResponseBody (cs (encode ()))) + other -> error $ "unmocked path " <> show other + | otherwise = error "unmocked domain" + (_, fedRequests) <- - withTempMockFederator (const (FederatedGalley.LeaveConversationResponse (Right ()))) $ + withTempMockFederator' handler $ deleteUser alexDel' !!! const 200 === statusCode - -- FUTUTREWORK: There should be 4 requests, one to each domain for telling - -- them that alex left the conversation hosted locally. Add assertions for - -- that and implement it. liftIO $ do - assertEqual ("expect exactly 2 federated requests in : " <> show fedRequests) 2 (length fedRequests) - bReq <- assertOne $ filter (\req -> F.domain req == domainText bDomain) fedRequests - cReq <- assertOne $ filter (\req -> F.domain req == domainText cDomain) fedRequests + assertEqual ("expect exactly 7 federated requests in : " <> show fedRequests) 7 (length fedRequests) + liftIO $ do + bReq <- assertOne $ filter (matchFedRequest bDomain "/federation/on-user-deleted/conversations") fedRequests fmap F.component (F.request bReq) @?= Just F.Galley fmap F.path (F.request bReq) @?= Just "/federation/on-user-deleted/conversations" Just (Right udcnB) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request bReq) sort (fromRange (FederatedGalley.udcnConversations udcnB)) @?= sort [convB1, convB2] FederatedGalley.udcnUser udcnB @?= qUnqualified alexDel - fmap F.component (F.request bReq) @?= Just F.Galley + liftIO $ do + cReq <- assertOne $ filter (matchFedRequest cDomain "/federation/on-user-deleted/conversations") fedRequests + fmap F.component (F.request cReq) @?= Just F.Galley fmap F.path (F.request cReq) @?= Just "/federation/on-user-deleted/conversations" Just (Right udcnC) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cReq) sort (fromRange (FederatedGalley.udcnConversations udcnC)) @?= sort [convC1] FederatedGalley.udcnUser udcnC @?= qUnqualified alexDel + liftIO $ do + dReq <- assertOne $ filter (matchFedRequest dDomain "/federation/on-user-deleted/conversations") fedRequests + fmap F.component (F.request dReq) @?= Just F.Galley + fmap F.path (F.request dReq) @?= Just "/federation/on-user-deleted/conversations" + Just (Right udcnD) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dReq) + sort (fromRange (FederatedGalley.udcnConversations udcnD)) @?= sort [convD1] + FederatedGalley.udcnUser udcnD @?= qUnqualified alexDel + + liftIO $ do WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ wsAssertMembersLeave qconvA1 alexDel [alexDel] WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel, wsAmy] $ wsAssertMembersLeave qconvA2 alexDel [alexDel] + + liftIO $ do + let bConvUpdateRPCs = filter (matchFedRequest bDomain "/federation/on-conversation-updated") fedRequests + bConvUpdatesEither :: [Either String ConversationUpdate] <- eitherDecode . LBS.fromStrict . F.body <$$> mapM (assertJust . F.request) bConvUpdateRPCs + bConvUpdates <- mapM assertRight bConvUpdatesEither + + bConvUpdatesA2 <- assertOne $ filter (\cu -> cuConvId cu == convA2) bConvUpdates + cuAction bConvUpdatesA2 @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers bConvUpdatesA2 @?= [qUnqualified berta] + + bConvUpdatesA4 <- assertOne $ filter (\cu -> cuConvId cu == convA4) bConvUpdates + cuAction bConvUpdatesA4 @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers bConvUpdatesA4 @?= [qUnqualified bart] + + liftIO $ do + cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "/federation/on-conversation-updated") fedRequests + Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request cConvUpdateRPC) + cuConvId convUpdate @?= convA4 + cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl] + + liftIO $ do + dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "/federation/on-conversation-updated") fedRequests + Just (Right convUpdate) <- pure $ fmap (eitherDecode . LBS.fromStrict . F.body) (F.request dConvUpdateRPC) + cuConvId convUpdate @?= convA2 + cuAction convUpdate @?= ConversationActionRemoveMembers (pure alexDel) + cuAlreadyPresentUsers convUpdate @?= [qUnqualified dwight] + -- Check memberships mems1 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA1 mems2 <- fmap cnvMembers . responseJsonError =<< getConv alice' convA2 diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 2665106b2d8..ae2c4d92aa7 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -22,7 +22,7 @@ import API.Util import Bilge import Bilge.Assert import Control.Lens hiding ((#)) -import Data.Aeson (FromJSON, ToJSON (..), eitherDecode) +import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS @@ -88,27 +88,42 @@ tests s = getConversationsAllFound :: TestM () getConversationsAllFound = do - bob <- randomUser - - -- create & get group conv - aliceQ <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") + bobQ <- randomQualifiedUser + let bob = qUnqualified bobQ + lBob = toLocalUnsafe (qDomain bobQ) (qUnqualified bobQ) + (rAlice, cnv1Id) <- generateRemoteAndConvId True lBob + let aliceQ = qUntagged rAlice carlQ <- randomQualifiedUser connectUsers bob (singleton (qUnqualified carlQ)) connectWithRemoteUser bob aliceQ + -- create & get group conv cnv2 <- responseJsonError =<< postConvWithRemoteUsers bob defNewConv {newConvQualifiedUsers = [aliceQ, carlQ]} - getConvs bob (Just $ Left [qUnqualified (cnvQualifiedId cnv2)]) Nothing !!! do - const 200 === statusCode - const (Just (Just [cnvQualifiedId cnv2])) - === fmap (fmap (map cnvQualifiedId . convList)) . responseJsonMaybe + -- create a one-to-one conversation between bob and alice + do + let createO2O = + UpsertOne2OneConversationRequest + { uooLocalUser = lBob, + uooRemoteUser = rAlice, + uooActor = LocalActor, + uooActorDesiredMembership = Included, + uooConvId = Just cnv1Id + } + UpsertOne2OneConversationResponse cnv1IdReturned <- + responseJsonError + =<< iUpsertOne2OneConversation createO2O + liftIO $ assertEqual "Mismatch in the generated conversation ID" cnv1IdReturned cnv1Id - -- FUTUREWORK: also create a one2one conversation + getConvs bob (Just . Left . fmap qUnqualified $ [cnv1Id, cnvQualifiedId cnv2]) Nothing !!! do + const 200 === statusCode + const (Just . Just . sort $ [cnv1Id, cnvQualifiedId cnv2]) + === fmap (fmap (sort . map cnvQualifiedId . convList)) . responseJsonMaybe -- get conversations @@ -119,7 +134,7 @@ getConversationsAllFound = do (qDomain aliceQ) ( GetConversationsRequest (qUnqualified aliceQ) - (map (qUnqualified . cnvQualifiedId) [cnv2]) + (map qUnqualified [cnv1Id, cnvQualifiedId cnv2]) ) let c2 = find ((== qUnqualified (cnvQualifiedId cnv2)) . rcnvId) convs @@ -854,49 +869,48 @@ sendMessage = do Map.keysSet (userClientMap (FedGalley.rmRecipients rm)) @?= Set.singleton chadId +-- | There are 3 backends in action here: +-- +-- - Backend A (local) has Alice and Alex +-- - Backend B has Bob and Bart +-- - Backend C has Carl +-- +-- Bob is in these convs: +-- - One2One Conv with Alice (ooConvId) +-- - Group conv with all users (groupConvId) +-- +-- When bob gets deleted, backend A gets an RPC from bDomain stating that bob is +-- deleted and they would like bob to leave these converstaions: +-- - ooConvId -> Causes Alice to be notified +-- - groupConvId -> Causes Alice and Alex to be notified +-- - extraConvId -> Ignored +-- - noBobConvId -> Ignored onUserDeleted :: TestM () onUserDeleted = do cannon <- view tsCannon - let eveDomain = Domain "eve.example.com" + let bDomain = Domain "b.far-away.example.com" + cDomain = Domain "c.far-away.example.com" alice <- qTagUnsafe <$> randomQualifiedUser - (bob, ooConvId) <- generateRemoteAndConvId True alice - let bobDomain = tDomain bob - charlie <- randomQualifiedUser - dee <- randomQualifiedId bobDomain - eve <- randomQualifiedId eveDomain + alex <- randomQualifiedUser + (bob, ooConvId) <- generateRemoteAndConvIdWithDomain bDomain True alice + bart <- randomQualifiedId bDomain + carl <- randomQualifiedId cDomain connectWithRemoteUser (tUnqualified alice) (qUntagged bob) - connectUsers (tUnqualified alice) (pure (qUnqualified charlie)) - connectWithRemoteUser (tUnqualified alice) dee - connectWithRemoteUser (tUnqualified alice) eve + connectUsers (tUnqualified alice) (pure (qUnqualified alex)) + connectWithRemoteUser (tUnqualified alice) bart + connectWithRemoteUser (tUnqualified alice) carl -- create 1-1 conversation between alice and bob - iUpsertOne2OneConversation - UpsertOne2OneConversationRequest - { uooLocalUser = alice, - uooRemoteUser = bob, - uooActor = LocalActor, - uooActorDesiredMembership = Included, - uooConvId = Nothing - } - !!! const 200 === statusCode - iUpsertOne2OneConversation - UpsertOne2OneConversationRequest - { uooLocalUser = alice, - uooRemoteUser = bob, - uooActor = RemoteActor, - uooActorDesiredMembership = Included, - uooConvId = Just ooConvId - } - !!! const 200 === statusCode + createOne2OneConvWithRemote alice bob -- create group conversation with everybody groupConvId <- decodeQualifiedConvId <$> ( postConvWithRemoteUsers (tUnqualified alice) - defNewConv {newConvQualifiedUsers = [qUntagged bob, charlie, dee, eve]} + defNewConv {newConvQualifiedUsers = [qUntagged bob, alex, bart, carl]} ( postConvQualified (tUnqualified alice) defNewConv {newConvQualifiedUsers = [charlie]} - do + WS.bracketR2 cannon (tUnqualified alice) (qUnqualified alex) $ \(wsAlice, wsAlex) -> do (resp, rpcCalls) <- withTempMockFederator (const ()) $ do let udcn = FedGalley.UserDeletedConversationsNotification @@ -942,44 +955,37 @@ onUserDeleted = do -- Assert that bob gets removed from the conversation cmOthers (cnvMembers ooConvAfterDel) @?= [] - sort (map omQualifiedId (cmOthers (cnvMembers groupConvAfterDel))) @?= sort [charlie, dee, eve] + sort (map omQualifiedId (cmOthers (cnvMembers groupConvAfterDel))) @?= sort [alex, bart, carl] -- Assert that local user's get notifications only for the conversation -- bob was part of and it wasn't a One2OneConv void . WS.assertMatch (3 # Second) wsAlice $ wsAssertMembersLeave groupConvId (qUntagged bob) [qUntagged bob] - void . WS.assertMatch (3 # Second) wsCharlie $ + void . WS.assertMatch (3 # Second) wsAlex $ wsAssertMembersLeave groupConvId (qUntagged bob) [qUntagged bob] -- Alice shouldn't get any other notifications because we don't notify -- on One2One convs. -- - -- Charlie shouldn't get any other notifications because charlie was + -- Alex shouldn't get any other notifications because alex was -- not part of any other conversations with bob. - WS.assertNoEvent (1 # Second) [wsAlice, wsCharlie] + WS.assertNoEvent (1 # Second) [wsAlice, wsAlex] -- There should be only 2 RPC calls made only for groupConvId: 1 for bob's -- domain and 1 for eve's domain - length rpcCalls @?= 2 + assertEqual ("Expected 2 RPC calls, got: " <> show rpcCalls) 2 (length rpcCalls) - -- Assertions about RPC to Bob's domain - bobDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText bobDomain) rpcCalls + -- Assertions about RPC to bDomain + bobDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText bDomain) rpcCalls bobDomainRPCReq <- assertRight $ parseFedRequest bobDomainRPC FedGalley.cuOrigUserId bobDomainRPCReq @?= qUntagged bob FedGalley.cuConvId bobDomainRPCReq @?= qUnqualified groupConvId - sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified dee] + sort (FedGalley.cuAlreadyPresentUsers bobDomainRPCReq) @?= sort [tUnqualified bob, qUnqualified bart] FedGalley.cuAction bobDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) - -- Assertions about RPC to Eve's domain - eveDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText eveDomain) rpcCalls - eveDomainRPCReq <- assertRight $ parseFedRequest eveDomainRPC - FedGalley.cuOrigUserId eveDomainRPCReq @?= qUntagged bob - FedGalley.cuConvId eveDomainRPCReq @?= qUnqualified groupConvId - FedGalley.cuAlreadyPresentUsers eveDomainRPCReq @?= [qUnqualified eve] - FedGalley.cuAction eveDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) - where - parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a - parseFedRequest fr = - case F.request fr of - Just r -> - (eitherDecode . cs) (F.body r) - Nothing -> Left "No request" + -- Assertions about RPC to 'cDomain' + cDomainRPC <- assertOne $ filter (\c -> F.domain c == domainText cDomain) rpcCalls + cDomainRPCReq <- assertRight $ parseFedRequest cDomainRPC + FedGalley.cuOrigUserId cDomainRPCReq @?= qUntagged bob + FedGalley.cuConvId cDomainRPCReq @?= qUnqualified groupConvId + FedGalley.cuAlreadyPresentUsers cDomainRPCReq @?= [qUnqualified carl] + FedGalley.cuAction cDomainRPCReq @?= ConversationActionRemoveMembers (pure $ qUntagged bob) diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 2c2394f0c80..76c5f7b408d 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -67,7 +67,8 @@ tests s = test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, test s "All features" testAllFeatures, test s "Feature Configs / Team Features Consistency" testFeatureConfigConsistency, - test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled + test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, + test s "SelfDeletingMessages" $ testSelfDeletingMessages ] testSSO :: TestM () @@ -377,6 +378,47 @@ testSimpleFlag defaultValue = do setFlagInternal defaultValue getFlag defaultValue +testSelfDeletingMessages :: TestM () +testSelfDeletingMessages = do + -- personal users + let setting :: TeamFeatureStatusValue -> Int32 -> Public.TeamFeatureStatus 'Public.TeamFeatureSelfDeletingMessages + setting stat tout = + Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig + stat + (Public.TeamFeatureSelfDeletingMessagesConfig tout) + + personalUser <- Util.randomUser + Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages personalUser + !!! responseJsonEither === const (Right $ setting TeamFeatureEnabled 0) + + -- team users + galley <- view tsGalley + (owner, tid, []) <- Util.createBindingTeamWithNMembers 0 + + let checkSet :: TeamFeatureStatusValue -> Int32 -> TestM () + checkSet stat tout = do + Util.putTeamFeatureFlagInternal @'Public.TeamFeatureSelfDeletingMessages + galley + tid + (setting stat tout) + + -- internal, public (/team/:tid/features), and team-agnostic (/feature-configs). + checkGet :: HasCallStack => TeamFeatureStatusValue -> Int32 -> TestM () + checkGet stat tout = do + let expected = setting stat tout + forM_ + [ Util.getTeamFeatureFlagInternal Public.TeamFeatureSelfDeletingMessages tid, + Util.getTeamFeatureFlagWithGalley Public.TeamFeatureSelfDeletingMessages galley owner tid, + Util.getFeatureConfig Public.TeamFeatureSelfDeletingMessages owner + ] + (!!! responseJsonEither === const (Right expected)) + + checkGet TeamFeatureEnabled 0 + checkSet TeamFeatureDisabled 0 + checkGet TeamFeatureDisabled 0 + checkSet TeamFeatureEnabled 30 + checkGet TeamFeatureEnabled 30 + -- | Call 'GET /teams/:tid/features' and 'GET /feature-configs', and check if all -- features are there. testAllFeatures :: TestM () @@ -411,7 +453,12 @@ testAllFeatures = do TeamFeatureEnabled (Public.TeamFeatureClassifiedDomainsConfig [Domain "example.com"]), toS TeamFeatureConferenceCalling - .= Public.TeamFeatureStatusNoConfig confCalling + .= Public.TeamFeatureStatusNoConfig confCalling, + toS TeamFeatureSelfDeletingMessages + .= ( Public.TeamFeatureStatusWithConfig @Public.TeamFeatureSelfDeletingMessagesConfig + TeamFeatureEnabled + (Public.TeamFeatureSelfDeletingMessagesConfig 0) + ) ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 161b1a2636c..b5d4cd24deb 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -65,8 +65,8 @@ import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Data.Time.Clock as Time import qualified Galley.App as Galley -import qualified Galley.Data as Data -import qualified Galley.Data.LegalHold as LegalHoldData +import Galley.Cassandra.Client +import qualified Galley.Cassandra.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients @@ -324,7 +324,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients' [member] + clients' <- Cql.runClient cassState $ lookupClients [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 9d458076467..f7ce8108228 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -59,8 +59,8 @@ import qualified Data.Set as Set import Data.String.Conversions (LBS, cs) import Data.Text.Encoding (encodeUtf8) import qualified Galley.App as Galley -import qualified Galley.Data as Data -import qualified Galley.Data.LegalHold as LegalHoldData +import Galley.Cassandra.Client +import qualified Galley.Cassandra.LegalHold as LegalHoldData import Galley.External.LegalHoldService (validateServiceKey) import Galley.Options (optSettings, setFeatureFlags) import qualified Galley.Types.Clients as Clients @@ -256,7 +256,7 @@ testApproveLegalHoldDevice = do renewToken authToken cassState <- view tsCass liftIO $ do - clients' <- Cql.runClient cassState $ Data.lookupClients' [member] + clients' <- Cql.runClient cassState $ lookupClients [member] assertBool "Expect clientId to be saved on the user" $ Clients.contains member someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a0521b675a8..2f7c43f6814 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -71,7 +71,7 @@ import qualified Galley.Options as Opts import qualified Galley.Run as Run import Galley.Types import qualified Galley.Types as Conv -import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest (..)) +import Galley.Types.Conversations.Intra import Galley.Types.Conversations.One2One (one2OneConvId) import Galley.Types.Conversations.Roles hiding (DeleteConversation) import Galley.Types.Teams hiding (Event, EventType (..), self) @@ -685,8 +685,8 @@ postProteusMessageQualifiedWithMockFederator :: [(Qualified UserId, ClientId, ByteString)] -> ByteString -> ClientMismatchStrategy -> - FederatedBrig.Api (AsServerT Handler) -> - FederatedGalley.Api (AsServerT Handler) -> + (Domain -> FederatedBrig.Api (AsServerT Handler)) -> + (Domain -> FederatedGalley.Api (AsServerT Handler)) -> TestM (ResponseLBS, Mock.ReceivedRequests) postProteusMessageQualifiedWithMockFederator senderUser senderClient convId recipients dat strat brigApi galleyApi = do localDomain <- viewFederationDomain @@ -2209,7 +2209,6 @@ mkProfile quid name = profileDeleted = False, profileService = Nothing, profileHandle = Nothing, - profileLocale = Nothing, profileExpire = Nothing, profileTeam = Nothing, profileEmail = Nothing, @@ -2252,19 +2251,22 @@ withTempMockFederator' resp action = do withTempServantMockFederator :: (MonadMask m, MonadIO m, HasGalley m) => - FederatedBrig.Api (AsServerT Handler) -> - FederatedGalley.Api (AsServerT Handler) -> + (Domain -> FederatedBrig.Api (AsServerT Handler)) -> + (Domain -> FederatedGalley.Api (AsServerT Handler)) -> Domain -> SessionT m b -> m (b, Mock.ReceivedRequests) withTempServantMockFederator brigApi galleyApi originDomain = withTempMockFederator' mock where - server :: ServerT (ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) Handler - server = genericServerT brigApi :<|> genericServerT galleyApi + server :: Domain -> ServerT CombinedBrigAndGalleyAPI Handler + server d = genericServerT (brigApi d) :<|> genericServerT (galleyApi d) mock :: F.FederatedRequest -> IO F.OutwardResponse - mock = makeFedRequestToServant @(ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api) originDomain server + mock req = + makeFedRequestToServant @CombinedBrigAndGalleyAPI originDomain (server (Domain (F.domain req))) req + +type CombinedBrigAndGalleyAPI = ToServantApi FederatedBrig.Api :<|> ToServantApi FederatedGalley.Api makeFedRequestToServant :: forall (api :: *). @@ -2462,20 +2464,56 @@ fedRequestsForDomain domain component = && fmap F.component (F.request req) == Just component ) +parseFedRequest :: FromJSON a => F.FederatedRequest -> Either String a +parseFedRequest fr = + case F.request fr of + Just r -> + (eitherDecode . cs) (F.body r) + Nothing -> Left "No request" + assertOne :: (HasCallStack, MonadIO m, Show a) => [a] -> m a assertOne [a] = pure a assertOne xs = liftIO . assertFailure $ "Expected exactly one element, found " <> show xs +assertJust :: (HasCallStack, MonadIO m) => Maybe a -> m a +assertJust (Just a) = pure a +assertJust Nothing = liftIO $ assertFailure "Expected Just, got Nothing" + iUpsertOne2OneConversation :: UpsertOne2OneConversationRequest -> TestM ResponseLBS iUpsertOne2OneConversation req = do galley <- view tsGalley post (galley . path "/i/conversations/one2one/upsert" . Bilge.json req) +createOne2OneConvWithRemote :: HasCallStack => Local UserId -> Remote UserId -> TestM () +createOne2OneConvWithRemote localUser remoteUser = do + let mkRequest actor mConvId = + UpsertOne2OneConversationRequest + { uooLocalUser = localUser, + uooRemoteUser = remoteUser, + uooActor = actor, + uooActorDesiredMembership = Included, + uooConvId = mConvId + } + ooConvId <- + fmap uuorConvId . responseJsonError + =<< iUpsertOne2OneConversation (mkRequest LocalActor Nothing) + Local UserId -> TestM (Remote UserId, Qualified ConvId) -generateRemoteAndConvId shouldBeLocal lUserId = do - other <- Qualified <$> randomId <*> pure (Domain "far-away.example.com") +generateRemoteAndConvId = generateRemoteAndConvIdWithDomain (Domain "far-away.example.com") + +generateRemoteAndConvIdWithDomain :: Domain -> Bool -> Local UserId -> TestM (Remote UserId, Qualified ConvId) +generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId = do + other <- Qualified <$> randomId <*> pure remoteDomain let convId = one2OneConvId (qUntagged lUserId) other isLocal = tDomain lUserId == qDomain convId if shouldBeLocal == isLocal then pure (qTagUnsafe other, convId) - else generateRemoteAndConvId shouldBeLocal lUserId + else generateRemoteAndConvIdWithDomain remoteDomain shouldBeLocal lUserId + +matchFedRequest :: Domain -> ByteString -> FederatedRequest -> Bool +matchFedRequest domain reqpath req = + F.domain req == domainText domain + && fmap F.path (F.request req) == Just reqpath diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index ffda58da20e..d4d833b1703 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -25,7 +25,7 @@ import Data.Domain import Data.Id import Data.Qualified import Galley.API.Mapping -import qualified Galley.Data as Data +import qualified Galley.Data.Conversation as Data import Galley.Types.Conversations.Members import Imports import Test.Tasty diff --git a/services/gundeck/gundeck.integration.yaml b/services/gundeck/gundeck.integration.yaml index edcd47d014f..e33c0e6cc90 100644 --- a/services/gundeck/gundeck.integration.yaml +++ b/services/gundeck/gundeck.integration.yaml @@ -7,6 +7,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: gundeck_test + # filterNodesByDatacentre: datacenter1 redis: host: 127.0.0.1 diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index a53643289a8..d8448dbd875 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -31,14 +31,14 @@ import Imports unregister :: UserId -> ClientId -> Gundeck () unregister uid cid = do - toks <- filter byClient <$> Push.lookup uid Push.Quorum + toks <- filter byClient <$> Push.lookup uid Push.LocalQuorum deleteTokens toks Nothing where byClient = (cid ==) . view addrClient removeUser :: UserId -> Gundeck () removeUser user = do - toks <- Push.lookup user Push.Quorum + toks <- Push.lookup user Push.LocalQuorum deleteTokens toks Nothing Push.erase user Notifications.deleteAll user diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 3c9888281d4..1a0c7d42985 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -93,6 +93,7 @@ createEnv m o = do . C.setSendTimeout 3 . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 + . C.setPolicy (C.dcFilterPolicyIfConfigured l (o ^. optCassandra . casFilterNodesByDatacentre)) $ C.defSettings a <- Aws.mkEnv l o n io <- diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index 65bd3d6f793..36becc262bf 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -62,7 +62,7 @@ add n tgts (Blob . JSON.encode -> p) (notificationTTLSeconds -> t) = pooledForConcurrentlyN_ 32 tgts $ \tgt -> let u = tgt ^. targetUser cs = C.Set (tgt ^. targetClients) - in write cqlInsert (params Quorum (u, n, p, cs, fromIntegral t)) & retry x5 + in write cqlInsert (params LocalQuorum (u, n, p, cs, fromIntegral t)) & retry x5 where cqlInsert :: PrepQuery W (UserId, NotificationId, Blob, C.Set ClientId, Int32) () cqlInsert = @@ -74,7 +74,7 @@ add n tgts (Blob . JSON.encode -> p) (notificationTTLSeconds -> t) = fetchId :: MonadClient m => UserId -> NotificationId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchId u n c = listToMaybe . foldr' (toNotif c) [] - <$> query cqlById (params Quorum (u, n)) & retry x1 + <$> query cqlById (params LocalQuorum (u, n)) & retry x1 where cqlById :: PrepQuery R (UserId, NotificationId) (TimeUuid, Blob, Maybe (C.Set ClientId)) cqlById = @@ -84,12 +84,12 @@ fetchId u n c = fetchLast :: MonadClient m => UserId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchLast u c = do - ls <- query cqlLast (params Quorum (Identity u)) & retry x1 + ls <- query cqlLast (params LocalQuorum (Identity u)) & retry x1 case ls of [] -> return Nothing ns@(n : _) -> ns `getFirstOrElse` do - p <- paginate cqlSeek (paramsP Quorum (u, n ^. _1) 100) & retry x1 + p <- paginate cqlSeek (paramsP LocalQuorum (u, n ^. _1) 100) & retry x1 seek p where seek p = @@ -120,8 +120,8 @@ fetch u c since (fromRange -> size) = do -- report whether there are more results. let size' = bool (+ 1) (+ 2) (isJust since) size page1 <- case TimeUuid . toUUID <$> since of - Nothing -> paginate cqlStart (paramsP Quorum (Identity u) size') & retry x1 - Just s -> paginate cqlSince (paramsP Quorum (u, s) size') & retry x1 + Nothing -> paginate cqlStart (paramsP LocalQuorum (Identity u) size') & retry x1 + Just s -> paginate cqlSince (paramsP LocalQuorum (u, s) size') & retry x1 -- Collect results, requesting more pages until we run out of data -- or have found size + 1 notifications (not including the 'since'). let isize = fromIntegral size' :: Int @@ -164,7 +164,7 @@ fetch u c since (fromRange -> size) = do \ORDER BY id ASC" deleteAll :: MonadClient m => UserId -> m () -deleteAll u = write cql (params Quorum (Identity u)) & retry x5 +deleteAll u = write cql (params LocalQuorum (Identity u)) & retry x5 where cql :: PrepQuery W (Identity UserId) () cql = "DELETE FROM notifications WHERE user = ?" diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index b611120fcc9..cd205b536f1 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -380,7 +380,7 @@ data AddTokenResponse addToken :: UserId -> ConnId -> PushToken -> Gundeck AddTokenResponse addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do - (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.Quorum + (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.LocalQuorum Log.info $ "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" .= Text.take 16 (tokenText (newtok ^. token)) @@ -512,10 +512,10 @@ updateEndpoint uid t arn e = do deleteToken :: UserId -> Token -> Gundeck () deleteToken uid tok = do - as <- filter (\x -> x ^. addrToken == tok) <$> Data.lookup uid Data.Quorum + as <- filter (\x -> x ^. addrToken == tok) <$> Data.lookup uid Data.LocalQuorum when (null as) $ throwM (mkError status404 "not-found" "Push token not found") Native.deleteTokens as Nothing listTokens :: UserId -> Gundeck PushTokenList -listTokens uid = PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.Quorum +listTokens uid = PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.LocalQuorum diff --git a/services/gundeck/src/Gundeck/Push/Data.hs b/services/gundeck/src/Gundeck/Push/Data.hs index 73fcbb5afcf..ed07d7837b6 100644 --- a/services/gundeck/src/Gundeck/Push/Data.hs +++ b/services/gundeck/src/Gundeck/Push/Data.hs @@ -42,19 +42,19 @@ lookup u c = foldM mk [] =<< retry x1 (query q (params c (Identity u))) mk as r = maybe as (: as) <$> mkAddr r insert :: MonadClient m => UserId -> Transport -> AppName -> Token -> EndpointArn -> ConnId -> ClientId -> m () -insert u t a p e o c = retry x5 $ write q (params Quorum (u, t, a, p, e, o, c)) +insert u t a p e o c = retry x5 $ write q (params LocalQuorum (u, t, a, p, e, o, c)) where q :: PrepQuery W (UserId, Transport, AppName, Token, EndpointArn, ConnId, ClientId) () q = "insert into user_push (usr, transport, app, ptoken, arn, connection, client) values (?, ?, ?, ?, ?, ?, ?)" delete :: MonadClient m => UserId -> Transport -> AppName -> Token -> m () -delete u t a p = retry x5 $ write q (params Quorum (u, t, a, p)) +delete u t a p = retry x5 $ write q (params LocalQuorum (u, t, a, p)) where q :: PrepQuery W (UserId, Transport, AppName, Token) () q = "delete from user_push where usr = ? and transport = ? and app = ? and ptoken = ?" erase :: MonadClient m => UserId -> m () -erase u = retry x5 $ write q (params Quorum (Identity u)) +erase u = retry x5 $ write q (params LocalQuorum (Identity u)) where q :: PrepQuery W (Identity UserId) () q = "delete from user_push where usr = ?" diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index 27d1234297f..3be51cae8d7 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -187,7 +187,7 @@ deleteTokens tokens new = do let oldTok = a ^. addrToken let newArn = a' ^. addrEndpoint let newTok = a' ^. addrToken - xs <- Data.lookup u Data.Quorum + xs <- Data.lookup u Data.LocalQuorum forM_ xs $ \x -> when (x ^. addrEndpoint == oldArn) $ do Data.insert diff --git a/services/gundeck/src/Gundeck/React.hs b/services/gundeck/src/Gundeck/React.hs index 6ffcc8d913f..b5340440c38 100644 --- a/services/gundeck/src/Gundeck/React.hs +++ b/services/gundeck/src/Gundeck/React.hs @@ -129,7 +129,7 @@ withEndpoint ev f = do e <- Aws.execute v (Aws.lookupEndpoint (ev ^. evEndpoint)) for_ e $ \ep -> do let us = Set.toList (ep ^. endpointUsers) - as <- concat <$> mapM (`Push.lookup` Push.Quorum) us + as <- concat <$> mapM (`Push.lookup` Push.LocalQuorum) us case filter ((== (ev ^. evEndpoint)) . view addrEndpoint) as of [] -> do logEvent ev $ diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 2ade72f5c74..0a1b2c55ef0 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -141,7 +141,7 @@ removeUser = do deleteUser g user ntfs <- listNotifications user Nothing liftIO $ do - tokens <- Cql.runClient s (Log.runWithLogger logger $ Push.lookup user Push.Quorum) + tokens <- Cql.runClient s (Log.runWithLogger logger $ Push.lookup user Push.LocalQuorum) null tokens @?= True ntfs @?= [] diff --git a/services/spar/migrate-data/src/Spar/DataMigration/Run.hs b/services/spar/migrate-data/src/Spar/DataMigration/Run.hs index d1b565a28f1..0820d04fbc3 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/Run.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/Run.hs @@ -100,7 +100,7 @@ latestMigrationVersion Env {..} = MigrationVersion . maybe 0 fromIntegral <$> C.runClient sparCassandra - (C.query1 cql (C.params C.Quorum ())) + (C.query1 cql (C.params C.LocalQuorum ())) where cql :: C.QueryString C.R () (Identity Int32) cql = "select version from data_migration where id=1 order by version desc limit 1" @@ -108,7 +108,7 @@ latestMigrationVersion Env {..} = persistVersion :: Env -> MigrationVersion -> Text -> UTCTime -> IO () persistVersion Env {..} (MigrationVersion v) desc time = C.runClient sparCassandra $ - C.write cql (C.params C.Quorum (fromIntegral v, desc, time)) + C.write cql (C.params C.LocalQuorum (fromIntegral v, desc, time)) where cql :: C.QueryString C.W (Int32, Text, UTCTime) () cql = "insert into data_migration (id, version, descr, date) values (1,?,?,?)" diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs b/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs index 70d5898018c..ba6b37cef11 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V1_ExternalIds.hs @@ -142,7 +142,7 @@ readLegacyExternalIds :: (HasSpar env, HasMigEnv env) => ConduitM () [LegacyExte readLegacyExternalIds = do pSize <- lift $ pageSize <$> askMigEnv transPipe runSpar $ - paginateC select (paramsP Quorum () pSize) x5 + paginateC select (paramsP LocalQuorum () pSize) x5 where select :: PrepQuery R () LegacyExternalId select = "SELECT external, user FROM scim_external_ids" @@ -160,7 +160,7 @@ resolveTeam (page, exts) = do readUserTeam :: HasBrig env => [UserId] -> RIO env [UserTeam] readUserTeam uids = runBrig $ do - query select (params Quorum (Identity uids)) + query select (params LocalQuorum (Identity uids)) where select :: PrepQuery R (Identity [UserId]) UserTeam select = "SELECT id, team FROM user where id in ?" @@ -190,7 +190,7 @@ sink = go DryRun -> pure () NoDryRun -> runSpar $ - write insert (params Quorum (tid, extid, uid)) + write insert (params LocalQuorum (tid, extid, uid)) go insert :: PrepQuery W (TeamId, Text, UserId) () insert = "INSERT INTO scim_external (team, external_id, user) VALUES (?, ?, ?)" diff --git a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs index ddc0958026a..083b8ef5f6b 100644 --- a/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs +++ b/services/spar/migrate-data/src/Spar/DataMigration/V2_UserV2.hs @@ -102,7 +102,7 @@ performMigration = do where insertNewRow :: NewRow -> EnvIO () insertNewRow newRow = do - runSpar $ write insert (params Quorum newRow) + runSpar $ write insert (params LocalQuorum newRow) where insert :: PrepQuery W NewRow () insert = "INSERT INTO user_v2 (issuer, normalized_uname_id, sso_id, uid) VALUES (?, ?, ?, ?)" @@ -138,7 +138,7 @@ collectMapping = do readOldRows = do pSize <- lift $ asks pageSize transPipe runSpar $ - paginateC select (paramsP Quorum () pSize) x5 + paginateC select (paramsP LocalQuorum () pSize) x5 where select :: PrepQuery R () OldRow select = "SELECT issuer, sso_id, uid FROM user" @@ -208,7 +208,7 @@ resolveViaActivated _ input@(List2 old1 old2 rest) = do isActivated u = runBrig $ (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params Quorum (Identity u))) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) activatedSelect = "SELECT activated FROM user WHERE id = ?" @@ -226,7 +226,7 @@ resolveViaAccessToken _ input@(List2 old1 old2 rest) = do latestCookieExpiry :: UserId -> EnvIO (Maybe UTCTime) latestCookieExpiry uid = runBrig $ - runIdentity <$$> query1 select (params Quorum (Identity uid)) + runIdentity <$$> query1 select (params LocalQuorum (Identity uid)) where select :: PrepQuery R (Identity UserId) (Identity UTCTime) select = "SELECT expires FROM user_cookies WHERE user = ? ORDER BY expires DESC LIMIT 1" diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 312376a6ae5..fc27e3fb8a1 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -99,6 +99,7 @@ tests: - QuickCheck - spar - uri-bytestring + - polysemy-check executables: spar: diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index e23c70faad2..c4689e5a70a 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e1e1abfd9d2fd00bd96a693a9466a13e0b7aef15677f0506941f662094a340a1 +-- hash: 6007f4f8ec59cf0a438cd7831dc87bda6d60acd7865f6c251bd6f2da5617b381 name: spar version: 0.1 @@ -51,6 +51,9 @@ library Spar.Sem.IdP Spar.Sem.IdP.Cassandra Spar.Sem.IdP.Mem + Spar.Sem.IdPRawMetadataStore + Spar.Sem.IdPRawMetadataStore.Cassandra + Spar.Sem.IdPRawMetadataStore.Mem Spar.Sem.Logger Spar.Sem.Logger.TinyLog Spar.Sem.Now @@ -499,6 +502,8 @@ test-suite spec Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString Test.Spar.ScimSpec + Test.Spar.Sem.IdPRawMetadataStoreSpec + Test.Spar.Sem.IdPSpec Test.Spar.TypesSpec Paths_spar hs-source-dirs: @@ -547,6 +552,7 @@ test-suite spec , network-uri , optparse-applicative , polysemy + , polysemy-check , polysemy-plugin , raw-strings-qq , retry diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 6b40d809505..77792b4ee16 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -27,6 +27,7 @@ cassandra: host: 127.0.0.1 port: 9042 keyspace: spar_test + filterNodesByDatacentre: datacenter1 # Wire/AWS specific, optional # discoUrl: "https://" diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index dddd5b8c653..39316cf97cc 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -78,6 +78,8 @@ import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) +import qualified Spar.Sem.IdPRawMetadataStore as IdPRawMetadataStore import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger import Spar.Sem.Now (Now) @@ -119,6 +121,7 @@ api :: ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, + IdPRawMetadataStore, SAMLUserStore, Random, Error SparError, @@ -181,6 +184,7 @@ apiIDP :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + IdPRawMetadataStore, SAMLUserStore, Error SparError ] @@ -380,14 +384,21 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do pure idp idpGetRaw :: - Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => + Members + '[ GalleyAccess, + BrigAccess, + IdPEffect.IdP, + IdPRawMetadataStore, + Error SparError + ] + r => Maybe UserId -> SAML.IdPId -> Sem r RawIdPMetadata idpGetRaw zusr idpid = do idp <- getIdPConfig idpid _ <- authorizeIdP zusr idp - IdPEffect.getRawMetadata idpid >>= \case + IdPRawMetadataStore.get idpid >>= \case Just txt -> pure $ RawIdPMetadata txt Nothing -> throwSparSem $ SparIdPNotFound (cs $ show idpid) @@ -426,6 +437,7 @@ idpDelete :: ScimTokenStore, SAMLUserStore, IdPEffect.IdP, + IdPRawMetadataStore, Error SparError ] r => @@ -461,8 +473,8 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId -- Delete IdP config do - IdPEffect.deleteConfig idpid issuer team - IdPEffect.deleteRawMetadata idpid + IdPEffect.deleteConfig idp + IdPRawMetadataStore.delete idpid return NoContent where updateOldIssuers :: IdP -> Sem r () @@ -492,6 +504,7 @@ idpCreate :: GalleyAccess, BrigAccess, ScimTokenStore, + IdPRawMetadataStore, IdPEffect.IdP, Error SparError ] @@ -512,6 +525,7 @@ idpCreateXML :: BrigAccess, ScimTokenStore, IdPEffect.IdP, + IdPRawMetadataStore, Error SparError ] r => @@ -526,7 +540,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive GalleyAccess.assertSSOEnabled teamid assertNoScimOrNoIdP teamid idp <- validateNewIdP apiversion idpmeta teamid mReplaces - IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + IdPRawMetadataStore.store (idp ^. SAML.idpId) raw storeIdPConfig idp forM_ mReplaces $ \replaces -> do IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId)) @@ -635,6 +649,7 @@ idpUpdate :: GalleyAccess, BrigAccess, IdPEffect.IdP, + IdPRawMetadataStore, Error SparError ] r => @@ -651,6 +666,7 @@ idpUpdateXML :: GalleyAccess, BrigAccess, IdPEffect.IdP, + IdPRawMetadataStore, Error SparError ] r => @@ -662,7 +678,7 @@ idpUpdateXML :: idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^. SAML.idpId)) $ do (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid GalleyAccess.assertSSOEnabled teamid - IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw + IdPRawMetadataStore.store (idp ^. SAML.idpId) raw -- (if raw metadata is stored and then spar goes out, raw metadata won't match the -- structured idp config. since this will lead to a 5xx response, the client is epected to -- try again, which would clean up cassandra state.) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 87daf33352f..926c466e366 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -763,10 +763,9 @@ deleteTeam team = do -- used by the team, and remove everything related to those IdPs, too. idps <- IdPEffect.getConfigsByTeam team for_ idps $ \idp -> do - let idpid = idp ^. SAML.idpId - issuer = idp ^. SAML.idpMetadata . SAML.edIssuer + let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer SAMLUserStore.deleteByIssuer issuer - IdPEffect.deleteConfig idpid issuer team + IdPEffect.deleteConfig idp sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError sparToServerErrorWithLogging err = do diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 12e96163767..dfc245db572 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -26,6 +26,8 @@ import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.IdP.Cassandra (idPToCassandra) +import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) +import Spar.Sem.IdPRawMetadataStore.Cassandra (idpRawMetadataStoreToCassandra) import Spar.Sem.Logger (Logger) import Spar.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) import Spar.Sem.Now (Now) @@ -60,6 +62,7 @@ type CanonicalEffs = ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, + IdPRawMetadataStore, SAMLUserStore, Embed (Cas.Client), BrigAccess, @@ -95,6 +98,7 @@ runSparToIO ctx action = . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) . samlUserStoreToCassandra + . idpRawMetadataStoreToCassandra . idPToCassandra . defaultSsoCodeToCassandra . scimTokenStoreToCassandra diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index 96c4403ba24..aaf20ae5653 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -179,7 +179,7 @@ storeAReqID :: storeAReqID (SAML.ID rid) (SAML.Time endOfLife) = do env <- ask TTL ttl <- mkTTLAuthnRequests env endOfLife - retry x5 . write ins $ params Quorum (rid, ttl) + retry x5 . write ins $ params LocalQuorum (rid, ttl) where ins :: PrepQuery W (SAML.XmlText, Int32) () ins = "INSERT INTO authreq (req) VALUES (?) USING TTL ?" @@ -188,7 +188,7 @@ unStoreAReqID :: (HasCallStack, MonadClient m) => AReqId -> m () -unStoreAReqID (SAML.ID rid) = retry x5 . write del . params Quorum $ Identity rid +unStoreAReqID (SAML.ID rid) = retry x5 . write del . params LocalQuorum $ Identity rid where del :: PrepQuery W (Identity SAML.XmlText) () del = "DELETE FROM authreq WHERE req = ?" @@ -198,7 +198,7 @@ isAliveAReqID :: AReqId -> m Bool isAliveAReqID (SAML.ID rid) = - (==) (Just 1) <$> (retry x1 . query1 sel . params Quorum $ Identity rid) + (==) (Just 1) <$> (retry x1 . query1 sel . params LocalQuorum $ Identity rid) where sel :: PrepQuery R (Identity SAML.XmlText) (Identity Int64) sel = "SELECT COUNT(*) FROM authreq WHERE req = ?" @@ -211,7 +211,7 @@ storeAssID :: storeAssID (SAML.ID aid) (SAML.Time endOfLife) = do env <- ask TTL ttl <- mkTTLAssertions env endOfLife - retry x5 . write ins $ params Quorum (aid, ttl) + retry x5 . write ins $ params LocalQuorum (aid, ttl) where ins :: PrepQuery W (SAML.XmlText, Int32) () ins = "INSERT INTO authresp (resp) VALUES (?) USING TTL ?" @@ -220,7 +220,7 @@ unStoreAssID :: (HasCallStack, MonadClient m) => AssId -> m () -unStoreAssID (SAML.ID aid) = retry x5 . write del . params Quorum $ Identity aid +unStoreAssID (SAML.ID aid) = retry x5 . write del . params LocalQuorum $ Identity aid where del :: PrepQuery W (Identity SAML.XmlText) () del = "DELETE FROM authresp WHERE resp = ?" @@ -230,7 +230,7 @@ isAliveAssID :: AssId -> m Bool isAliveAssID (SAML.ID aid) = - (==) (Just 1) <$> (retry x1 . query1 sel . params Quorum $ Identity aid) + (==) (Just 1) <$> (retry x1 . query1 sel . params LocalQuorum $ Identity aid) where sel :: PrepQuery R (Identity SAML.XmlText) (Identity Int64) sel = "SELECT COUNT(*) FROM authresp WHERE resp = ?" @@ -249,7 +249,7 @@ storeVerdictFormat :: m () storeVerdictFormat diffTime req (fromVerdictFormat -> (fmtCon, fmtMobSucc, fmtMobErr)) = do let ttl = nominalDiffToSeconds diffTime * 2 - retry x5 . write cql $ params Quorum (req, fmtCon, fmtMobSucc, fmtMobErr, ttl) + retry x5 . write cql $ params LocalQuorum (req, fmtCon, fmtMobSucc, fmtMobErr, ttl) where cql :: PrepQuery W (AReqId, VerdictFormatCon, Maybe URI, Maybe URI, Int32) () cql = "INSERT INTO verdict (req, format_con, format_mobile_success, format_mobile_error) VALUES (?, ?, ?, ?) USING TTL ?" @@ -260,7 +260,7 @@ getVerdictFormat :: m (Maybe VerdictFormat) getVerdictFormat req = (>>= toVerdictFormat) - <$> (retry x1 . query1 cql $ params Quorum (Identity req)) + <$> (retry x1 . query1 cql $ params LocalQuorum (Identity req)) where cql :: PrepQuery R (Identity AReqId) VerdictFormatRow cql = "SELECT format_con, format_mobile_success, format_mobile_error FROM verdict WHERE req = ?" @@ -299,7 +299,7 @@ normalizeQualifiedNameId = normalizeUnqualifiedNameId . view SAML.nameID -- | Add new user. If user with this 'SAML.UserId' exists, overwrite it. insertSAMLUser :: (HasCallStack, MonadClient m) => SAML.UserRef -> UserId -> m () -insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params Quorum (tenant, normalizeQualifiedNameId subject, subject, uid) +insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params LocalQuorum (tenant, normalizeQualifiedNameId subject, subject, uid) where ins :: PrepQuery W (SAML.Issuer, NormalizedUNameID, SAML.NameID, UserId) () ins = "INSERT INTO user_v2 (issuer, normalized_uname_id, sso_id, uid) VALUES (?, ?, ?, ?)" @@ -308,7 +308,7 @@ insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params getSAMLAnyUserByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m (Maybe UserId) getSAMLAnyUserByIssuer issuer = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (Identity issuer)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (Identity issuer)) where sel :: PrepQuery R (Identity SAML.Issuer) (Identity UserId) sel = "SELECT uid FROM user_v2 WHERE issuer = ? LIMIT 1" @@ -318,7 +318,7 @@ getSAMLAnyUserByIssuer issuer = getSAMLSomeUsersByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m [(SAML.UserRef, UserId)] getSAMLSomeUsersByIssuer issuer = (_1 %~ SAML.UserRef issuer) - <$$> (retry x1 . query sel $ params Quorum (Identity issuer)) + <$$> (retry x1 . query sel $ params LocalQuorum (Identity issuer)) where sel :: PrepQuery R (Identity SAML.Issuer) (SAML.NameID, UserId) sel = "SELECT sso_id, uid FROM user_v2 WHERE issuer = ? LIMIT 2000" @@ -338,7 +338,7 @@ getSAMLUser uref = do getSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId) getSAMLUserNew (SAML.UserRef tenant subject) = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (tenant, normalizeQualifiedNameId subject)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, normalizeQualifiedNameId subject)) where sel :: PrepQuery R (SAML.Issuer, NormalizedUNameID) (Identity UserId) sel = "SELECT uid FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?" @@ -353,13 +353,13 @@ getSAMLUser uref = do getSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m (Maybe UserId) getSAMLUserLegacy (SAML.UserRef tenant subject) = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (tenant, subject)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (tenant, subject)) where sel :: PrepQuery R (SAML.Issuer, SAML.NameID) (Identity UserId) sel = "SELECT uid FROM user WHERE issuer = ? AND sso_id = ?" deleteSAMLUsersByIssuer :: (HasCallStack, MonadClient m) => SAML.Issuer -> m () -deleteSAMLUsersByIssuer issuer = retry x5 . write del $ params Quorum (Identity issuer) +deleteSAMLUsersByIssuer issuer = retry x5 . write del $ params LocalQuorum (Identity issuer) where del :: PrepQuery W (Identity SAML.Issuer) () del = "DELETE FROM user_v2 WHERE issuer = ?" @@ -373,12 +373,12 @@ deleteSAMLUser uid uref = do deleteSAMLUserNew uref where deleteSAMLUserNew :: (HasCallStack, MonadClient m) => SAML.UserRef -> m () - deleteSAMLUserNew (SAML.UserRef tenant subject) = retry x5 . write del $ params Quorum (tenant, normalizeQualifiedNameId subject) + deleteSAMLUserNew (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, normalizeQualifiedNameId subject) where del :: PrepQuery W (SAML.Issuer, NormalizedUNameID) () del = "DELETE FROM user_v2 WHERE issuer = ? AND normalized_uname_id = ?" deleteSAMLUserLegacy :: (HasCallStack, MonadClient m) => SAML.UserRef -> m () - deleteSAMLUserLegacy (SAML.UserRef tenant subject) = retry x5 . write del $ params Quorum (tenant, subject) + deleteSAMLUserLegacy (SAML.UserRef tenant subject) = retry x5 . write del $ params LocalQuorum (tenant, subject) where del :: PrepQuery W (SAML.Issuer, SAML.NameID) () del = "DELETE FROM user WHERE issuer = ? AND sso_id = ?" @@ -398,7 +398,7 @@ insertBindCookie cky uid ttlNDT = do env <- ask TTL ttlInt32 <- mkTTLAuthnRequestsNDT env ttlNDT let ckyval = cs . Cky.setCookieValue . SAML.fromSimpleSetCookie . getSimpleSetCookie $ cky - retry x5 . write ins $ params Quorum (ckyval, uid, ttlInt32) + retry x5 . write ins $ params LocalQuorum (ckyval, uid, ttlInt32) where ins :: PrepQuery W (ST, UserId, Int32) () ins = "INSERT INTO bind_cookie (cookie, session_owner) VALUES (?, ?) USING TTL ?" @@ -407,7 +407,7 @@ insertBindCookie cky uid ttlNDT = do lookupBindCookie :: (HasCallStack, MonadClient m) => BindCookie -> m (Maybe UserId) lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = runIdentity <$$> do - (retry x1 . query1 sel $ params Quorum (Identity ckyval)) + (retry x1 . query1 sel $ params LocalQuorum (Identity ckyval)) where sel :: PrepQuery R (Identity ST) (Identity UserId) sel = "SELECT session_owner FROM bind_cookie WHERE cookie = ?" @@ -427,7 +427,7 @@ storeIdPConfig :: m () storeIdPConfig idp = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery ins ( idp ^. SAML.idpId, @@ -470,7 +470,7 @@ setReplacedBy :: Replacing -> m () setReplacedBy (Replaced old) (Replacing new) = do - retry x5 . write ins $ params Quorum (new, old) + retry x5 . write ins $ params LocalQuorum (new, old) where ins :: PrepQuery W (SAML.IdPId, SAML.IdPId) () ins = "UPDATE idp SET replaced_by = ? WHERE idp = ?" @@ -481,7 +481,7 @@ clearReplacedBy :: Replaced -> m () clearReplacedBy (Replaced old) = do - retry x5 . write ins $ params Quorum (Identity old) + retry x5 . write ins $ params LocalQuorum (Identity old) where ins :: PrepQuery W (Identity SAML.IdPId) () ins = "UPDATE idp SET replaced_by = null WHERE idp = ?" @@ -492,7 +492,7 @@ getIdPConfig :: SAML.IdPId -> m (Maybe IdP) getIdPConfig idpid = - traverse toIdp =<< retry x1 (query1 sel $ params Quorum (Identity idpid)) + traverse toIdp =<< retry x1 (query1 sel $ params LocalQuorum (Identity idpid)) where toIdp :: IdPConfigRow -> m IdP toIdp @@ -522,9 +522,9 @@ getIdPIdByIssuerWithoutTeam :: SAML.Issuer -> m (GetIdPResult SAML.IdPId) getIdPIdByIssuerWithoutTeam issuer = do - (runIdentity <$$> retry x1 (query selv2 $ params Quorum (Identity issuer))) >>= \case + (runIdentity <$$> retry x1 (query selv2 $ params LocalQuorum (Identity issuer))) >>= \case [] -> - (runIdentity <$$> retry x1 (query1 sel $ params Quorum (Identity issuer))) >>= \case + (runIdentity <$$> retry x1 (query1 sel $ params LocalQuorum (Identity issuer))) >>= \case Just idpid -> pure $ GetIdPFound idpid Nothing -> pure GetIdPNotFound [idpid] -> @@ -544,7 +544,7 @@ getIdPIdByIssuerWithTeam :: TeamId -> m (Maybe SAML.IdPId) getIdPIdByIssuerWithTeam issuer tid = do - runIdentity <$$> retry x1 (query1 sel $ params Quorum (issuer, tid)) + runIdentity <$$> retry x1 (query1 sel $ params LocalQuorum (issuer, tid)) where sel :: PrepQuery R (SAML.Issuer, TeamId) (Identity SAML.IdPId) sel = "SELECT idp FROM issuer_idp_v2 WHERE issuer = ? and team = ?" @@ -554,7 +554,7 @@ getIdPConfigsByTeam :: TeamId -> m [IdP] getIdPConfigsByTeam team = do - idpids <- runIdentity <$$> retry x1 (query sel $ params Quorum (Identity team)) + idpids <- runIdentity <$$> retry x1 (query sel $ params LocalQuorum (Identity team)) catMaybes <$> mapM getIdPConfig idpids where sel :: PrepQuery R (Identity TeamId) (Identity SAML.IdPId) @@ -568,7 +568,7 @@ deleteIdPConfig :: m () deleteIdPConfig idp issuer team = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delDefaultIdp (Identity idp) addPrepQuery delIdp (Identity idp) addPrepQuery delIssuerIdp (Identity issuer) @@ -595,7 +595,7 @@ storeIdPRawMetadata :: SAML.IdPId -> ST -> m () -storeIdPRawMetadata idp raw = retry x5 . write ins $ params Quorum (idp, raw) +storeIdPRawMetadata idp raw = retry x5 . write ins $ params LocalQuorum (idp, raw) where ins :: PrepQuery W (SAML.IdPId, ST) () ins = "INSERT INTO idp_raw_metadata (id, metadata) VALUES (?, ?)" @@ -606,7 +606,7 @@ getIdPRawMetadata :: m (Maybe ST) getIdPRawMetadata idp = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum (Identity idp)) + <$$> (retry x1 . query1 sel $ params LocalQuorum (Identity idp)) where sel :: PrepQuery R (Identity SAML.IdPId) (Identity ST) sel = "SELECT metadata FROM idp_raw_metadata WHERE id = ?" @@ -615,7 +615,7 @@ deleteIdPRawMetadata :: (HasCallStack, MonadClient m) => SAML.IdPId -> m () -deleteIdPRawMetadata idp = retry x5 . write del $ params Quorum (Identity idp) +deleteIdPRawMetadata idp = retry x5 . write del $ params LocalQuorum (Identity idp) where del :: PrepQuery W (Identity SAML.IdPId) () del = "DELETE FROM idp_raw_metadata WHERE id = ?" @@ -632,7 +632,7 @@ getDefaultSsoCode :: m (Maybe SAML.IdPId) getDefaultSsoCode = runIdentity - <$$> (retry x1 . query1 sel $ params Quorum ()) + <$$> (retry x1 . query1 sel $ params LocalQuorum ()) where sel :: PrepQuery R () (Identity SAML.IdPId) sel = "SELECT idp FROM default_idp WHERE partition_key_always_default = 'default' ORDER BY idp LIMIT 1" @@ -648,7 +648,7 @@ storeDefaultSsoCode idpId = do -- `ORDER BY` clause. The others will get removed by `deleteDefaultSsoCode` -- the next time this function is called (as it removes all entries). deleteDefaultSsoCode - retry x5 . write ins $ params Quorum (Identity idpId) + retry x5 . write ins $ params LocalQuorum (Identity idpId) where ins :: PrepQuery W (Identity SAML.IdPId) () ins = "INSERT INTO default_idp (partition_key_always_default, idp) VALUES ('default', ?)" @@ -656,7 +656,7 @@ storeDefaultSsoCode idpId = do deleteDefaultSsoCode :: (HasCallStack, MonadClient m) => m () -deleteDefaultSsoCode = retry x5 . write del $ params Quorum () +deleteDefaultSsoCode = retry x5 . write del $ params LocalQuorum () where del :: PrepQuery W () () del = "DELETE FROM default_idp WHERE partition_key_always_default = 'default'" @@ -684,7 +684,7 @@ insertScimToken :: m () insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let tokenHash = hashScimToken token addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) addPrepQuery insByTeam (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) @@ -711,7 +711,7 @@ lookupScimToken :: m (Maybe ScimTokenInfo) lookupScimToken token = do let tokenHash = hashScimToken token - rows <- retry x1 . query sel $ params Quorum (tokenHash, token) + rows <- retry x1 . query sel $ params LocalQuorum (tokenHash, token) case fmap (scimTokenLookupKey &&& Prelude.id) rows of [(ScimTokenLookupKeyHashed _, row)] -> pure (Just (fromScimTokenRow row)) @@ -743,7 +743,7 @@ connvertPlaintextToken :: m () connvertPlaintextToken token ScimTokenInfo {..} = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum let tokenHash = hashScimToken token -- enter by new lookup key addPrepQuery insByToken (ScimTokenLookupKeyHashed tokenHash, stiTeam, stiId, stiCreatedAt, stiIdP, stiDescr) @@ -760,7 +760,7 @@ getScimTokens :: getScimTokens team = do -- We don't need pagination here because the limit should be pretty low -- (e.g. 16). If the limit grows, we might have to introduce pagination. - rows <- retry x1 . query sel $ params Quorum (Identity team) + rows <- retry x1 . query sel $ params LocalQuorum (Identity team) pure $ sortOn stiCreatedAt $ map fromScimTokenRow rows where sel :: PrepQuery R (Identity TeamId) ScimTokenRow @@ -777,10 +777,10 @@ deleteScimToken :: ScimTokenId -> m () deleteScimToken team tokenid = do - mbToken <- retry x1 . query1 selById $ params Quorum (team, tokenid) + mbToken <- retry x1 . query1 selById $ params LocalQuorum (team, tokenid) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delById (team, tokenid) for_ mbToken $ \(Identity key) -> addPrepQuery delByTokenLookup (Identity key) @@ -812,10 +812,10 @@ deleteTeamScimTokens :: TeamId -> m () deleteTeamScimTokens team = do - tokens <- retry x5 $ query sel $ params Quorum (Identity team) + tokens <- retry x5 $ query sel $ params LocalQuorum (Identity team) retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery delByTeam (Identity team) mapM_ (addPrepQuery delByTokenLookup) tokens where @@ -834,7 +834,7 @@ writeScimUserTimes :: (HasCallStack, MonadClient m) => WithMeta (WithId UserId a writeScimUserTimes (WithMeta meta (WithId uid _)) = retry x5 . write ins $ params - Quorum + LocalQuorum ( uid, toUTCTimeMillis $ created meta, toUTCTimeMillis $ lastModified meta @@ -846,7 +846,7 @@ writeScimUserTimes (WithMeta meta (WithId uid _)) = -- | Read creation and last-update time from database for a given user id. readScimUserTimes :: (HasCallStack, MonadClient m) => UserId -> m (Maybe (UTCTimeMillis, UTCTimeMillis)) readScimUserTimes uid = do - retry x1 . query1 sel $ params Quorum (Identity uid) + retry x1 . query1 sel $ params LocalQuorum (Identity uid) where sel :: PrepQuery R (Identity UserId) (UTCTimeMillis, UTCTimeMillis) sel = "SELECT created_at, last_updated_at FROM scim_user_times WHERE uid = ?" @@ -857,7 +857,7 @@ deleteScimUserTimes :: (HasCallStack, MonadClient m) => UserId -> m () -deleteScimUserTimes uid = retry x5 . write del $ params Quorum (Identity uid) +deleteScimUserTimes uid = retry x5 . write del $ params LocalQuorum (Identity uid) where del :: PrepQuery W (Identity UserId) () del = "DELETE FROM scim_user_times WHERE uid = ?" @@ -869,14 +869,14 @@ deleteScimUserTimes uid = retry x5 . write del $ params Quorum (Identity uid) -- as a 'Text'.) insertScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> UserId -> m () insertScimExternalId tid (fromEmail -> email) uid = - retry x5 . write insert $ params Quorum (tid, email, uid) + retry x5 . write insert $ params LocalQuorum (tid, email, uid) where insert :: PrepQuery W (TeamId, Text, UserId) () insert = "INSERT INTO scim_external (team, external_id, user) VALUES (?, ?, ?)" -- | The inverse of 'insertScimExternalId'. lookupScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m (Maybe UserId) -lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . query1 sel $ params Quorum (tid, email)) +lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . query1 sel $ params LocalQuorum (tid, email)) where sel :: PrepQuery R (TeamId, Text) (Identity UserId) sel = "SELECT user FROM scim_external WHERE team = ? and external_id = ?" @@ -884,7 +884,7 @@ lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . que -- | The other inverse of 'insertScimExternalId' :). deleteScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m () deleteScimExternalId tid (fromEmail -> email) = - retry x5 . write delete $ params Quorum (tid, email) + retry x5 . write delete $ params LocalQuorum (tid, email) where delete :: PrepQuery W (TeamId, Text) () delete = "DELETE FROM scim_external WHERE team = ? and external_id = ?" diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 8dd7bd7439b..325d96665e6 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -54,7 +54,7 @@ import Spar.Orphans () import Spar.Sem.Logger.TinyLog (toLevel) import System.Logger.Class (Logger) import qualified System.Logger.Extended as Log -import Util.Options (casEndpoint, casKeyspace, epHost, epPort) +import Util.Options (casEndpoint, casFilterNodesByDatacentre, casKeyspace, epHost, epPort) import Wire.API.User.Saml as Types ---------------------------------------------------------------------- @@ -62,9 +62,10 @@ import Wire.API.User.Saml as Types initCassandra :: Opts -> Logger -> IO ClientState initCassandra opts lgr = do + let cassOpts = Types.cassandra opts connectString <- maybe - (Cas.initialContactsPlain (Types.cassandra opts ^. casEndpoint . epHost)) + (Cas.initialContactsPlain (cassOpts ^. casEndpoint . epHost)) (Cas.initialContactsDisco "cassandra_spar") (cs <$> Types.discoUrl opts) cas <- @@ -72,14 +73,15 @@ initCassandra opts lgr = do Cas.defSettings & Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.spar") lgr)) & Cas.setContacts (NE.head connectString) (NE.tail connectString) - & Cas.setPortNumber (fromIntegral $ Types.cassandra opts ^. casEndpoint . epPort) - & Cas.setKeyspace (Keyspace $ Types.cassandra opts ^. casKeyspace) + & Cas.setPortNumber (fromIntegral $ cassOpts ^. casEndpoint . epPort) + & Cas.setKeyspace (Keyspace $ cassOpts ^. casKeyspace) & Cas.setMaxConnections 4 & Cas.setMaxStreams 128 & Cas.setPoolStripes 4 & Cas.setSendTimeout 3 & Cas.setResponseTimeout 10 & Cas.setProtocolVersion V4 + & Cas.setPolicy (Cas.dcFilterPolicyIfConfigured lgr (cassOpts ^. casFilterNodesByDatacentre)) runClient cas $ Cas.versionCheck Data.schemaVersion pure cas diff --git a/services/spar/src/Spar/Sem/IdP.hs b/services/spar/src/Spar/Sem/IdP.hs index 946561fe7a3..53e94faed03 100644 --- a/services/spar/src/Spar/Sem/IdP.hs +++ b/services/spar/src/Spar/Sem/IdP.hs @@ -18,11 +18,13 @@ data GetIdPResult a | -- | An IdP was found, but it lives in another team than the one you were looking for. -- This should be handled similarly to NotFound in most cases. GetIdPWrongTeam SAML.IdPId - deriving (Eq, Show) + deriving (Eq, Show, Generic) newtype Replaced = Replaced SAML.IdPId + deriving (Eq, Ord, Show) newtype Replacing = Replacing SAML.IdPId + deriving (Eq, Ord, Show) data IdP m a where StoreConfig :: IP.IdP -> IdP m () @@ -30,14 +32,12 @@ data IdP m a where GetIdByIssuerWithoutTeam :: SAML.Issuer -> IdP m (GetIdPResult SAML.IdPId) GetIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> IdP m (Maybe SAML.IdPId) GetConfigsByTeam :: TeamId -> IdP m [IP.IdP] - DeleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> IdP m () + DeleteConfig :: IP.IdP -> IdP m () + -- affects _wiReplacedBy in GetConfig SetReplacedBy :: Replaced -> Replacing -> IdP m () ClearReplacedBy :: Replaced -> IdP m () - -- TODO(sandy): maybe this wants to be a separate effect - -- data Metadata m a wher e - StoreRawMetadata :: SAML.IdPId -> Text -> IdP m () - GetRawMetadata :: SAML.IdPId -> IdP m (Maybe Text) - DeleteRawMetadata :: SAML.IdPId -> IdP m () + +deriving stock instance Show (IdP m a) -- TODO(sandy): Inline this definition --- no TH makeSem ''IdP diff --git a/services/spar/src/Spar/Sem/IdP/Cassandra.hs b/services/spar/src/Spar/Sem/IdP/Cassandra.hs index 286eb2301ee..63a3e88bfb4 100644 --- a/services/spar/src/Spar/Sem/IdP/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdP/Cassandra.hs @@ -1,10 +1,13 @@ module Spar.Sem.IdP.Cassandra where import Cassandra +import Control.Lens ((^.)) import Imports import Polysemy +import qualified SAML2.WebSSO.Types as SAML import qualified Spar.Data as Data import Spar.Sem.IdP +import Wire.API.User.IdentityProvider (wiTeam) idPToCassandra :: forall m r a. @@ -19,9 +22,10 @@ idPToCassandra = GetIdByIssuerWithoutTeam i -> Data.getIdPIdByIssuerWithoutTeam i GetIdByIssuerWithTeam i t -> Data.getIdPIdByIssuerWithTeam i t GetConfigsByTeam itlt -> Data.getIdPConfigsByTeam itlt - DeleteConfig i i11 itlt -> Data.deleteIdPConfig i i11 itlt + DeleteConfig idp -> + let idpid = idp ^. SAML.idpId + issuer = idp ^. SAML.idpMetadata . SAML.edIssuer + team = idp ^. SAML.idpExtraInfo . wiTeam + in Data.deleteIdPConfig idpid issuer team SetReplacedBy r r11 -> Data.setReplacedBy r r11 ClearReplacedBy r -> Data.clearReplacedBy r - StoreRawMetadata i t -> Data.storeIdPRawMetadata i t - GetRawMetadata i -> Data.getIdPRawMetadata i - DeleteRawMetadata i -> Data.deleteIdPRawMetadata i diff --git a/services/spar/src/Spar/Sem/IdP/Mem.hs b/services/spar/src/Spar/Sem/IdP/Mem.hs index 154bdda142d..0eb1603fa25 100644 --- a/services/spar/src/Spar/Sem/IdP/Mem.hs +++ b/services/spar/src/Spar/Sem/IdP/Mem.hs @@ -1,9 +1,8 @@ {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -module Spar.Sem.IdP.Mem (idPToMem) where +module Spar.Sem.IdP.Mem (idPToMem, TypedState) where -import Control.Exception (assert) -import Control.Lens ((%~), (.~), (^.), _1, _2) +import Control.Lens ((.~), (^.)) import Data.Id (TeamId) import qualified Data.Map as M import Imports @@ -13,56 +12,46 @@ import qualified SAML2.WebSSO.Types as SAML import qualified Spar.Sem.IdP as Eff import qualified Wire.API.User.IdentityProvider as IP -type IS = (TypedState, RawState) - type TypedState = Map SAML.IdPId IP.IdP -type RawState = Map SAML.IdPId Text - idPToMem :: forall r a. Sem (Eff.IdP ': r) a -> - Sem r a + Sem r (TypedState, a) idPToMem = evState . evEff where - evState :: Sem (State IS : r) a -> Sem r a - evState = evalState mempty + evState :: Sem (State TypedState : r) a -> Sem r (TypedState, a) + evState = runState mempty - evEff :: Sem (Eff.IdP ': r) a -> Sem (State IS ': r) a - evEff = reinterpret @_ @(State IS) $ \case + evEff :: Sem (Eff.IdP ': r) a -> Sem (State TypedState ': r) a + evEff = reinterpret @_ @(State TypedState) $ \case Eff.StoreConfig iw -> - modify' (_1 %~ storeConfig iw) + modify' (storeConfig iw) Eff.GetConfig i -> - gets (getConfig i . (^. _1)) + gets (getConfig i) Eff.GetIdByIssuerWithoutTeam iss -> - gets (getIdByIssuerWithoutTeam iss . (^. _1)) + gets (getIdByIssuerWithoutTeam iss) Eff.GetIdByIssuerWithTeam iss team -> - gets (getIdByIssuerWithTeam iss team . (^. _1)) + gets (getIdByIssuerWithTeam iss team) Eff.GetConfigsByTeam team -> - gets (getConfigsByTeam team . (^. _1)) - Eff.DeleteConfig i iss team -> - modify' (_1 %~ deleteConfig i iss team) + gets (getConfigsByTeam team) + Eff.DeleteConfig idp -> + modify' (deleteConfig idp) Eff.SetReplacedBy (Eff.Replaced replaced) (Eff.Replacing replacing) -> - modify' (_1 %~ ((updateReplacedBy (Just replacing) replaced) <$>)) + modify' (updateReplacedBy (Just replacing) replaced <$>) Eff.ClearReplacedBy (Eff.Replaced replaced) -> - modify' (_1 %~ ((updateReplacedBy Nothing replaced) <$>)) - Eff.StoreRawMetadata i txt -> - modify (_2 %~ storeRawMetadata i txt) - Eff.GetRawMetadata i -> - gets (getRawMetadata i . (^. _2)) - Eff.DeleteRawMetadata i -> - modify (_2 %~ deleteRawMetadata i) + modify' (updateReplacedBy Nothing replaced <$>) storeConfig :: IP.IdP -> TypedState -> TypedState storeConfig iw = - M.filter - ( \iw' -> - or - [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, - iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam - ] - ) - . M.insert (iw ^. SAML.idpId) iw + M.insert (iw ^. SAML.idpId) iw + . M.filter + ( \iw' -> + or + [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, + iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam + ] + ) getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP getConfig = M.lookup @@ -95,17 +84,12 @@ getConfigsByTeam team = fl :: IP.IdP -> Bool fl idp = idp ^. SAML.idpExtraInfo . IP.wiTeam == team -deleteConfig :: SAML.IdPId -> SAML.Issuer -> TeamId -> TypedState -> TypedState -deleteConfig i iss team = +deleteConfig :: IP.IdP -> TypedState -> TypedState +deleteConfig idp = M.filter fl where fl :: IP.IdP -> Bool - fl idp = - assert -- calling this function with inconsistent values will crash hard. - ( idp ^. SAML.idpMetadata . SAML.edIssuer == iss - && idp ^. SAML.idpExtraInfo . IP.wiTeam == team - ) - (idp ^. SAML.idpId /= i) + fl idp' = idp' ^. SAML.idpId /= idp ^. SAML.idpId updateReplacedBy :: Maybe SAML.IdPId -> SAML.IdPId -> IP.IdP -> IP.IdP updateReplacedBy mbReplacing replaced idp = @@ -113,12 +97,3 @@ updateReplacedBy mbReplacing replaced idp = & if idp ^. SAML.idpId == replaced then SAML.idpExtraInfo . IP.wiReplacedBy .~ mbReplacing else id - -storeRawMetadata :: SAML.IdPId -> Text -> RawState -> RawState -storeRawMetadata = M.insert - -getRawMetadata :: SAML.IdPId -> RawState -> Maybe Text -getRawMetadata = M.lookup - -deleteRawMetadata :: SAML.IdPId -> RawState -> RawState -deleteRawMetadata idpid = M.filterWithKey (\idpid' _ -> idpid' /= idpid) diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs new file mode 100644 index 00000000000..4cee44c4c80 --- /dev/null +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs @@ -0,0 +1,15 @@ +module Spar.Sem.IdPRawMetadataStore where + +import Imports +import Polysemy +import qualified SAML2.WebSSO as SAML + +data IdPRawMetadataStore m a where + Store :: SAML.IdPId -> Text -> IdPRawMetadataStore m () + Get :: SAML.IdPId -> IdPRawMetadataStore m (Maybe Text) + Delete :: SAML.IdPId -> IdPRawMetadataStore m () + +deriving stock instance Show (IdPRawMetadataStore m a) + +-- TODO(sandy): Inline this definition --- no TH +makeSem ''IdPRawMetadataStore diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs new file mode 100644 index 00000000000..08ea88fdda9 --- /dev/null +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs @@ -0,0 +1,19 @@ +module Spar.Sem.IdPRawMetadataStore.Cassandra where + +import Cassandra +import Imports +import Polysemy +import qualified Spar.Data as Data +import Spar.Sem.IdPRawMetadataStore + +idpRawMetadataStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (IdPRawMetadataStore ': r) a -> + Sem r a +idpRawMetadataStoreToCassandra = + interpret $ + embed @m . \case + Store i t -> Data.storeIdPRawMetadata i t + Get i -> Data.getIdPRawMetadata i + Delete i -> Data.deleteIdPRawMetadata i diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Mem.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Mem.hs new file mode 100644 index 00000000000..5956019273a --- /dev/null +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Mem.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Spar.Sem.IdPRawMetadataStore.Mem (idpRawMetadataStoreToMem, RawState) where + +import qualified Data.Map as M +import Imports +import Polysemy +import Polysemy.State (State, gets, modify, runState) +import qualified SAML2.WebSSO.Types as SAML +import Spar.Sem.IdPRawMetadataStore + +type RawState = Map SAML.IdPId Text + +idpRawMetadataStoreToMem :: + forall r a. + Sem (IdPRawMetadataStore ': r) a -> + Sem r (RawState, a) +idpRawMetadataStoreToMem = runState mempty . evEff + where + evEff :: Sem (IdPRawMetadataStore ': r) a -> Sem (State RawState ': r) a + evEff = reinterpret @_ @(State RawState) $ \case + Store i txt -> + modify $ M.insert i txt + Get i -> + gets $ M.lookup i + Delete idpid -> + modify $ M.filterWithKey (\idpid' _ -> idpid' /= idpid) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 7685df85177..980a761aa04 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1515,7 +1515,7 @@ specSparUserMigration = do let insert :: PrepQuery W (SAML.Issuer, SAML.NameID, UserId) () insert = "INSERT INTO user (issuer, sso_id, uid) VALUES (?, ?, ?)" runClient client $ - retry x5 $ write insert (params Quorum (issuer, subject, memberUid)) + retry x5 $ write insert (params LocalQuorum (issuer, subject, memberUid)) mbUserId <- do authnreq <- negotiateAuthnRequest idp diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 2c66752773d..4bd1547b385 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -200,7 +200,7 @@ spec = do do midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Just idp - () <- runSpar $ IdPEffect.deleteConfig (idp ^. idpId) (idp ^. idpMetadata . edIssuer) teamid + () <- runSpar $ IdPEffect.deleteConfig idp do midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId) liftIO $ midp `shouldBe` Nothing diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 5be4bc24a2c..20c3bdc071c 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -277,7 +277,7 @@ testPlaintextTokensAreConverted = do wrapMonadClient $ do retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum addPrepQuery insByToken (ScimTokenLookupKeyPlaintext token, teamId, tokenId, now, Nothing, descr) addPrepQuery insByTeam (ScimTokenLookupKeyPlaintext token, teamId, tokenId, now, Nothing, descr) pure token @@ -299,7 +299,7 @@ testPlaintextTokensAreConverted = do countTokensInDB :: ScimTokenLookupKey -> TestSpar Int64 countTokensInDB key = wrapMonadClient $ do - count <- runIdentity <$$> (retry x1 . query1 selByKey $ params Quorum (Identity key)) + count <- runIdentity <$$> (retry x1 . query1 selByKey $ params LocalQuorum (Identity key)) pure $ fromMaybe 0 count selByKey :: PrepQuery R (Identity ScimTokenLookupKey) (Identity Int64) diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index f48e5722fc5..bc7ca9fae4e 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -23,15 +23,18 @@ module Arbitrary where import Data.Aeson -import Data.Id () +import Data.Id (TeamId) import Data.Proxy import Data.String.Conversions (cs) import Data.Swagger hiding (Header (..)) import Imports import SAML2.WebSSO.Test.Arbitrary () +import SAML2.WebSSO.Types import Servant.API.ContentTypes import Spar.Scim +import qualified Spar.Sem.IdP as E import Test.QuickCheck +import URI.ByteString import Wire.API.User.IdentityProvider import Wire.API.User.Saml @@ -85,3 +88,30 @@ instance ToJSON NoContent where instance ToSchema NoContent where declareNamedSchema _ = declareNamedSchema (Proxy @String) + +instance Arbitrary E.Replacing where + arbitrary = E.Replacing <$> arbitrary + +instance Arbitrary E.Replaced where + arbitrary = E.Replaced <$> arbitrary + +instance CoArbitrary a => CoArbitrary (E.GetIdPResult a) + +instance CoArbitrary IdPId + +instance CoArbitrary WireIdP + +instance CoArbitrary WireIdPAPIVersion + +instance CoArbitrary TeamId + +instance CoArbitrary Issuer where + coarbitrary (Issuer ur) = coarbitrary $ show ur + +instance CoArbitrary a => CoArbitrary (URIRef a) where + coarbitrary = coarbitrary . show + +instance CoArbitrary (IdPConfig WireIdP) + +instance CoArbitrary IdPMetadata where + coarbitrary = coarbitrary . show diff --git a/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs b/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs new file mode 100644 index 00000000000..c1d5f6b9b81 --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/IdPRawMetadataStoreSpec.hs @@ -0,0 +1,111 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.IdPRawMetadataStoreSpec where + +import Arbitrary () +import Imports +import Polysemy +import Polysemy.Check +import qualified Spar.Sem.IdPRawMetadataStore as E +import Spar.Sem.IdPRawMetadataStore.Mem +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +deriveGenericK ''E.IdPRawMetadataStore + +prop_storeGetRaw :: + Member E.IdPRawMetadataStore r => + (forall a. Sem r a -> IO (RawState, a)) -> + Property +prop_storeGetRaw x = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t <- arbitrary + pure + ( do + E.store idpid t + E.get idpid, + do + E.store idpid t + pure (Just t) + ) + ) + x + +prop_storeStoreRaw :: + Member E.IdPRawMetadataStore r => + (forall a. Sem r a -> IO (RawState, a)) -> + Property +prop_storeStoreRaw x = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t1 <- arbitrary + t2 <- arbitrary + pure + ( do + E.store idpid t1 + E.store idpid t2, + do + E.store idpid t2 + ) + ) + x + +prop_storeDeleteRaw :: + Member E.IdPRawMetadataStore r => + (forall a. Sem r a -> IO (RawState, a)) -> + Property +prop_storeDeleteRaw x = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + t <- arbitrary + pure + ( do + E.store idpid t + E.delete idpid, + do + E.delete idpid + ) + ) + x + +prop_deleteGetRaw :: + Member E.IdPRawMetadataStore r => + (forall a. Sem r a -> IO (RawState, a)) -> + Property +prop_deleteGetRaw x = + prepropLaw @'[E.IdPRawMetadataStore] + ( do + idpid <- arbitrary + pure + ( do + E.delete idpid + E.get idpid, + do + E.delete idpid + pure Nothing + ) + ) + x + +testInterpreter :: Sem '[E.IdPRawMetadataStore] a -> IO (RawState, a) +testInterpreter = pure . run . idpRawMetadataStoreToMem + +propsForInterpreter :: + Member E.IdPRawMetadataStore r => + (forall a. Sem r a -> IO (RawState, a)) -> + Spec +propsForInterpreter lower = do + prop "store/store" $ prop_storeStoreRaw lower + prop "store/get" $ prop_storeGetRaw lower + prop "store/deleteRawMetadata" $ prop_storeDeleteRaw lower + prop "deleteRawMetadata/get" $ prop_deleteGetRaw lower + +spec :: Spec +spec = modifyMaxSuccess (const 1000) $ do + propsForInterpreter testInterpreter diff --git a/services/spar/test/Test/Spar/Sem/IdPSpec.hs b/services/spar/test/Test/Spar/Sem/IdPSpec.hs new file mode 100644 index 00000000000..162f5b1625f --- /dev/null +++ b/services/spar/test/Test/Spar/Sem/IdPSpec.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +module Test.Spar.Sem.IdPSpec where + +import Arbitrary () +import Control.Lens +import Imports +import Polysemy +import Polysemy.Check +import SAML2.WebSSO.Types +import qualified Spar.Sem.IdP as E +import Spar.Sem.IdP.Mem +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +deriveGenericK ''E.IdP + +prop_storeGet :: + Member E.IdP r => + (forall a. Sem r a -> IO (TypedState, a)) -> + Property +prop_storeGet x = + prepropLaw @'[E.IdP] + ( do + s <- arbitrary + pure + ( do + E.storeConfig s + E.getConfig $ s ^. idpId, + do + E.storeConfig s + pure (Just s) + ) + ) + x + +prop_storeGetByIssuer :: + Member E.IdP r => + (forall a. Sem r a -> IO (TypedState, a)) -> + Property +prop_storeGetByIssuer x = + prepropLaw @'[E.IdP] + ( do + s <- arbitrary + pure + ( do + E.storeConfig s + E.getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer, + do + E.storeConfig s + pure $ E.GetIdPFound $ s ^. idpId + ) + ) + x + +testInterpreter :: Sem '[E.IdP] a -> IO (TypedState, a) +testInterpreter = pure . run . idPToMem + +propsForInterpreter :: + Member E.IdP r => + (forall a. Sem r a -> IO (TypedState, a)) -> + Spec +propsForInterpreter lower = do + describe "Config Actions" $ do + prop "storeConfig/getConfig" $ prop_storeGet lower + prop "storeConfig/getIdByIssuerWithoutTeam" $ prop_storeGetByIssuer lower + +spec :: Spec +spec = modifyMaxSuccess (const 1000) $ do + propsForInterpreter testInterpreter diff --git a/stack.yaml b/stack.yaml index b816f92c3c4..28cd4ee7aa4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -104,9 +104,8 @@ extra-deps: # Therefore we pin an unreleased commit directly. # # Once the fix has been merged (and released on hackage), we can pin that instead. -- archive: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 - size: 11158334 +- git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb subdirs: - amazonka - amazonka-cloudfront @@ -255,6 +254,9 @@ extra-deps: subdirs: - x509-store +# Not on stackage yet +- polysemy-check-0.8.1.0 + ############################################################ # Development tools ############################################################ diff --git a/stack.yaml.lock b/stack.yaml.lock index a8910cfe1db..9c6dd2b653f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -109,125 +109,109 @@ packages: original: hackage: aeson-1.4.7.1@sha256:6d8d2fd959b7122a1df9389cf4eca30420a053d67289f92cdc0dbc0dab3530ba,7098 - completed: - size: 11158334 subdir: amazonka - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 1038 sha256: 59c7840fe6c9609d1d5022149010e72db5778e4978b9384b6dee8a4a207c96b3 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-cloudfront - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-cloudfront version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 12839 sha256: f0f27588c628d9996c298ab035b19999572ad8432ea05526497b608b009b1258 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-cloudfront - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-dynamodb - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-dynamodb version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 8379 sha256: d513775676879e3b2ff8393528882df1670a79110120b65ce6c68765581a2473 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-dynamodb - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-s3 - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-s3 version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 18431 sha256: a19d02da301bbcad502e6092d7418a59543747c8bb6f12932bcbc4606f7814ab + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-s3 - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-ses - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-ses version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 18197 sha256: cd9b02c30d7571dc87868b054ed3826d5b8d26b717f3158da6443377e8dfd563 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-ses - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-sns - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-sns version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 7905 sha256: e5a6d407b92e423ccf58d784fe42d4a0598204f65c0e7753569c130428bfb5eb + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-sns - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: amazonka-sqs - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-sqs version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 5351 sha256: 990b7e4467d557e43959483063f7229f5039857a8cd67decb53f9a5c513db7f8 + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: amazonka-sqs - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: - size: 11158334 subdir: core - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz name: amazonka-core version: 1.6.1 - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka pantry-tree: size: 3484 sha256: d4e427a362d66c9ee0dc0de810015633e43e3953944a84b24cfa2e71bcf0ed4d + commit: 412172d8c28906591f01576a78792de7c34cc3eb original: - size: 11158334 subdir: core - url: https://github.com/wireapp/amazonka/archive/412172d8c28906591f01576a78792de7c34cc3eb.tar.gz - sha256: c5eb2007e0eef0daaa70f5c622ec0cc75227be1bc8d32bc9446754f01595ad21 + git: https://github.com/wireapp/amazonka + commit: 412172d8c28906591f01576a78792de7c34cc3eb - completed: name: cryptobox-haskell version: 0.1.1 @@ -820,6 +804,13 @@ packages: subdir: x509-store git: https://github.com/vincenthz/hs-certificate commit: a899bda3d7666d25143be7be8f3105fc076703d9 +- completed: + hackage: polysemy-check-0.8.1.0@sha256:5cce3ae162d2f8d8f629397daa28ec5e425f72d357afeb4fe994e102425f2383,2648 + pantry-tree: + size: 1027 + sha256: bc880fb3405307ed251c02358d604979d8014040b78c2ffe6319076431f93509 + original: + hackage: polysemy-check-0.8.1.0 - completed: hackage: ormolu-0.1.4.1@sha256:ed404eac6e4eb64da1ca5fb749e0f99907431a9633e6ba34e44d260e7d7728ba,6499 pantry-tree: diff --git a/tools/convert-to-cabal/README.md b/tools/convert-to-cabal/README.md new file mode 100644 index 00000000000..c3f4e780814 --- /dev/null +++ b/tools/convert-to-cabal/README.md @@ -0,0 +1,85 @@ +# How to convert the project to cabal + +1. Run + + ```bash + ./tools/convert-to-cabal/generate.sh + ``` + + This will generate these files + - `cabal.project.freeze` + - `cabal.project` + +2. Create a `cabal.project.local` file with + + ``` + optimization: False + ``` + + This configures that local builds fast without optimization. + + To make sure Haskell Language Server also builds all projects without optimization run this: + + ```bash + ./hack/bin/cabal-project-local-template.sh "ghc-options: -O0" >> ./cabal.project.local + ``` + + Note: cabal v2-repl (which is run by hie-bios (HLS)) seem to be ignoring "optimization" flag for local dependencies, this is why we need to specify `ghc-options` explicitely. + + +# How to use the project with cabal + +1. Update your environment. + ```bash + cabal update + ``` + + Add this to your .envrc.local + ```bash + export WIRE_BUILD_WITH_CABAL=1 + ``` + + You should be able to build wire-server with cabal now: + + ```bash + make install # using cabal + make c package=brig # to build and install all of brig's executables + make c package=brig test=1 # also run unit tests + make ci package=brig pattern="delete" # build and run brig's integration tests + ``` + +2. For Haskell Language Server change `hie.yaml` to use cabal + ```bash + WIRE_BUILD_WITH_CABAL=1 make hie.yaml + ``` + + + +## Notes + +- `cabal v2-repl` (used by hie-bios) seem to be ignoring "optimization" flag for local dependencies. However it respects ghc-options + +``` +package foo + ghc-options: -O0 +``` + +- With new cabal build there doesn't seem to be any way of running tests as part of a build. You have to run the tests manually. + https://github.com/haskell/cabal/issues/7267 + +- Nix integration (`nix: True` in `~/.cabal/config`) is not supported in new-build. + https://github.com/haskell/cabal/issues/4646 + That's why you have to enter the environment defined by `direnv.nix` manually (or via direnv) to use cabal. + +- cabal oddity? Specifying `--ghc-options` twice yields different result + + if run + ``` + cabal build --ghc-options "-O0" exe:brig + ``` + + and then + ``` + cabal build --ghc-options "-O0" --ghc-options "-O0" exe:brig + ``` + Cabal will retry to build brig and _all_ of its dependencies diff --git a/tools/convert-to-cabal/generate.sh b/tools/convert-to-cabal/generate.sh new file mode 100755 index 00000000000..3a0e8c5f421 --- /dev/null +++ b/tools/convert-to-cabal/generate.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash +set -euo pipefail + +TOP_LEVEL="$( cd "$( dirname "${BASH_SOURCE[0]}" )/../.." && pwd )" + +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"; + ./hack/bin/cabal-project-local-template.sh "ghc-options: -Werror" +} >> ./cabal.project diff --git a/tools/convert-to-cabal/shell.nix b/tools/convert-to-cabal/shell.nix new file mode 100644 index 00000000000..87266663a03 --- /dev/null +++ b/tools/convert-to-cabal/shell.nix @@ -0,0 +1,28 @@ +{ pkgs ? import ../../nix }: +let + pinned = { + stack2cabal = + let source = pkgs.fetchFromGitHub { + owner = "hasufell"; + repo = "stack2cabal"; + rev = "afa113beb77569ff21f03fade6ce39edc109598d"; + sha256 = "1zwg1xkqxn5b9mmqafg87rmgln47zsmpgdkly165xdzg38smhmng"; + }; + + overlay = self: super: { + "stack2cabal" = super.callCabal2nix "stack2cabal" source { }; + }; + + haskellPackages = pkgs.haskell.packages.ghc884.override { + overrides = overlay; + }; + + in pkgs.haskell.lib.doJailbreak haskellPackages.stack2cabal; + + }; +in pkgs.mkShell { + name = "shell"; + buildInputs = [ + pinned.stack2cabal + ]; +} diff --git a/tools/db/auto-whitelist/src/Work.hs b/tools/db/auto-whitelist/src/Work.hs index b8ff4c84c50..d79832dfc6e 100644 --- a/tools/db/auto-whitelist/src/Work.hs +++ b/tools/db/auto-whitelist/src/Work.hs @@ -49,7 +49,7 @@ runCommand l brig = runClient brig $ do -- | Get all services in team conversations getServices :: Client [(ProviderId, ServiceId, TeamId)] -getServices = retry x5 $ query cql (params Quorum ()) +getServices = retry x5 $ query cql (params LocalQuorum ()) where cql :: PrepQuery R () (ProviderId, ServiceId, TeamId) cql = "SELECT provider, service, team FROM service_team" @@ -57,7 +57,7 @@ getServices = retry x5 $ query cql (params Quorum ()) -- | Check if a service exists doesServiceExist :: (ProviderId, ServiceId, a) -> Client Bool doesServiceExist (pid, sid, _) = - retry x5 $ fmap isJust $ query1 cql (params Quorum (pid, sid)) + retry x5 $ fmap isJust $ query1 cql (params LocalQuorum (pid, sid)) where cql :: PrepQuery R (ProviderId, ServiceId) (Identity ServiceId) cql = @@ -73,7 +73,7 @@ whitelistService l (pid, sid, tid) = do . Log.field "service" (show sid) . Log.field "team" (show tid) retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged addPrepQuery insert1 (tid, pid, sid) addPrepQuery insert1Rev (tid, pid, sid) diff --git a/tools/db/billing-team-member-backfill/src/Work.hs b/tools/db/billing-team-member-backfill/src/Work.hs index 318610f8bef..4d45abcc3b3 100644 --- a/tools/db/billing-team-member-backfill/src/Work.hs +++ b/tools/db/billing-team-member-backfill/src/Work.hs @@ -61,7 +61,7 @@ pageSize = 1000 -- | Get team members from Galley getTeamMembers :: ConduitM () [(TeamId, UserId, Maybe Permissions)] Client () -getTeamMembers = paginateC cql (paramsP Quorum () pageSize) x5 +getTeamMembers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (TeamId, UserId, Maybe Permissions) cql = "SELECT team, user, perms FROM team_member" @@ -70,7 +70,7 @@ createBillingTeamMembers :: [(TeamId, UserId)] -> Client () createBillingTeamMembers pairs = retry x5 . batch $ do setType BatchLogged - setConsistency Quorum + setConsistency LocalQuorum mapM_ (addPrepQuery cql) pairs where cql :: PrepQuery W (TeamId, UserId) () diff --git a/tools/db/find-undead/src/Work.hs b/tools/db/find-undead/src/Work.hs index 8a08096c335..7661bbd8fb3 100644 --- a/tools/db/find-undead/src/Work.hs +++ b/tools/db/find-undead/src/Work.hs @@ -105,7 +105,7 @@ extractScrollId :: MonadThrow m => ES.SearchResult a -> m ES.ScrollId extractScrollId res = maybe (throwM NoScrollId) pure (ES.scrollId res) usersInCassandra :: [UUID] -> Client [(UUID, Maybe AccountStatus, Maybe (Writetime ()))] -usersInCassandra users = retry x1 $ query cql (params Quorum (Identity users)) +usersInCassandra users = retry x1 $ query cql (params LocalQuorum (Identity users)) where cql :: PrepQuery R (Identity [UUID]) (UUID, Maybe AccountStatus, Maybe (Writetime ())) cql = "SELECT id, status, writetime(status) from user where id in ?" diff --git a/tools/db/migrate-sso-feature-flag/src/Work.hs b/tools/db/migrate-sso-feature-flag/src/Work.hs index a194b5c8e60..582f2fdf3bd 100644 --- a/tools/db/migrate-sso-feature-flag/src/Work.hs +++ b/tools/db/migrate-sso-feature-flag/src/Work.hs @@ -31,7 +31,7 @@ import Data.Conduit.Internal (zipSources) import qualified Data.Conduit.List as C import Data.Id import Data.Misc -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.Logger (Logger) import qualified System.Logger as Log @@ -57,7 +57,7 @@ pageSize :: Int32 pageSize = 1000 getSsoTeams :: ConduitM () [Identity TeamId] Client () -getSsoTeams = paginateC cql (paramsP Quorum () pageSize) x5 +getSsoTeams = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (Identity TeamId) cql = "select team from idp" @@ -67,6 +67,6 @@ writeSsoFlags = mapM_ (`setSSOTeamConfig` TeamFeatureEnabled) where setSSOTeamConfig :: MonadClient m => TeamId -> TeamFeatureStatusValue -> m () setSSOTeamConfig tid ssoTeamConfigStatus = do - retry x5 $ write updateSSOTeamConfig (params Quorum (ssoTeamConfigStatus, tid)) + retry x5 $ write updateSSOTeamConfig (params LocalQuorum (ssoTeamConfigStatus, tid)) updateSSOTeamConfig :: PrepQuery W (TeamFeatureStatusValue, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" diff --git a/tools/db/move-team/move-team.cabal b/tools/db/move-team/move-team.cabal index 55543fbe2be..8b3fb1e66c5 100644 --- a/tools/db/move-team/move-team.cabal +++ b/tools/db/move-team/move-team.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 6c50a8e33625c79cb1b04adac7f5a9b9c337181da35f450c10ea970548a9acd4 +-- hash: 6f97fa57af68acb9606816e6048ebe009ec9c0f01a971d39ae9dbc5e2061346d name: move-team version: 1.0.0 @@ -38,7 +38,6 @@ library , cassandra-util , conduit , containers - , cql , filepath , galley , imports @@ -74,7 +73,6 @@ executable move-team , cassandra-util , conduit , containers - , cql , filepath , galley , imports @@ -111,7 +109,6 @@ executable move-team-generate , cassandra-util , conduit , containers - , cql , filepath , galley , imports diff --git a/tools/db/move-team/package.yaml b/tools/db/move-team/package.yaml index 4d01f5f4ad9..108af8a6d9c 100644 --- a/tools/db/move-team/package.yaml +++ b/tools/db/move-team/package.yaml @@ -24,7 +24,7 @@ dependencies: - cassandra-util - conduit - containers -- cql +- cassandra-util - filepath - galley - imports diff --git a/tools/db/move-team/src/Common.hs b/tools/db/move-team/src/Common.hs index 64041a43899..2d79a203fb9 100644 --- a/tools/db/move-team/src/Common.hs +++ b/tools/db/move-team/src/Common.hs @@ -22,7 +22,6 @@ import Conduit import Data.Aeson import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.Combinators as C -import Database.CQL.Protocol (Tuple) import Imports import System.IO @@ -44,5 +43,5 @@ sinkTableRows insertQuery = go case mbTuple of Nothing -> pure () Just tuple -> do - lift $ write insertQuery (params Quorum tuple) + lift $ write insertQuery (params LocalQuorum tuple) go diff --git a/tools/db/move-team/src/ParseSchema.hs b/tools/db/move-team/src/ParseSchema.hs index f98909218d8..7d4299a8b2f 100644 --- a/tools/db/move-team/src/ParseSchema.hs +++ b/tools/db/move-team/src/ParseSchema.hs @@ -205,7 +205,7 @@ import Data.Conduit import Data.Id import Data.Time import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import Types import Wire.API.Team.Permission @@ -229,7 +229,7 @@ select{{keySpaceCaml}}{{tableNameCaml}} = "SELECT {{columns}} FROM {{tableName}} read{{keySpaceCaml}}{{tableNameCaml}}:: Env -> {{lookupKeyType}} -> ConduitM () [Row{{keySpaceCaml}}{{tableNameCaml}}] IO () read{{keySpaceCaml}}{{tableNameCaml}} Env {..} {{lookupKeyVar}} = transPipe (runClient env{{keySpaceCaml}}) $ - paginateC select{{keySpaceCaml}}{{tableNameCaml}} (paramsP Quorum (pure {{lookupKeyVar}}) envPageSize) x5 + paginateC select{{keySpaceCaml}}{{tableNameCaml}} (paramsP LocalQuorum (pure {{lookupKeyVar}}) envPageSize) x5 select{{keySpaceCaml}}{{tableNameCaml}}All :: PrepQuery R () Row{{keySpaceCaml}}{{tableNameCaml}} select{{keySpaceCaml}}{{tableNameCaml}}All = "SELECT {{columns}} FROM {{tableName}}" @@ -237,7 +237,7 @@ select{{keySpaceCaml}}{{tableNameCaml}}All = "SELECT {{columns}} FROM {{tableNam read{{keySpaceCaml}}{{tableNameCaml}}All :: Env -> ConduitM () [Row{{keySpaceCaml}}{{tableNameCaml}}] IO () read{{keySpaceCaml}}{{tableNameCaml}}All Env {..} = transPipe (runClient env{{keySpaceCaml}}) $ - paginateC select{{keySpaceCaml}}{{tableNameCaml}}All (paramsP Quorum () envPageSize) x5 + paginateC select{{keySpaceCaml}}{{tableNameCaml}}All (paramsP LocalQuorum () envPageSize) x5 export{{keySpaceCaml}}{{tableNameCaml}}Full :: Env -> FilePath -> IO () export{{keySpaceCaml}}{{tableNameCaml}}Full env@Env {..} path = do diff --git a/tools/db/move-team/src/Schema.hs b/tools/db/move-team/src/Schema.hs index 81d99692dec..1958fb705b1 100644 --- a/tools/db/move-team/src/Schema.hs +++ b/tools/db/move-team/src/Schema.hs @@ -27,7 +27,7 @@ import Data.IP (IP) import Data.Id import Data.Time import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.FilePath.Posix (()) import Types @@ -46,7 +46,7 @@ selectBrigClients = "SELECT user, client, class, cookie, ip, label, lat, lon, mo readBrigClients :: Env -> [UserId] -> ConduitM () [RowBrigClients] IO () readBrigClients Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigClients (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigClients (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigClientsAll :: PrepQuery R () RowBrigClients selectBrigClientsAll = "SELECT user, client, class, cookie, ip, label, lat, lon, model, tstamp, type FROM clients" @@ -54,7 +54,7 @@ selectBrigClientsAll = "SELECT user, client, class, cookie, ip, label, lat, lon, readBrigClientsAll :: Env -> ConduitM () [RowBrigClients] IO () readBrigClientsAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigClientsAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigClientsAll (paramsP LocalQuorum () envPageSize) x5 exportBrigClientsFull :: Env -> FilePath -> IO () exportBrigClientsFull env@Env {..} path = do @@ -92,7 +92,7 @@ selectBrigConnection = "SELECT left, right, conv, last_update, message, status F readBrigConnection :: Env -> [UserId] -> ConduitM () [RowBrigConnection] IO () readBrigConnection Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigConnection (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigConnection (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigConnectionAll :: PrepQuery R () RowBrigConnection selectBrigConnectionAll = "SELECT left, right, conv, last_update, message, status FROM connection" @@ -100,7 +100,7 @@ selectBrigConnectionAll = "SELECT left, right, conv, last_update, message, statu readBrigConnectionAll :: Env -> ConduitM () [RowBrigConnection] IO () readBrigConnectionAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigConnectionAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigConnectionAll (paramsP LocalQuorum () envPageSize) x5 exportBrigConnectionFull :: Env -> FilePath -> IO () exportBrigConnectionFull env@Env {..} path = do @@ -138,7 +138,7 @@ selectBrigLoginCodes = "SELECT user, code, retries, timeout FROM login_codes WHE readBrigLoginCodes :: Env -> [UserId] -> ConduitM () [RowBrigLoginCodes] IO () readBrigLoginCodes Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigLoginCodes (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigLoginCodes (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigLoginCodesAll :: PrepQuery R () RowBrigLoginCodes selectBrigLoginCodesAll = "SELECT user, code, retries, timeout FROM login_codes" @@ -146,7 +146,7 @@ selectBrigLoginCodesAll = "SELECT user, code, retries, timeout FROM login_codes" readBrigLoginCodesAll :: Env -> ConduitM () [RowBrigLoginCodes] IO () readBrigLoginCodesAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigLoginCodesAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigLoginCodesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigLoginCodesFull :: Env -> FilePath -> IO () exportBrigLoginCodesFull env@Env {..} path = do @@ -184,7 +184,7 @@ selectBrigPasswordReset = "SELECT key, code, retries, timeout, user FROM passwor readBrigPasswordReset :: Env -> [PasswordResetKey] -> ConduitM () [RowBrigPasswordReset] IO () readBrigPasswordReset Env {..} reset_keys = transPipe (runClient envBrig) $ - paginateC selectBrigPasswordReset (paramsP Quorum (pure reset_keys) envPageSize) x5 + paginateC selectBrigPasswordReset (paramsP LocalQuorum (pure reset_keys) envPageSize) x5 selectBrigPasswordResetAll :: PrepQuery R () RowBrigPasswordReset selectBrigPasswordResetAll = "SELECT key, code, retries, timeout, user FROM password_reset" @@ -192,7 +192,7 @@ selectBrigPasswordResetAll = "SELECT key, code, retries, timeout, user FROM pass readBrigPasswordResetAll :: Env -> ConduitM () [RowBrigPasswordReset] IO () readBrigPasswordResetAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPasswordResetAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPasswordResetAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPasswordResetFull :: Env -> FilePath -> IO () exportBrigPasswordResetFull env@Env {..} path = do @@ -230,7 +230,7 @@ selectBrigPrekeys = "SELECT user, client, key, data FROM prekeys WHERE user in ? readBrigPrekeys :: Env -> [UserId] -> ConduitM () [RowBrigPrekeys] IO () readBrigPrekeys Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigPrekeys (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigPrekeys (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigPrekeysAll :: PrepQuery R () RowBrigPrekeys selectBrigPrekeysAll = "SELECT user, client, key, data FROM prekeys" @@ -238,7 +238,7 @@ selectBrigPrekeysAll = "SELECT user, client, key, data FROM prekeys" readBrigPrekeysAll :: Env -> ConduitM () [RowBrigPrekeys] IO () readBrigPrekeysAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPrekeysAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPrekeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPrekeysFull :: Env -> FilePath -> IO () exportBrigPrekeysFull env@Env {..} path = do @@ -276,7 +276,7 @@ selectBrigProperties = "SELECT user, key, value FROM properties WHERE user in ?" readBrigProperties :: Env -> [UserId] -> ConduitM () [RowBrigProperties] IO () readBrigProperties Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigProperties (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigProperties (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigPropertiesAll :: PrepQuery R () RowBrigProperties selectBrigPropertiesAll = "SELECT user, key, value FROM properties" @@ -284,7 +284,7 @@ selectBrigPropertiesAll = "SELECT user, key, value FROM properties" readBrigPropertiesAll :: Env -> ConduitM () [RowBrigProperties] IO () readBrigPropertiesAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigPropertiesAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigPropertiesAll (paramsP LocalQuorum () envPageSize) x5 exportBrigPropertiesFull :: Env -> FilePath -> IO () exportBrigPropertiesFull env@Env {..} path = do @@ -322,7 +322,7 @@ selectBrigRichInfo = "SELECT user, json FROM rich_info WHERE user in ?" readBrigRichInfo :: Env -> [UserId] -> ConduitM () [RowBrigRichInfo] IO () readBrigRichInfo Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigRichInfo (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigRichInfo (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigRichInfoAll :: PrepQuery R () RowBrigRichInfo selectBrigRichInfoAll = "SELECT user, json FROM rich_info" @@ -330,7 +330,7 @@ selectBrigRichInfoAll = "SELECT user, json FROM rich_info" readBrigRichInfoAll :: Env -> ConduitM () [RowBrigRichInfo] IO () readBrigRichInfoAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigRichInfoAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigRichInfoAll (paramsP LocalQuorum () envPageSize) x5 exportBrigRichInfoFull :: Env -> FilePath -> IO () exportBrigRichInfoFull env@Env {..} path = do @@ -368,7 +368,7 @@ selectBrigUser = "SELECT id, accent, accent_id, activated, assets, country, emai readBrigUser :: Env -> [UserId] -> ConduitM () [RowBrigUser] IO () readBrigUser Env {..} uids = transPipe (runClient envBrig) $ - paginateC selectBrigUser (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectBrigUser (paramsP LocalQuorum (pure uids) envPageSize) x5 selectBrigUserAll :: PrepQuery R () RowBrigUser selectBrigUserAll = "SELECT id, accent, accent_id, activated, assets, country, email, expires, handle, language, managed_by, name, password, phone, picture, provider, searchable, service, sso_id, status, team FROM user" @@ -376,7 +376,7 @@ selectBrigUserAll = "SELECT id, accent, accent_id, activated, assets, country, e readBrigUserAll :: Env -> ConduitM () [RowBrigUser] IO () readBrigUserAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserFull :: Env -> FilePath -> IO () exportBrigUserFull env@Env {..} path = do @@ -414,7 +414,7 @@ selectBrigUserHandle = "SELECT handle, user FROM user_handle WHERE handle in ?" readBrigUserHandle :: Env -> [Handle] -> ConduitM () [RowBrigUserHandle] IO () readBrigUserHandle Env {..} handles = transPipe (runClient envBrig) $ - paginateC selectBrigUserHandle (paramsP Quorum (pure handles) envPageSize) x5 + paginateC selectBrigUserHandle (paramsP LocalQuorum (pure handles) envPageSize) x5 selectBrigUserHandleAll :: PrepQuery R () RowBrigUserHandle selectBrigUserHandleAll = "SELECT handle, user FROM user_handle" @@ -422,7 +422,7 @@ selectBrigUserHandleAll = "SELECT handle, user FROM user_handle" readBrigUserHandleAll :: Env -> ConduitM () [RowBrigUserHandle] IO () readBrigUserHandleAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserHandleAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserHandleAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserHandleFull :: Env -> FilePath -> IO () exportBrigUserHandleFull env@Env {..} path = do @@ -460,7 +460,7 @@ selectBrigUserKeys = "SELECT key, user FROM user_keys WHERE key in ?" readBrigUserKeys :: Env -> [Int32] -> ConduitM () [RowBrigUserKeys] IO () readBrigUserKeys Env {..} keys = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeys (paramsP Quorum (pure keys) envPageSize) x5 + paginateC selectBrigUserKeys (paramsP LocalQuorum (pure keys) envPageSize) x5 selectBrigUserKeysAll :: PrepQuery R () RowBrigUserKeys selectBrigUserKeysAll = "SELECT key, user FROM user_keys" @@ -468,7 +468,7 @@ selectBrigUserKeysAll = "SELECT key, user FROM user_keys" readBrigUserKeysAll :: Env -> ConduitM () [RowBrigUserKeys] IO () readBrigUserKeysAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserKeysAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysFull :: Env -> FilePath -> IO () exportBrigUserKeysFull env@Env {..} path = do @@ -506,7 +506,7 @@ selectBrigUserKeysHash = "SELECT key, key_type, user FROM user_keys_hash WHERE k readBrigUserKeysHash :: Env -> [Int32] -> ConduitM () [RowBrigUserKeysHash] IO () readBrigUserKeysHash Env {..} keys = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysHash (paramsP Quorum (pure keys) envPageSize) x5 + paginateC selectBrigUserKeysHash (paramsP LocalQuorum (pure keys) envPageSize) x5 selectBrigUserKeysHashAll :: PrepQuery R () RowBrigUserKeysHash selectBrigUserKeysHashAll = "SELECT key, key_type, user FROM user_keys_hash" @@ -514,7 +514,7 @@ selectBrigUserKeysHashAll = "SELECT key, key_type, user FROM user_keys_hash" readBrigUserKeysHashAll :: Env -> ConduitM () [RowBrigUserKeysHash] IO () readBrigUserKeysHashAll Env {..} = transPipe (runClient envBrig) $ - paginateC selectBrigUserKeysHashAll (paramsP Quorum () envPageSize) x5 + paginateC selectBrigUserKeysHashAll (paramsP LocalQuorum () envPageSize) x5 exportBrigUserKeysHashFull :: Env -> FilePath -> IO () exportBrigUserKeysHashFull env@Env {..} path = do @@ -552,7 +552,7 @@ selectGalleyBillingTeamMember = "SELECT team, user FROM billing_team_member WHER readGalleyBillingTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyBillingTeamMember] IO () readGalleyBillingTeamMember Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyBillingTeamMember (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyBillingTeamMember (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyBillingTeamMemberAll :: PrepQuery R () RowGalleyBillingTeamMember selectGalleyBillingTeamMemberAll = "SELECT team, user FROM billing_team_member" @@ -560,7 +560,7 @@ selectGalleyBillingTeamMemberAll = "SELECT team, user FROM billing_team_member" readGalleyBillingTeamMemberAll :: Env -> ConduitM () [RowGalleyBillingTeamMember] IO () readGalleyBillingTeamMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyBillingTeamMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyBillingTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyBillingTeamMemberFull :: Env -> FilePath -> IO () exportGalleyBillingTeamMemberFull env@Env {..} path = do @@ -598,7 +598,7 @@ selectGalleyClients = "SELECT user, clients FROM clients WHERE user in ?" readGalleyClients :: Env -> [UserId] -> ConduitM () [RowGalleyClients] IO () readGalleyClients Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyClients (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyClients (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyClientsAll :: PrepQuery R () RowGalleyClients selectGalleyClientsAll = "SELECT user, clients FROM clients" @@ -606,7 +606,7 @@ selectGalleyClientsAll = "SELECT user, clients FROM clients" readGalleyClientsAll :: Env -> ConduitM () [RowGalleyClients] IO () readGalleyClientsAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyClientsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyClientsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyClientsFull :: Env -> FilePath -> IO () exportGalleyClientsFull env@Env {..} path = do @@ -644,7 +644,7 @@ selectGalleyConversation = "SELECT conv, access, access_role, creator, deleted, readGalleyConversation :: Env -> [ConvId] -> ConduitM () [RowGalleyConversation] IO () readGalleyConversation Env {..} cids = transPipe (runClient envGalley) $ - paginateC selectGalleyConversation (paramsP Quorum (pure cids) envPageSize) x5 + paginateC selectGalleyConversation (paramsP LocalQuorum (pure cids) envPageSize) x5 selectGalleyConversationAll :: PrepQuery R () RowGalleyConversation selectGalleyConversationAll = "SELECT conv, access, access_role, creator, deleted, message_timer, name, receipt_mode, team, type FROM conversation" @@ -652,7 +652,7 @@ selectGalleyConversationAll = "SELECT conv, access, access_role, creator, delete readGalleyConversationAll :: Env -> ConduitM () [RowGalleyConversation] IO () readGalleyConversationAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyConversationAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyConversationAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyConversationFull :: Env -> FilePath -> IO () exportGalleyConversationFull env@Env {..} path = do @@ -690,7 +690,7 @@ selectGalleyMember = "SELECT conv, user, conversation_role, hidden, hidden_ref, readGalleyMember :: Env -> [ConvId] -> ConduitM () [RowGalleyMember] IO () readGalleyMember Env {..} cids = transPipe (runClient envGalley) $ - paginateC selectGalleyMember (paramsP Quorum (pure cids) envPageSize) x5 + paginateC selectGalleyMember (paramsP LocalQuorum (pure cids) envPageSize) x5 selectGalleyMemberAll :: PrepQuery R () RowGalleyMember selectGalleyMemberAll = "SELECT conv, user, conversation_role, hidden, hidden_ref, otr_archived, otr_archived_ref, otr_muted, otr_muted_ref, otr_muted_status, provider, service, status, user_remote_domain, user_remote_id FROM member" @@ -698,7 +698,7 @@ selectGalleyMemberAll = "SELECT conv, user, conversation_role, hidden, hidden_re readGalleyMemberAll :: Env -> ConduitM () [RowGalleyMember] IO () readGalleyMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyMemberFull :: Env -> FilePath -> IO () exportGalleyMemberFull env@Env {..} path = do @@ -736,7 +736,7 @@ selectGalleyTeam = "SELECT team, binding, creator, deleted, icon, icon_key, name readGalleyTeam :: Env -> TeamId -> ConduitM () [RowGalleyTeam] IO () readGalleyTeam Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeam (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeam (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamAll :: PrepQuery R () RowGalleyTeam selectGalleyTeamAll = "SELECT team, binding, creator, deleted, icon, icon_key, name, search_visibility, status FROM team" @@ -744,7 +744,7 @@ selectGalleyTeamAll = "SELECT team, binding, creator, deleted, icon, icon_key, n readGalleyTeamAll :: Env -> ConduitM () [RowGalleyTeam] IO () readGalleyTeamAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFull :: Env -> FilePath -> IO () exportGalleyTeamFull env@Env {..} path = do @@ -782,7 +782,7 @@ selectGalleyTeamConv = "SELECT team, conv, managed FROM team_conv WHERE team = ? readGalleyTeamConv :: Env -> TeamId -> ConduitM () [RowGalleyTeamConv] IO () readGalleyTeamConv Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamConv (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamConv (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamConvAll :: PrepQuery R () RowGalleyTeamConv selectGalleyTeamConvAll = "SELECT team, conv, managed FROM team_conv" @@ -790,7 +790,7 @@ selectGalleyTeamConvAll = "SELECT team, conv, managed FROM team_conv" readGalleyTeamConvAll :: Env -> ConduitM () [RowGalleyTeamConv] IO () readGalleyTeamConvAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamConvAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamConvAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamConvFull :: Env -> FilePath -> IO () exportGalleyTeamConvFull env@Env {..} path = do @@ -828,7 +828,7 @@ selectGalleyTeamFeatures = "SELECT team_id, app_lock_enforce, app_lock_inactivit readGalleyTeamFeatures :: Env -> TeamId -> ConduitM () [RowGalleyTeamFeatures] IO () readGalleyTeamFeatures Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamFeatures (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamFeatures (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamFeaturesAll :: PrepQuery R () RowGalleyTeamFeatures selectGalleyTeamFeaturesAll = "SELECT team_id, app_lock_enforce, app_lock_inactivity_timeout_secs, app_lock_status, digital_signatures, legalhold_status, search_visibility_status, sso_status, validate_saml_emails FROM team_features" @@ -836,7 +836,7 @@ selectGalleyTeamFeaturesAll = "SELECT team_id, app_lock_enforce, app_lock_inacti readGalleyTeamFeaturesAll :: Env -> ConduitM () [RowGalleyTeamFeatures] IO () readGalleyTeamFeaturesAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamFeaturesAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamFeaturesAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamFeaturesFull :: Env -> FilePath -> IO () exportGalleyTeamFeaturesFull env@Env {..} path = do @@ -874,7 +874,7 @@ selectGalleyTeamMember = "SELECT team, user, invited_at, invited_by, legalhold_s readGalleyTeamMember :: Env -> TeamId -> ConduitM () [RowGalleyTeamMember] IO () readGalleyTeamMember Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamMember (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamMember (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamMemberAll :: PrepQuery R () RowGalleyTeamMember selectGalleyTeamMemberAll = "SELECT team, user, invited_at, invited_by, legalhold_status, perms FROM team_member" @@ -882,7 +882,7 @@ selectGalleyTeamMemberAll = "SELECT team, user, invited_at, invited_by, legalhol readGalleyTeamMemberAll :: Env -> ConduitM () [RowGalleyTeamMember] IO () readGalleyTeamMemberAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamMemberAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamMemberAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamMemberFull :: Env -> FilePath -> IO () exportGalleyTeamMemberFull env@Env {..} path = do @@ -920,7 +920,7 @@ selectGalleyTeamNotifications = "SELECT team, id, payload FROM team_notification readGalleyTeamNotifications :: Env -> TeamId -> ConduitM () [RowGalleyTeamNotifications] IO () readGalleyTeamNotifications Env {..} tid = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamNotifications (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectGalleyTeamNotifications (paramsP LocalQuorum (pure tid) envPageSize) x5 selectGalleyTeamNotificationsAll :: PrepQuery R () RowGalleyTeamNotifications selectGalleyTeamNotificationsAll = "SELECT team, id, payload FROM team_notifications" @@ -928,7 +928,7 @@ selectGalleyTeamNotificationsAll = "SELECT team, id, payload FROM team_notificat readGalleyTeamNotificationsAll :: Env -> ConduitM () [RowGalleyTeamNotifications] IO () readGalleyTeamNotificationsAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyTeamNotificationsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyTeamNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyTeamNotificationsFull :: Env -> FilePath -> IO () exportGalleyTeamNotificationsFull env@Env {..} path = do @@ -966,7 +966,7 @@ selectGalleyUser = "SELECT user, conv, conv_remote_domain, conv_remote_id FROM u readGalleyUser :: Env -> [UserId] -> ConduitM () [RowGalleyUser] IO () readGalleyUser Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyUser (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyUser (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyUserAll :: PrepQuery R () RowGalleyUser selectGalleyUserAll = "SELECT user, conv, conv_remote_domain, conv_remote_id FROM user" @@ -974,7 +974,7 @@ selectGalleyUserAll = "SELECT user, conv, conv_remote_domain, conv_remote_id FRO readGalleyUserAll :: Env -> ConduitM () [RowGalleyUser] IO () readGalleyUserAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyUserAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserFull :: Env -> FilePath -> IO () exportGalleyUserFull env@Env {..} path = do @@ -1012,7 +1012,7 @@ selectGalleyUserTeam = "SELECT user, team FROM user_team WHERE user in ?" readGalleyUserTeam :: Env -> [UserId] -> ConduitM () [RowGalleyUserTeam] IO () readGalleyUserTeam Env {..} uids = transPipe (runClient envGalley) $ - paginateC selectGalleyUserTeam (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGalleyUserTeam (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGalleyUserTeamAll :: PrepQuery R () RowGalleyUserTeam selectGalleyUserTeamAll = "SELECT user, team FROM user_team" @@ -1020,7 +1020,7 @@ selectGalleyUserTeamAll = "SELECT user, team FROM user_team" readGalleyUserTeamAll :: Env -> ConduitM () [RowGalleyUserTeam] IO () readGalleyUserTeamAll Env {..} = transPipe (runClient envGalley) $ - paginateC selectGalleyUserTeamAll (paramsP Quorum () envPageSize) x5 + paginateC selectGalleyUserTeamAll (paramsP LocalQuorum () envPageSize) x5 exportGalleyUserTeamFull :: Env -> FilePath -> IO () exportGalleyUserTeamFull env@Env {..} path = do @@ -1058,7 +1058,7 @@ selectGundeckNotifications = "SELECT user, id, clients, payload FROM notificatio readGundeckNotifications :: Env -> [UserId] -> ConduitM () [RowGundeckNotifications] IO () readGundeckNotifications Env {..} uids = transPipe (runClient envGundeck) $ - paginateC selectGundeckNotifications (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectGundeckNotifications (paramsP LocalQuorum (pure uids) envPageSize) x5 selectGundeckNotificationsAll :: PrepQuery R () RowGundeckNotifications selectGundeckNotificationsAll = "SELECT user, id, clients, payload FROM notifications" @@ -1066,7 +1066,7 @@ selectGundeckNotificationsAll = "SELECT user, id, clients, payload FROM notifica readGundeckNotificationsAll :: Env -> ConduitM () [RowGundeckNotifications] IO () readGundeckNotificationsAll Env {..} = transPipe (runClient envGundeck) $ - paginateC selectGundeckNotificationsAll (paramsP Quorum () envPageSize) x5 + paginateC selectGundeckNotificationsAll (paramsP LocalQuorum () envPageSize) x5 exportGundeckNotificationsFull :: Env -> FilePath -> IO () exportGundeckNotificationsFull env@Env {..} path = do @@ -1104,7 +1104,7 @@ selectSparScimExternal = "SELECT team, external_id, user FROM scim_external WHER readSparScimExternal :: Env -> TeamId -> ConduitM () [RowSparScimExternal] IO () readSparScimExternal Env {..} tid = transPipe (runClient envSpar) $ - paginateC selectSparScimExternal (paramsP Quorum (pure tid) envPageSize) x5 + paginateC selectSparScimExternal (paramsP LocalQuorum (pure tid) envPageSize) x5 selectSparScimExternalAll :: PrepQuery R () RowSparScimExternal selectSparScimExternalAll = "SELECT team, external_id, user FROM scim_external" @@ -1112,7 +1112,7 @@ selectSparScimExternalAll = "SELECT team, external_id, user FROM scim_external" readSparScimExternalAll :: Env -> ConduitM () [RowSparScimExternal] IO () readSparScimExternalAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparScimExternalAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparScimExternalAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimExternalFull :: Env -> FilePath -> IO () exportSparScimExternalFull env@Env {..} path = do @@ -1150,7 +1150,7 @@ selectSparScimUserTimes = "SELECT uid, created_at, last_updated_at FROM scim_use readSparScimUserTimes :: Env -> [UserId] -> ConduitM () [RowSparScimUserTimes] IO () readSparScimUserTimes Env {..} uids = transPipe (runClient envSpar) $ - paginateC selectSparScimUserTimes (paramsP Quorum (pure uids) envPageSize) x5 + paginateC selectSparScimUserTimes (paramsP LocalQuorum (pure uids) envPageSize) x5 selectSparScimUserTimesAll :: PrepQuery R () RowSparScimUserTimes selectSparScimUserTimesAll = "SELECT uid, created_at, last_updated_at FROM scim_user_times" @@ -1158,7 +1158,7 @@ selectSparScimUserTimesAll = "SELECT uid, created_at, last_updated_at FROM scim_ readSparScimUserTimesAll :: Env -> ConduitM () [RowSparScimUserTimes] IO () readSparScimUserTimesAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparScimUserTimesAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparScimUserTimesAll (paramsP LocalQuorum () envPageSize) x5 exportSparScimUserTimesFull :: Env -> FilePath -> IO () exportSparScimUserTimesFull env@Env {..} path = do @@ -1196,7 +1196,7 @@ selectSparUser = "SELECT issuer, sso_id, uid FROM user WHERE issuer in ?" readSparUser :: Env -> [Text] -> ConduitM () [RowSparUser] IO () readSparUser Env {..} issuer = transPipe (runClient envSpar) $ - paginateC selectSparUser (paramsP Quorum (pure issuer) envPageSize) x5 + paginateC selectSparUser (paramsP LocalQuorum (pure issuer) envPageSize) x5 selectSparUserAll :: PrepQuery R () RowSparUser selectSparUserAll = "SELECT issuer, sso_id, uid FROM user" @@ -1204,7 +1204,7 @@ selectSparUserAll = "SELECT issuer, sso_id, uid FROM user" readSparUserAll :: Env -> ConduitM () [RowSparUser] IO () readSparUserAll Env {..} = transPipe (runClient envSpar) $ - paginateC selectSparUserAll (paramsP Quorum () envPageSize) x5 + paginateC selectSparUserAll (paramsP LocalQuorum () envPageSize) x5 exportSparUserFull :: Env -> FilePath -> IO () exportSparUserFull env@Env {..} path = do diff --git a/tools/db/move-team/src/Types.hs b/tools/db/move-team/src/Types.hs index 905dee633ed..e103908cb73 100644 --- a/tools/db/move-team/src/Types.hs +++ b/tools/db/move-team/src/Types.hs @@ -36,8 +36,7 @@ import Data.Id import qualified Data.Text as T import Data.Text.Ascii (AsciiText, Base64, decodeBase64, encodeBase64) import qualified Data.Vector as V -import Database.CQL.Protocol (ColumnType (VarCharColumn)) -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import System.Logger (Logger) import Wire.API.User.Password (PasswordResetKey (..)) diff --git a/tools/db/move-team/src/Work.hs b/tools/db/move-team/src/Work.hs index 7d9e8207aef..cab4883b389 100644 --- a/tools/db/move-team/src/Work.hs +++ b/tools/db/move-team/src/Work.hs @@ -38,7 +38,7 @@ import qualified Data.Conduit.List as CL import Data.Id import qualified Data.Set as Set import Data.UUID -import Galley.Data.Instances () +import Galley.Cassandra.Instances () import Imports import Schema import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitWith) diff --git a/tools/db/repair-handles/src/Work.hs b/tools/db/repair-handles/src/Work.hs index d8ab725020b..3a014750375 100644 --- a/tools/db/repair-handles/src/Work.hs +++ b/tools/db/repair-handles/src/Work.hs @@ -60,7 +60,7 @@ type HandleMap = Map UserId [Handle] readHandleMap :: Env -> IO HandleMap readHandleMap Env {..} = runConduit $ - (transPipe (runClient envBrig) $ paginateC selectUserHandle (paramsP Quorum () envPageSize) x1) + (transPipe (runClient envBrig) $ paginateC selectUserHandle (paramsP LocalQuorum () envPageSize) x1) .| (C.foldM insertAndLog (Map.empty, 0) <&> fst) where selectUserHandle :: PrepQuery R () (Maybe UserId, Maybe Handle) @@ -121,7 +121,7 @@ decideAction uid (Just currentHandle) handles = sourceActions :: Env -> HandleMap -> ConduitM () ActionResult IO () sourceActions Env {..} hmap = ( transPipe (runClient envGalley) $ - paginateC selectTeam (paramsP Quorum (pure envTeam) envPageSize) x5 + paginateC selectTeam (paramsP LocalQuorum (pure envTeam) envPageSize) x5 .| C.map (fmap runIdentity) ) .| C.mapM readUsersPage @@ -137,7 +137,7 @@ sourceActions Env {..} hmap = readUsersPage :: [UserId] -> IO [(UserId, Maybe Handle)] readUsersPage uids = runClient envBrig $ - query selectUsers (params Quorum (pure uids)) + query selectUsers (params LocalQuorum (pure uids)) selectUsers :: PrepQuery R (Identity [UserId]) (UserId, Maybe Handle) selectUsers = "SELECT id, handle FROM user WHERE id in ?" @@ -154,7 +154,7 @@ executeAction env = \case setUserHandle :: Env -> UserId -> Handle -> IO () setUserHandle Env {..} uid handle = runClient envBrig $ - Cas.write updateHandle $ params Quorum (handle, uid) + Cas.write updateHandle $ params LocalQuorum (handle, uid) where updateHandle :: PrepQuery W (Handle, UserId) () updateHandle = "UPDATE user SET handle = ? WHERE id = ?" @@ -162,7 +162,7 @@ executeAction env = \case removeHandle :: Env -> Handle -> IO () removeHandle Env {..} handle = runClient envBrig $ - Cas.write deleteHandle $ params Quorum (pure handle) + Cas.write deleteHandle $ params LocalQuorum (pure handle) where deleteHandle :: PrepQuery W (Identity Handle) () deleteHandle = "DELETE FROM user_handle WHERE handle = ?" diff --git a/tools/db/service-backfill/src/Work.hs b/tools/db/service-backfill/src/Work.hs index 5b73e8d68c6..99f7b856fed 100644 --- a/tools/db/service-backfill/src/Work.hs +++ b/tools/db/service-backfill/src/Work.hs @@ -62,7 +62,7 @@ pageSize = 1000 -- | Get users from Galley getUsers :: ConduitM () [(Maybe ProviderId, Maybe ServiceId, BotId, ConvId)] Client () -getUsers = paginateC cql (paramsP Quorum () pageSize) x5 +getUsers = paginateC cql (paramsP LocalQuorum () pageSize) x5 where cql :: PrepQuery R () (Maybe ProviderId, Maybe ServiceId, BotId, ConvId) cql = "SELECT provider, service, user, conv FROM member" @@ -72,7 +72,7 @@ resolveBot :: (Maybe ProviderId, Maybe ServiceId, BotId, ConvId) -> Client (Maybe (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId)) resolveBot (Just pid, Just sid, bid, cid) = do - tid <- retry x5 $ query1 teamSelect (params Quorum (Identity cid)) + tid <- retry x5 $ query1 teamSelect (params LocalQuorum (Identity cid)) pure (Just (pid, sid, bid, cid, join (fmap runIdentity tid))) where teamSelect :: PrepQuery R (Identity ConvId) (Identity (Maybe TeamId)) @@ -85,7 +85,7 @@ writeBots :: Client () writeBots [] = pure () writeBots xs = retry x5 . batch $ do - setConsistency Quorum + setConsistency LocalQuorum setType BatchLogged forM_ xs $ \(pid, sid, bid, cid, mbTid) -> do addPrepQuery writeUser (pid, sid, bid, cid, mbTid) diff --git a/tools/nginz_disco/README.md b/tools/nginz_disco/README.md index da952414c76..5571c7a1a38 100644 --- a/tools/nginz_disco/README.md +++ b/tools/nginz_disco/README.md @@ -2,5 +2,5 @@ Due to nginx not supporting DNS names for its list of upstream servers (unless you pay extra), the nginz-disco container is a simple bash script to do DNS lookups and write the resulting IPs to a file. Nginz reloads on changes to this file. -This is useful as a sidecar container to nginz in kubernetes. See also [wire-server-deploy/nginz](https://github.com/wireapp/wire-server-deploy/charts/nginz/) +This is useful as a sidecar container to nginz in kubernetes. See also [wire-server-deploy/nginz](https://github.com/wireapp/wire-server-deploy/charts/nginz/)