From f0cf2abde1d7978b8fd4d13d67b57399d6480be0 Mon Sep 17 00:00:00 2001 From: Florian Klink Date: Mon, 17 Jan 2022 13:35:32 +0100 Subject: [PATCH 01/58] nix/pkgs: move cryptobox and zauth into their own folders Further align it with nixpkgs style. --- nix/overlays/wire-server.nix | 58 ++-------------------------------- nix/pkgs/cryptobox/default.nix | 31 ++++++++++++++++++ nix/pkgs/zauth/default.nix | 34 ++++++++++++++++++++ 3 files changed, 67 insertions(+), 56 deletions(-) create mode 100644 nix/pkgs/cryptobox/default.nix create mode 100644 nix/pkgs/zauth/default.nix diff --git a/nix/overlays/wire-server.nix b/nix/overlays/wire-server.nix index 9ba8ca872fb..6c4a6f439b1 100644 --- a/nix/overlays/wire-server.nix +++ b/nix/overlays/wire-server.nix @@ -1,60 +1,6 @@ self: super: { - # TODO: Do not use buildRustPackage. Ces't horrible - cryptobox = self.callPackage ( - { fetchFromGitHub, rustPlatform, pkgconfig, libsodium }: - rustPlatform.buildRustPackage rec { - name = "cryptobox-c-${version}"; - version = "2019-06-17"; - nativeBuildInputs = [ pkgconfig ]; - buildInputs = [ libsodium ]; - src = fetchFromGitHub { - owner = "wireapp"; - repo = "cryptobox-c"; - rev = "4067ad96b125942545dbdec8c1a89f1e1b65d013"; - sha256 = "1i9dlhw0xk1viglyhail9fb36v1awrypps8jmhrkz8k1bhx98ci3"; - }; - cargoSha256 = "sha256-Afr3ShCXDCwTQNdeCZbA5/aosRt+KFpGfT1mrob6cog="; - - patchLibs = super.lib.optionalString super.stdenv.isDarwin '' - install_name_tool -id $out/lib/libcryptobox.dylib $out/lib/libcryptobox.dylib - ''; - - postInstall = '' - ${patchLibs} - mkdir -p $out/include - cp src/cbox.h $out/include - ''; - } - ) {}; - - zauth = self.callPackage ( - { fetchFromGitHub, rustPlatform, pkgconfig, libsodium }: - rustPlatform.buildRustPackage rec { - name = "libzauth-${version}"; - version = "3.0.0"; - nativeBuildInputs = [ pkgconfig ]; - buildInputs = [ libsodium ]; - src = self.nix-gitignore.gitignoreSourcePure [ ../../.gitignore ] ../../libs/libzauth; - sourceRoot = "libzauth/libzauth-c"; - - cargoSha256 = "sha256-umwOVCFHtszu64aIc8eqMPGCS7vt1nYQFAQh2XuV+v4="; # self.lib.fakeSha256; - - patchLibs = super.lib.optionalString super.stdenv.isDarwin '' - install_name_tool -id $out/lib/libzauth.dylib $out/lib/libzauth.dylib - ''; - - postInstall = '' - mkdir -p $out/lib/pkgconfig - mkdir -p $out/include - cp src/zauth.h $out/include - sed -e "s~<>~${version}~" \ - -e "s~<>~$out~" \ - src/libzauth.pc > $out/lib/pkgconfig/libzauth.pc - cp target/release-tmp/libzauth.* $out/lib/ - ${patchLibs} - ''; - } - ) {}; + cryptobox = self.callPackage ../pkgs/cryptobox { }; + zauth = self.callPackage ../pkgs/zauth { }; nginxModules = super.nginxModules // { zauth = { diff --git a/nix/pkgs/cryptobox/default.nix b/nix/pkgs/cryptobox/default.nix new file mode 100644 index 00000000000..5945c616f22 --- /dev/null +++ b/nix/pkgs/cryptobox/default.nix @@ -0,0 +1,31 @@ +{ fetchFromGitHub +, lib +, libsodium +, pkg-config +, rustPlatform +, stdenv +}: + +rustPlatform.buildRustPackage rec { + name = "cryptobox-c-${version}"; + version = "2019-06-17"; + nativeBuildInputs = [ pkg-config ]; + buildInputs = [ libsodium ]; + src = fetchFromGitHub { + owner = "wireapp"; + repo = "cryptobox-c"; + rev = "4067ad96b125942545dbdec8c1a89f1e1b65d013"; + sha256 = "1i9dlhw0xk1viglyhail9fb36v1awrypps8jmhrkz8k1bhx98ci3"; + }; + cargoSha256 = "sha256-Afr3ShCXDCwTQNdeCZbA5/aosRt+KFpGfT1mrob6cog="; + + patchLibs = lib.optionalString stdenv.isDarwin '' + install_name_tool -id $out/lib/libcryptobox.dylib $out/lib/libcryptobox.dylib + ''; + + postInstall = '' + ${patchLibs} + mkdir -p $out/include + cp src/cbox.h $out/include + ''; +} diff --git a/nix/pkgs/zauth/default.nix b/nix/pkgs/zauth/default.nix new file mode 100644 index 00000000000..432fd1810d0 --- /dev/null +++ b/nix/pkgs/zauth/default.nix @@ -0,0 +1,34 @@ +{ fetchFromGitHub +, lib +, libsodium +, nix-gitignore +, pkg-config +, rustPlatform +, stdenv +}: + +rustPlatform.buildRustPackage rec { + name = "libzauth-${version}"; + version = "3.0.0"; + nativeBuildInputs = [ pkg-config ]; + buildInputs = [ libsodium ]; + src = nix-gitignore.gitignoreSourcePure [ ../../../.gitignore ] ../../../libs/libzauth; + sourceRoot = "libzauth/libzauth-c"; + + cargoSha256 = "10ijvi3rnnqpy589hhhp8s4p7xfpsbb1c3mzqnf65ra96q4nd6bf"; # self.lib.fakeSha256; + + patchLibs = lib.optionalString stdenv.isDarwin '' + install_name_tool -id $out/lib/libzauth.dylib $out/lib/libzauth.dylib + ''; + + postInstall = '' + mkdir -p $out/lib/pkgconfig + mkdir -p $out/include + cp src/zauth.h $out/include + sed -e "s~<>~${version}~" \ + -e "s~<>~$out~" \ + src/libzauth.pc > $out/lib/pkgconfig/libzauth.pc + cp target/release-tmp/libzauth.* $out/lib/ + ${patchLibs} + ''; +} From 9ebf3b0c8f2b747568e5a1ed74fcccd1262fc3e7 Mon Sep 17 00:00:00 2001 From: Florian Klink Date: Mon, 17 Jan 2022 13:40:37 +0100 Subject: [PATCH 02/58] nix: move nix/overlays/wire-server.nix to nix/overlay.nix We only have one overlay. --- nix/default.nix | 6 +++--- nix/{overlays/wire-server.nix => overlay.nix} | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) rename nix/{overlays/wire-server.nix => overlay.nix} (63%) diff --git a/nix/default.nix b/nix/default.nix index 00a7df196fa..00bf284b9b7 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -4,11 +4,11 @@ let config.allowUnfree = true; overlays = [ # the tool we use for versioning (The thing that generates sources.json) - (_: _: { niv = (import sources.niv {}).niv; }) + (_: _: { niv = (import sources.niv { }).niv; }) # All wire-server specific packages - (import ./overlays/wire-server.nix) + (import ./overlay.nix) ]; }; in - pkgs +pkgs diff --git a/nix/overlays/wire-server.nix b/nix/overlay.nix similarity index 63% rename from nix/overlays/wire-server.nix rename to nix/overlay.nix index 6c4a6f439b1..771ec26e503 100644 --- a/nix/overlays/wire-server.nix +++ b/nix/overlay.nix @@ -1,10 +1,10 @@ self: super: { - cryptobox = self.callPackage ../pkgs/cryptobox { }; - zauth = self.callPackage ../pkgs/zauth { }; + cryptobox = self.callPackage ./pkgs/cryptobox { }; + zauth = self.callPackage ./pkgs/zauth { }; nginxModules = super.nginxModules // { zauth = { - src = ../../services/nginz/third_party/nginx-zauth-module; + src = ../services/nginz/third_party/nginx-zauth-module; inputs = [ self.pkg-config self.zauth ]; }; }; From 84959489997484ed2c6bc1c95023f22d0dc2ddda Mon Sep 17 00:00:00 2001 From: Florian Klink Date: Mon, 17 Jan 2022 13:42:40 +0100 Subject: [PATCH 03/58] nix/pkgs/zauth: fix cargoSha256 --- nix/pkgs/zauth/default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/pkgs/zauth/default.nix b/nix/pkgs/zauth/default.nix index 432fd1810d0..7572ec3478e 100644 --- a/nix/pkgs/zauth/default.nix +++ b/nix/pkgs/zauth/default.nix @@ -15,7 +15,7 @@ rustPlatform.buildRustPackage rec { src = nix-gitignore.gitignoreSourcePure [ ../../../.gitignore ] ../../../libs/libzauth; sourceRoot = "libzauth/libzauth-c"; - cargoSha256 = "10ijvi3rnnqpy589hhhp8s4p7xfpsbb1c3mzqnf65ra96q4nd6bf"; # self.lib.fakeSha256; + cargoSha256 = "umwOVCFHtszu64aIc8eqMPGCS7vt1nYQFAQh2XuV+v4="; # self.lib.fakeSha256; patchLibs = lib.optionalString stdenv.isDarwin '' install_name_tool -id $out/lib/libzauth.dylib $out/lib/libzauth.dylib From cdbd326eed6d435bc688efe5400dd831570a01ba Mon Sep 17 00:00:00 2001 From: Florian Klink Date: Mon, 17 Jan 2022 13:23:51 +0100 Subject: [PATCH 04/58] direnv.nix: add niv Simplifies interacting with nix/sources.json --- dev-packages.nix | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/dev-packages.nix b/dev-packages.nix index 73522c868eb..f7ce4920953 100644 --- a/dev-packages.nix +++ b/dev-packages.nix @@ -141,6 +141,7 @@ let pkgs.libsodium.dev pkgs.libxml2.dev pkgs.ncurses.dev + pkgs.niv.out pkgs.openssl.dev pkgs.pcre.dev pkgs.snappy.dev @@ -166,7 +167,7 @@ in pkgs.cfssl pkgs.docker-compose pkgs.gnumake - (pkgs.haskell-language-server.override {supportedGhcVersions = ["8107"];}) + (pkgs.haskell-language-server.override { supportedGhcVersions = [ "8107" ]; }) pkgs.jq pkgs.ormolu pkgs.telepresence From 338be214df5fd4447d55e3e8309e16c33a2890e5 Mon Sep 17 00:00:00 2001 From: VictorWissink Date: Fri, 28 Jan 2022 14:04:38 +0100 Subject: [PATCH 05/58] Update TESTMapping TSFI's --- libs/zauth/test/ZAuth.hs | 2 +- services/brig/test/integration/API/User/Auth.hs | 4 ++-- .../federator/test/unit/Test/Federator/InternalServer.hs | 2 +- services/federator/test/unit/Test/Federator/Options.hs | 2 +- services/federator/test/unit/Test/Federator/Remote.hs | 2 +- services/federator/test/unit/Test/Federator/Validation.hs | 6 +++--- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 13c2de15611..703cbd69b5a 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -94,7 +94,7 @@ testNotExpired p = do liftIO $ assertBool "testNotExpired: validation failed" (isRight x) -- The testExpired test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 +-- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 @S3 -- -- Using an expired access token should fail testExpired :: V.Env -> Create () diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index dc0691bb902..828209c187d 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -402,7 +402,7 @@ testThrottleLogins conf b = do login b (defEmailLogin e) SessionCookie !!! const 200 === statusCode -- The testLimitRetries test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @S2 +-- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- The following test tests the login retries. It checks that a user can make -- only a prespecified number of attempts to log in with an invalid password, @@ -585,7 +585,7 @@ testNoUserSsoLogin brig = do -- Token Refresh -- The testInvalidCookie test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 +-- @SF.Provisioning @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- Test that invalid and expired tokens do not work. testInvalidCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index f4560fd9f3b..89e79ff1837 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -100,7 +100,7 @@ federatedRequestSuccess = body <- Wai.lazyResponseBody res body @?= "\"bar\"" --- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when allowlist is configured. federatedRequestFailureAllowList :: TestTree diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index b891fc6d810..b6b2e884b05 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -171,7 +171,7 @@ testSettings = assertFailure $ "expected failure for non-existing client certificate, got: " <> show (tlsSettings ^. creds), - -- @SF.Federation @TSFI.RESTfulAPI @S3 @S7 + -- @SF.Federation @TSFI.Federate @S3 @S7 testCase "failToStartWithInvalidServerCredentials" $ do let settings = defRunSettings diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 842feba3602..67512bcdbb6 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -120,7 +120,7 @@ testValidatesCertificateSuccess = Right _ -> assertFailure "Congratulations, you fixed a known issue!" ] --- @SF.Federation @TSFI.RESTfulAPI @S2 +-- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 -- -- This is a group of test cases where refusing to connect with the server is -- checked. The second test case refuses to connect with a server when the diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 33ff845826c..498a4079e8f 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -117,7 +117,7 @@ validateDomainAllowListFailSemantic = $ validateDomain (Just exampleCert) "invalid//.><-semantic-&@-domain" res @?= Left (DomainParseError "invalid//.><-semantic-&@-domain") --- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when allowlist is configured. validateDomainAllowListFail :: TestTree @@ -162,7 +162,7 @@ validateDomainCertMissing = $ validateDomain Nothing "foo.example.com" res @?= Left NoClientCertificate --- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 validateDomainCertInvalid :: TestTree validateDomainCertInvalid = testCase "should fail if the client certificate is invalid" $ do @@ -176,7 +176,7 @@ validateDomainCertInvalid = -- @END --- @SF.Federation @TSFI.RESTfulAPI @S3 @S7 +-- @SF.Federation @TSFI.Federate @TSFI.DNS @S3 @S7 -- -- Reject request if the infrastructure domain in the client cert does not match the backend -- domain in the `Wire-origin-domain` header. From cc77207ce34f4ac18a1c651f65f9c2832493492c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 3 Feb 2022 10:10:25 +0100 Subject: [PATCH 06/58] SQSERVICES 1174 enforce access roles when adding a participant or generating a guest link (#2076) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * when a client tries to add a participant. For instance, a request to add a guest should fail if the access role setting doesn’t allow guests. when a client tried to generate a guest link. If the conversation access role doesn’t allow guests, then the link should not be generated. --- changelog.d/0-release-notes/pr-2076 | 1 + services/galley/src/Galley/API/Update.hs | 4 ++++ services/galley/test/integration/API.hs | 24 +++++++++++++++++++++++- 3 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/pr-2076 diff --git a/changelog.d/0-release-notes/pr-2076 b/changelog.d/0-release-notes/pr-2076 new file mode 100644 index 00000000000..0c4c7832c97 --- /dev/null +++ b/changelog.d/0-release-notes/pr-2076 @@ -0,0 +1 @@ +Enforce conversation access roles more tightly on the backend: if a guests or non-team-members are not allowed, block guest link creation (new behavior) as well as ephemeral users joining (old behavior). diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 4ab5392bbad..ede7fb6ee5a 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -567,6 +567,7 @@ addCode lusr zcon lcnv = do Query.ensureGuestLinksEnabled conv ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) ensureAccess conv CodeAccess + ensureGuestsOrNonTeamMembersAllowed conv let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv key <- E.makeKey (tUnqualified lcnv) mCode <- E.getCode key ReusableCode @@ -586,6 +587,9 @@ addCode lusr zcon lcnv = do createCode :: Code -> Sem r ConversationCode createCode code = do mkConversationCode (codeKey code) (codeValue code) <$> E.getConversationCodeURI + ensureGuestsOrNonTeamMembersAllowed :: Data.Conversation -> Sem r () + ensureGuestsOrNonTeamMembersAllowed conv = + unless (GuestAccessRole `Set.member` convAccessRoles conv || NonTeamMemberAccessRole `Set.member` convAccessRoles conv) $ throw ConvAccessDenied rmCodeH :: Members diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index ecde034202a..a9c5e052574 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -155,6 +155,8 @@ tests s = test s "add members" postMembersOk, test s "add existing members" postMembersOk2, test s "add past members" postMembersOk3, + test s "add guest forbidden when no guest access role" postMembersFailNoGuestAccess, + test s "generate guest link forbidden when no guest or non-team-member access role" generateGuestLinkFailIfNoNonTeamMemberOrNoGuestAccess, test s "fail to add members when not connected" postMembersFail, test s "fail to add too many members" postTooManyMembersFail, test s "add remote members" testAddRemoteMember, @@ -1209,7 +1211,7 @@ testGetCodeRejectedIfGuestLinksDisabled :: TestM () testGetCodeRejectedIfGuestLinksDisabled = do galley <- view tsGalley (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 - Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole] [GuestAccessRole] + Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, GuestAccessRole] [] let createConvWithGuestLink = do convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just accessRoles) Nothing void $ decodeConvCodeEvent <$> postConvCode owner convId @@ -2537,6 +2539,26 @@ postMembersOk3 = do -- Fetch bob again getSelfMember bob conv !!! const 200 === statusCode +postMembersFailNoGuestAccess :: TestM () +postMembersFailNoGuestAccess = do + alice <- randomUser + bob <- randomUser + peter <- randomUser + eve <- ephemeralUser + connectUsers alice (list1 bob [peter]) + Right noGuestsAccess <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, NonTeamMemberAccessRole] [GuestAccessRole] + conv <- decodeConvId <$> postConv alice [bob, peter] (Just "gossip") [] (Just noGuestsAccess) Nothing + postMembers alice (singleton eve) conv !!! const 403 === statusCode + +generateGuestLinkFailIfNoNonTeamMemberOrNoGuestAccess :: TestM () +generateGuestLinkFailIfNoNonTeamMemberOrNoGuestAccess = do + alice <- randomUser + bob <- randomUser + connectUsers alice (singleton bob) + Right noGuestsAccess <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole] [GuestAccessRole, NonTeamMemberAccessRole] + convId <- decodeConvId <$> postConv alice [bob] (Just "gossip") [CodeAccess] (Just noGuestsAccess) Nothing + postConvCode alice convId !!! const 403 === statusCode + postMembersFail :: TestM () postMembersFail = do alice <- randomUser From c95cea1040d7d9ea124b1747cf6a8df9b5ea49f8 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Thu, 3 Feb 2022 10:34:10 +0100 Subject: [PATCH 07/58] Update servant.md: Add link to schema-profunctor README.md (#2021) The link makes it easier to go to the mentioned README.md. --- docs/developer/servant.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/developer/servant.md b/docs/developer/servant.md index 07e003facbc..e514c6934fe 100644 --- a/docs/developer/servant.md +++ b/docs/developer/servant.md @@ -4,7 +4,7 @@ We currently use Servant for the public (i.e. client-facing) API in brig, galley Client-facing APIs are defined in `Wire.API.Routes.Public.{Brig,Galley}`. Internal APIs are all over the place at the moment. Federation APIs are in `Wire.API.Federation.API.{Brig,Galley}`. -Our APIs are able to generate Swagger documentation semi-automatically using `servant-swagger2`. The `schema-profunctor` library (see README in libs/schema-profunctor) is used to create "schemas" for the input and output types used in the Servant APIs. A schema contains all the information needed to serialise/deserialise JSON values, as well as the documentation and metadata needed to generate Swagger. +Our APIs are able to generate Swagger documentation semi-automatically using `servant-swagger2`. The `schema-profunctor` library (see [`README.md`](/libs/schema-profunctor/README.md) in `libs/schema-profunctor`) is used to create "schemas" for the input and output types used in the Servant APIs. A schema contains all the information needed to serialise/deserialise JSON values, as well as the documentation and metadata needed to generate Swagger. # Combinators From 8ce70c8556d7e9e84d6a2a1256e1416e914290b0 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Thu, 3 Feb 2022 11:29:20 +0100 Subject: [PATCH 08/58] More logs in gundeck - Make sure `Debug` log level may be used in production (#2053) * Do not log notification payloads (SQPIT-834) These are considered private and secret. We should not break this by logging. * Log notifications that are bulk sent to Cannon (SQPIT-834) All notifications are logged, but (due to privacy / security reasons) no contents. * Add changelog entry --- changelog.d/5-internal/gundeck-debug-logs | 4 ++++ services/gundeck/src/Gundeck/Push/Native.hs | 3 --- .../gundeck/src/Gundeck/Push/Websocket.hs | 20 ++++++++++++++----- 3 files changed, 19 insertions(+), 8 deletions(-) create mode 100644 changelog.d/5-internal/gundeck-debug-logs diff --git a/changelog.d/5-internal/gundeck-debug-logs b/changelog.d/5-internal/gundeck-debug-logs new file mode 100644 index 00000000000..3d5ca38b103 --- /dev/null +++ b/changelog.d/5-internal/gundeck-debug-logs @@ -0,0 +1,4 @@ +To investigate issues related to push notifications, adjust Gundeck `Debug` +leveled logs to not print the message itself. So, that it can safely be turned +on in production environments. Add a log entry when a bulk notification is +pushed to Cannon. diff --git a/services/gundeck/src/Gundeck/Push/Native.hs b/services/gundeck/src/Gundeck/Push/Native.hs index d0baae81b5b..6a97efd6e15 100644 --- a/services/gundeck/src/Gundeck/Push/Native.hs +++ b/services/gundeck/src/Gundeck/Push/Native.hs @@ -24,7 +24,6 @@ where import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch -import Data.Aeson (encode) import Data.ByteString.Conversion.To import Data.Id import Data.List1 @@ -125,8 +124,6 @@ publish m a = flip catches pushException $ do ~~ field "arn" (toText (a ^. addrEndpoint)) ~~ field "notificationId" (toText (npNotificationid m)) ~~ field "prio" (show (npPriority m)) - ~~ field "apsData" (encode (npApsData m)) - ~~ field "payload" (show txt) ~~ Log.msg (val "Native push") case txt of Left f -> return $! Failure f a diff --git a/services/gundeck/src/Gundeck/Push/Websocket.hs b/services/gundeck/src/Gundeck/Push/Websocket.hs index 86671d0a0c8..03716d0dbfa 100644 --- a/services/gundeck/src/Gundeck/Push/Websocket.hs +++ b/services/gundeck/src/Gundeck/Push/Websocket.hs @@ -151,7 +151,8 @@ bulkSend :: MonadMask m, HasRequestId m, MonadHttp m, - MonadUnliftIO m + MonadUnliftIO m, + Log.MonadLogger m ) => URI -> BulkPushRequest -> @@ -166,12 +167,21 @@ bulkSend' :: MonadMask m, HasRequestId m, MonadHttp m, - MonadUnliftIO m + MonadUnliftIO m, + Log.MonadLogger m ) => URI -> BulkPushRequest -> m BulkPushResponse -bulkSend' uri (encode -> jsbody) = do +bulkSend' uri bulkPushRequest = do + forM_ (fromBulkPushRequest bulkPushRequest) $ \(notification, targets) -> + Log.debug $ + Log.msg ("Bulk sending notification to Cannon." :: Text) + . Log.field "ntf_id" (show (ntfId notification)) + . Log.field "user_ids" (show (map ptUserId targets)) + . Log.field "conn_ids" (show (map ptConnId targets)) + + let jsbody = encode bulkPushRequest req <- check . method POST @@ -387,5 +397,5 @@ send n pp = logPresence :: Presence -> Log.Msg -> Log.Msg logPresence p = - Log.field "user" (toByteString (userId p)) - ~~ Log.field "zconn" (toByteString (connId p)) + Log.field "user_id" (toByteString (userId p)) + ~~ Log.field "conn_id" (toByteString (connId p)) From e48a6bd2689e183352a52e766b840f18e944c519 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 3 Feb 2022 17:12:23 +0100 Subject: [PATCH 09/58] Brig: Servantify self API (#2091) * Brig: Servantify `PUT /self` endpoint * Brig: Servantify PUT `/self/phone` endpoint * Brig: Sevantify `DELETE /self/{email,phone}` endpoints * Brig: Servantify `HEAD /self/password` endpoint Also add instnce for AsUnion '[..] Bool back. * Brig: Servantify `PUT /self/password` endpoint * PasswordChange: Adjust golden JSONs to not include null old_password Only `FromJSON` needs to be backwards compatible as this object is consumed as request body by brig. So, breaking `ToJSON` like this shouldn't cause any issues. * Brig: Servantify `PUT /self/locale` endpoint * Brig: Servantify `PUT /self/handle` endpoint * Add changelog * Delete duplicate errors use ErrorDescription where possible * Delete unused swagger 1.x docs * Brig: Deflake user update test The test was using a hardcoded name for a user and searching for the user. Since the DB is not cleaned up after/before every test run, this causes the new users to not show up in the search results. * Use maybe{To,From}Union instead of hand-written AsUnion instances --- changelog.d/5-internal/servantification | 1 + libs/wire-api/package.yaml | 1 + .../wire-api/src/Wire/API/ErrorDescription.hs | 20 ++ .../wire-api/src/Wire/API/Routes/MultiVerb.hs | 35 +++ .../src/Wire/API/Routes/Public/Brig.hs | 84 +++++++ libs/wire-api/src/Wire/API/Swagger.hs | 5 - libs/wire-api/src/Wire/API/User.hs | 225 +++++++++++------- libs/wire-api/src/Wire/API/User/Identity.hs | 13 +- .../testObject_PasswordChange_user_1.json | 3 +- .../testObject_PasswordChange_user_13.json | 3 +- .../testObject_PasswordChange_user_14.json | 3 +- .../testObject_PasswordChange_user_17.json | 3 +- .../testObject_PasswordChange_user_18.json | 3 +- .../testObject_PasswordChange_user_7.json | 3 +- libs/wire-api/wire-api.cabal | 1 + services/brig/src/Brig/API/Error.hs | 87 ++----- services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/Public.hs | 182 +++----------- services/brig/src/Brig/API/Types.hs | 25 -- services/brig/src/Brig/API/User.hs | 12 +- services/brig/src/Brig/API/Util.hs | 8 +- services/brig/src/Brig/Team/API.hs | 4 +- services/brig/src/Brig/User/API/Auth.hs | 6 +- .../brig/test/integration/API/User/Account.hs | 23 +- 24 files changed, 385 insertions(+), 367 deletions(-) create mode 100644 changelog.d/5-internal/servantification diff --git a/changelog.d/5-internal/servantification b/changelog.d/5-internal/servantification new file mode 100644 index 00000000000..90e81600ed9 --- /dev/null +++ b/changelog.d/5-internal/servantification @@ -0,0 +1 @@ +Servantify /self/* endpoints in brig. \ No newline at end of file diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index c616fb4d1c2..ffb719e83aa 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -41,6 +41,7 @@ library: - currency-codes >=2.0 - deriving-aeson >=0.2 - deriving-swagger2 + - either - email-validate >=2.0 - errors - extended diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 4cd0b9be10e..444e131a026 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -334,3 +334,23 @@ type AssetTooLarge = ErrorDescription 413 "client-error" "Asset too large" type InvalidLength = ErrorDescription 400 "invalid-length" "Invalid content length" type AssetNotFound = ErrorDescription 404 "not-found" "Asset not found" + +type NameManagedByScim = ErrorDescription 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM" + +type HandleManagedByScim = ErrorDescription 403 "managed-by-scim" "Updating handle is not allowed, because it is managed by SCIM" + +type InvalidPhone = ErrorDescription 400 "invalid-phone" "Invalid mobile phone number" + +type UserKeyExists = ErrorDescription 409 "key-exists" "The give e-mail address or phone number is in use." + +type BlacklistedPhone = ErrorDescription 403 "blacklisted-phone" "The given phone number has been blacklisted due to suspected abuse or a complaint." + +type LastIdentity = ErrorDescription 403 "last-identity" "The last user identity (email or phone number) cannot be removed." + +type NoPassword = ErrorDescription 403 "no-password" "The user has no password." + +type ChangePasswordMustDiffer = ErrorDescription 409 "password-must-differ" "For password change, new and old password must be different." + +type HandleExists = ErrorDescription 409 "handle-exists" "The given handle is already taken." + +type InvalidHandle = ErrorDescription 400 "invalid-handle" "The given handle is invalid." diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 590c583e32c..ff0498d6d5a 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -31,6 +31,8 @@ module Wire.API.Routes.MultiVerb AsUnion (..), eitherToUnion, eitherFromUnion, + maybeToUnion, + maybeFromUnion, AsConstructor (..), GenericAsConstructor (..), GenericAsUnion (..), @@ -50,6 +52,7 @@ import Data.ByteString.Builder import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI import Data.Containers.ListUtils +import Data.Either.Combinators (leftToMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Metrics.Servant @@ -529,6 +532,21 @@ instance EitherFromUnion as bs => EitherFromUnion (a ': as) bs where eitherFromUnion f _ (Z x) = Left (f (Z x)) eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x +maybeToUnion :: + forall as a. + (InjectAfter as '[()], InjectBefore as '[()]) => + (a -> Union as) -> + (Maybe a -> Union (as .++ '[()])) +maybeToUnion f (Just a) = injectBefore @as @'[()] (f a) +maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ())) + +maybeFromUnion :: + forall as a. + EitherFromUnion as '[()] => + (Union as -> a) -> + (Union (as .++ '[()]) -> Maybe a) +maybeFromUnion f = leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ()))) + -- | This class can be instantiated to get automatic derivation of 'AsUnion' -- instances via 'GenericAsUnion'. The idea is that one has to make sure that for -- each response @r@ in a 'MultiVerb' endpoint, there is an instance of @@ -607,6 +625,23 @@ instance toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs +-- | A handler for a pair of empty responses can be implemented simply by +-- returning a boolean value. The convention is that the "failure" case, normally +-- represented by 'False', corresponds to the /first/ response. +instance + AsUnion + '[ RespondEmpty s1 desc1, + RespondEmpty s2 desc2 + ] + Bool + where + toUnion False = Z (I ()) + toUnion True = S (Z (I ())) + + fromUnion (Z (I ())) = False + fromUnion (S (Z (I ()))) = True + fromUnion (S (S x)) = case x of + -- | A handler for a pair of responses where the first is empty can be -- implemented simply by returning a 'Maybe' value. The convention is that the -- "failure" case, normally represented by 'Nothing', corresponds to the /first/ diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index c800e770072..02adeba83da 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -135,6 +135,90 @@ data Api routes = Api :> "self" :> ReqBody '[JSON] DeleteUser :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout), + -- This endpoint can lead to the following events being sent: + -- - UserUpdated event to contacts of self + putSelf :: + routes + :- Summary "Update your profile." + :> ZUser + :> ZConn + :> "self" + :> ReqBody '[JSON] UserUpdate + :> MultiVerb 'PUT '[JSON] PutSelfResponses (Maybe UpdateProfileError), + changePhone :: + routes + :- Summary "Change your phone number." + :> ZUser + :> ZConn + :> "self" + :> "phone" + :> ReqBody '[JSON] PhoneUpdate + :> MultiVerb 'PUT '[JSON] ChangePhoneResponses (Maybe ChangePhoneError), + -- This endpoint can lead to the following events being sent: + -- - UserIdentityRemoved event to self + removePhone :: + routes + :- Summary "Remove your phone number." + :> Description + "Your phone number can only be removed if you also have an \ + \email address and a password." + :> ZUser + :> ZConn + :> "self" + :> "phone" + :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError), + -- This endpoint can lead to the following events being sent: + -- - UserIdentityRemoved event to self + removeEmail :: + routes + :- Summary "Remove your email address." + :> Description + "Your email address can only be removed if you also have a \ + \phone number." + :> ZUser + :> ZConn + :> "self" + :> "email" + :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError), + checkPasswordExists :: + routes + :- Summary "Check that your password is set." + :> ZUser + :> "self" + :> "password" + :> MultiVerb + 'HEAD + '() + '[ RespondEmpty 404 "Password is not set", + RespondEmpty 200 "Password is set" + ] + Bool, + changePassword :: + routes + :- Summary "Change your password." + :> ZUser + :> "self" + :> "password" + :> ReqBody '[JSON] PasswordChange + :> MultiVerb 'PUT '[JSON] ChangePasswordResponses (Maybe ChangePasswordError), + changeLocale :: + routes + :- Summary "Change your locale." + :> ZUser + :> ZConn + :> "self" + :> "locale" + :> ReqBody '[JSON] LocaleUpdate + :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Local Changed"] (), + changeHandle :: + routes + :- Summary "Change your handle." + :> ZUser + :> ZConn + :> "self" + :> "handle" + :> ReqBody '[JSON] HandleUpdate + :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError), updateUserEmail :: routes :- Summary "Resend email address validation email." diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 19cdb227c6a..1aa893026bc 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -142,12 +142,7 @@ models = User.modelUserIdList, User.modelUser, User.modelNewUser, - User.modelUserUpdate, - User.modelChangePassword, - User.modelChangeLocale, User.modelEmailUpdate, - User.modelPhoneUpdate, - User.modelChangeHandle, User.modelDelete, User.modelVerifyDelete, User.Activation.modelActivate, diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 2ef7f9f7158..5d11283717c 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -56,11 +56,21 @@ module Wire.API.User -- * Profile Updates UserUpdate (..), + UpdateProfileError (..), + PutSelfResponses, PasswordChange (..), + ChangePasswordError (..), + ChangePasswordResponses, LocaleUpdate (..), EmailUpdate (..), PhoneUpdate (..), + ChangePhoneError (..), + ChangePhoneResponses, + RemoveIdentityError (..), + RemoveIdentityResponses, HandleUpdate (..), + ChangeHandleError (..), + ChangeHandleResponses, NameUpdate (..), -- * Account Deletion @@ -81,16 +91,11 @@ module Wire.API.User module Wire.API.User.Profile, -- * Swagger - modelChangeHandle, - modelChangeLocale, - modelChangePassword, modelDelete, modelEmailUpdate, modelNewUser, - modelPhoneUpdate, modelUser, modelUserIdList, - modelUserUpdate, modelVerifyDelete, ) where @@ -113,9 +118,9 @@ import Data.Json.Util (UTCTimeMillis, (#)) import Data.LegalHold (UserLegalHoldStatus) import qualified Data.List as List import Data.Misc (PlainTextPassword (..)) -import Data.Proxy (Proxy (..)) import Data.Qualified import Data.Range +import Data.SOP import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc @@ -124,11 +129,15 @@ import Data.UUID (UUID, nil) import qualified Data.UUID as UUID import Deriving.Swagger import GHC.TypeLits (KnownNat, Nat) +import qualified Generics.SOP as GSOP import Imports import qualified SAML2.WebSSO as SAML +import Servant (type (.++)) import qualified Test.QuickCheck as QC import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.ErrorDescription import Wire.API.Provider.Service (ServiceRef, modelServiceRef) +import Wire.API.Routes.MultiVerb import Wire.API.Team (BindingNewTeam (BindingNewTeam), NewTeam (..), modelNewBindingTeam) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) @@ -830,37 +839,33 @@ data UserUpdate = UserUpdate uupAccentId :: Maybe ColourId } deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserUpdate) deriving (Arbitrary) via (GenericUniform UserUpdate) -modelUserUpdate :: Doc.Model -modelUserUpdate = Doc.defineModel "UserUpdate" $ do - Doc.description "User Update Data" - Doc.property "name" Doc.string' $ do - Doc.description "Name (1 - 128 characters)" - Doc.optional - Doc.property "assets" (Doc.array (Doc.ref modelAsset)) $ do - Doc.description "Profile assets" - Doc.optional - Doc.property "accent_id" Doc.int32' $ do - Doc.description "Accent colour ID" - Doc.optional +instance ToSchema UserUpdate where + schema = + object "UserUpdate" $ + UserUpdate + <$> uupName .= maybe_ (optField "name" schema) + <*> uupPict .= maybe_ (optField "picture" schema) + <*> uupAssets .= maybe_ (optField "assets" (array schema)) + <*> uupAccentId .= maybe_ (optField "accent_id" schema) -instance ToJSON UserUpdate where - toJSON u = - A.object $ - "name" A..= uupName u - # "picture" A..= uupPict u - # "assets" A..= uupAssets u - # "accent_id" A..= uupAccentId u - # [] +data UpdateProfileError + = DisplayNameManagedByScim + | ProfileNotFound + deriving (Generic) + deriving (AsUnion PutSelfErrorResponses) via GenericAsUnion PutSelfErrorResponses UpdateProfileError + +instance GSOP.Generic UpdateProfileError + +type PutSelfErrorResponses = '[NameManagedByScim, UserNotFound] + +type PutSelfResponses = PutSelfErrorResponses .++ '[RespondEmpty 200 "User updated"] -instance FromJSON UserUpdate where - parseJSON = A.withObject "UserUpdate" $ \o -> - UserUpdate - <$> o A..:? "name" - <*> o A..:? "picture" - <*> o A..:? "assets" - <*> o A..:? "accent_id" +instance (res ~ PutSelfResponses) => AsUnion res (Maybe UpdateProfileError) where + toUnion = maybeToUnion (toUnion @PutSelfErrorResponses) + fromUnion = maybeFromUnion (fromUnion @PutSelfErrorResponses) -- | The payload for setting or changing a password. data PasswordChange = PasswordChange @@ -869,47 +874,49 @@ data PasswordChange = PasswordChange } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform PasswordChange) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema PasswordChange) -modelChangePassword :: Doc.Model -modelChangePassword = Doc.defineModel "ChangePassword" $ do - Doc.description - "Data to change a password. The old password is required if \ - \a password already exists." - Doc.property "old_password" Doc.string' $ do - Doc.description "Old password" - Doc.optional - Doc.property "new_password" Doc.string' $ - Doc.description "New password (6 - 1024 characters)" - -instance ToJSON PasswordChange where - toJSON (PasswordChange old new) = - A.object - [ "old_password" A..= old, - "new_password" A..= new - ] - -instance FromJSON PasswordChange where - parseJSON = A.withObject "PasswordChange" $ \o -> - PasswordChange - <$> o A..:? "old_password" - <*> o A..: "new_password" +instance ToSchema PasswordChange where + schema = + over + doc + ( description + ?~ "Data to change a password. The old password is required if \ + \a password already exists." + ) + . object "PasswordChange" + $ PasswordChange + <$> cpOldPassword .= maybe_ (optField "old_password" schema) + <*> cpNewPassword .= field "new_password" schema + +data ChangePasswordError + = InvalidCurrentPassword + | ChangePasswordNoIdentity + | ChangePasswordMustDiffer + deriving (Generic) + deriving (AsUnion ChangePasswordErrorResponses) via GenericAsUnion ChangePasswordErrorResponses ChangePasswordError + +instance GSOP.Generic ChangePasswordError + +type ChangePasswordErrorResponses = [BadCredentials, NoIdentity, ChangePasswordMustDiffer] + +type ChangePasswordResponses = + ChangePasswordErrorResponses .++ '[RespondEmpty 200 "Password Changed"] + +instance (res ~ ChangePasswordResponses) => AsUnion res (Maybe ChangePasswordError) where + toUnion = maybeToUnion (toUnion @ChangePasswordErrorResponses) + fromUnion = maybeFromUnion (fromUnion @ChangePasswordErrorResponses) newtype LocaleUpdate = LocaleUpdate {luLocale :: Locale} deriving stock (Eq, Show, Generic) deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LocaleUpdate) -modelChangeLocale :: Doc.Model -modelChangeLocale = Doc.defineModel "ChangeLocale" $ do - Doc.description "Data to change a locale." - Doc.property "locale" Doc.string' $ - Doc.description "Locale to be set" - -instance ToJSON LocaleUpdate where - toJSON l = A.object ["locale" A..= luLocale l] - -instance FromJSON LocaleUpdate where - parseJSON = A.withObject "locale-update" $ \o -> - LocaleUpdate <$> o A..: "locale" +instance ToSchema LocaleUpdate where + schema = + object "LocaleUpdate" $ + LocaleUpdate + <$> luLocale .= field "locale" schema newtype EmailUpdate = EmailUpdate {euEmail :: Email} deriving stock (Eq, Show, Generic) @@ -938,36 +945,78 @@ instance FromJSON EmailUpdate where newtype PhoneUpdate = PhoneUpdate {puPhone :: Phone} deriving stock (Eq, Show, Generic) deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via Schema PhoneUpdate -modelPhoneUpdate :: Doc.Model -modelPhoneUpdate = Doc.defineModel "PhoneUpdate" $ do - Doc.description "Phone Update Data" - Doc.property "phone" Doc.string' $ - Doc.description "E.164 phone number" +instance ToSchema PhoneUpdate where + schema = + object "PhoneUpdate" $ + PhoneUpdate + <$> puPhone .= field "phone" schema + +data ChangePhoneError + = PhoneExists + | InvalidNewPhone + | BlacklistedNewPhone + deriving (Generic) + deriving (AsUnion ChangePhoneErrorResponses) via GenericAsUnion ChangePhoneErrorResponses ChangePhoneError + +instance GSOP.Generic ChangePhoneError + +type ChangePhoneErrorResponses = [UserKeyExists, InvalidPhone, BlacklistedPhone] -instance ToJSON PhoneUpdate where - toJSON p = A.object ["phone" A..= puPhone p] +type ChangePhoneResponses = + ChangePhoneErrorResponses .++ '[RespondEmpty 202 "Phone updated"] -instance FromJSON PhoneUpdate where - parseJSON = A.withObject "phone-update" $ \o -> - PhoneUpdate <$> o A..: "phone" +instance (res ~ ChangePhoneResponses) => AsUnion res (Maybe ChangePhoneError) where + toUnion = maybeToUnion (toUnion @ChangePhoneErrorResponses) + fromUnion = maybeFromUnion (fromUnion @ChangePhoneErrorResponses) + +data RemoveIdentityError + = LastIdentity + | NoPassword + | NoIdentity + deriving (Generic) + deriving (AsUnion RemoveIdentityErrorResponses) via GenericAsUnion RemoveIdentityErrorResponses RemoveIdentityError + +instance GSOP.Generic RemoveIdentityError + +type RemoveIdentityErrorResponses = [LastIdentity, NoPassword, NoIdentity] + +type RemoveIdentityResponses = + RemoveIdentityErrorResponses .++ '[RespondEmpty 200 "Identity Removed"] + +instance (res ~ RemoveIdentityResponses) => AsUnion res (Maybe RemoveIdentityError) where + toUnion = maybeToUnion (toUnion @RemoveIdentityErrorResponses) + fromUnion = maybeFromUnion (fromUnion @RemoveIdentityErrorResponses) newtype HandleUpdate = HandleUpdate {huHandle :: Text} deriving stock (Eq, Show, Generic) deriving newtype (Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema HandleUpdate) + +instance ToSchema HandleUpdate where + schema = + object "HandleUpdate" $ + HandleUpdate <$> huHandle .= field "handle" schema + +data ChangeHandleError + = ChangeHandleNoIdentity + | ChangeHandleExists + | ChangeHandleInvalid + | ChangeHandleManagedByScim + deriving (Generic) + deriving (AsUnion ChangeHandleErrorResponses) via GenericAsUnion ChangeHandleErrorResponses ChangeHandleError + +instance GSOP.Generic ChangeHandleError -modelChangeHandle :: Doc.Model -modelChangeHandle = Doc.defineModel "ChangeHandle" $ do - Doc.description "Change the handle." - Doc.property "handle" Doc.string' $ - Doc.description "Handle to set" +type ChangeHandleErrorResponses = [NoIdentity, HandleExists, InvalidHandle, HandleManagedByScim] -instance ToJSON HandleUpdate where - toJSON h = A.object ["handle" A..= huHandle h] +type ChangeHandleResponses = + ChangeHandleErrorResponses .++ '[RespondEmpty 200 "Handle Changed"] -instance FromJSON HandleUpdate where - parseJSON = A.withObject "handle-update" $ \o -> - HandleUpdate <$> o A..: "handle" +instance (res ~ ChangeHandleResponses) => AsUnion res (Maybe ChangeHandleError) where + toUnion = maybeToUnion (toUnion @ChangeHandleErrorResponses) + fromUnion = maybeFromUnion (fromUnion @ChangeHandleErrorResponses) newtype NameUpdate = NameUpdate {nuHandle :: Text} deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index d9b819d9a38..07ca0f4bc93 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -50,7 +50,7 @@ module Wire.API.User.Identity where import Control.Applicative (optional) -import Control.Lens ((.~), (?~), (^.)) +import Control.Lens (over, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A @@ -242,13 +242,12 @@ validateEmail = newtype Phone = Phone {fromPhone :: Text} deriving stock (Eq, Ord, Show, Generic) - deriving newtype (ToJSON, S.ToSchema) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema Phone) -instance FromJSON Phone where - parseJSON (A.String s) = case parsePhone s of - Just p -> return p - Nothing -> fail "Invalid phone number. Expected E.164 format." - parseJSON _ = mempty +instance ToSchema Phone where + schema = + over doc (S.description ?~ "E.164 phone number") $ + fromPhone .= parsedText "PhoneNumber" (maybe (Left "Invalid phone number. Expected E.164 format.") Right . parsePhone) instance ToByteString Phone where builder = builder . fromPhone diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_1.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_1.json index efc8fa9efea..56d9750fae6 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_1.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_1.json @@ -1,4 +1,3 @@ { - "new_password": "\u0001f;0B+CKY󾃹W\u0005𫧻𐑹􇟚󽀰f\u0001&𨫳􀟘󹪊􊤍𣧚\tX𮥥\u001chl󹏂^A𥠮=𤻆\u0019_ow?\\h4𥼫𐬤\u0016⹋4O\u0015nJT\u0004r\u0018~\u0006\u0017R'󲏴sX󴤦mlCHvg􏥩ba󵂐R\\󼝬o󱢀􁹎*k\r)H𬂳􀧘\n#㠞~\\9Q|\u000b;\u001fd.􄙔0SHP%󸹆囇'!󾺴N\u001a!Kz@\u0000𒅟􉤛\u001aVp􌥏鞴\u00023#\u0014}}􋉝N𝙺`𩖂7󼽅\u0010𥱥^\u0002{`i:\rUT!\u0013􏚔𥏟\u0015WK\u0000􌋍􍅦eA𢚊\u0003𩿡󼣩t@?󷭺\u0001J􆔶7\u001eg{𓆲5R_\u0013u\u000f𥝛􈑉`}𐔔X\u0011𪱠D懷b𫋄6T𢨐𨳔p*7\n\\'\u000bO#\u001c𪫫(H\u0015n𫪢󷾡}2s𣀩8GA&󵏡\u0018􄱤d⍠\u001a􂤠t @􂀰I/𪻢痰\u00135烙c\u0004󿜉塂Uk\u0016\u0010􌕟8\u001d󼞚𗁬R-x󴇝󶁑󶏺\u0010O,Z\u0003􆌧f*\u000c^>\u0004D\r\u000f_AQPO33𗣃/F\u001e𭍙y𓀞|Fn󶬼E<󿩫9\u0003[y`e𩍈ｺL\u001a@4i/*󷂯􍋍⍮Ih\u000fC1󻴈\t%?kFt\u0006\u0010\u001f\u001dN𩰟\u000c􋆋:\u0007V\u0003j䙞\u0016\u0016𤨷\u0019K􈤚𧥃鸶Uez)􇹨\u001c)8vT;\u001d呭ay\u0003\u000f\u001d{C=\u0019,\u0001\u0003O𧰫\u0003&\u00012%<2s\u000c\u0016\r6ivo{󺿷WN􁓱R󽸖󻟱󳆅𘉋[ :\u001fu𬆺^f􉤮\u0018𡪧𬰥N\u000f𣝶\u0019@pK􇖌9\r@Ze𥐣f\u0012xM痽;j\u0016珥K_~:v&Dpx~_\u0002:b;bv\u0013=㧜6\u001aꄚ\u001by0Ho.B\"u*{󸪴Vw\u001aW𡰗𪞫rbY쬎I{q󾏞\u0005&_Pt𬪎'󠀷5\u000b𤵫谺觻Ue@YM𨌙)\n\u0019\u001dn\u0004Z\u000e\\\u000c`f3T+_\u001e@\u0007\u001e𭤦}", - "old_password": null + "new_password": "\u0001f;0B+CKY󾃹W\u0005𫧻𐑹􇟚󽀰f\u0001&𨫳􀟘󹪊􊤍𣧚\tX𮥥\u001chl󹏂^A𥠮=𤻆\u0019_ow?\\h4𥼫𐬤\u0016⹋4O\u0015nJT\u0004r\u0018~\u0006\u0017R'󲏴sX󴤦mlCHvg􏥩ba󵂐R\\󼝬o󱢀􁹎*k\r)H𬂳􀧘\n#㠞~\\9Q|\u000b;\u001fd.􄙔0SHP%󸹆囇'!󾺴N\u001a!Kz@\u0000𒅟􉤛\u001aVp􌥏鞴\u00023#\u0014}}􋉝N𝙺`𩖂7󼽅\u0010𥱥^\u0002{`i:\rUT!\u0013􏚔𥏟\u0015WK\u0000􌋍􍅦eA𢚊\u0003𩿡󼣩t@?󷭺\u0001J􆔶7\u001eg{𓆲5R_\u0013u\u000f𥝛􈑉`}𐔔X\u0011𪱠D懷b𫋄6T𢨐𨳔p*7\n\\'\u000bO#\u001c𪫫(H\u0015n𫪢󷾡}2s𣀩8GA&󵏡\u0018􄱤d⍠\u001a􂤠t @􂀰I/𪻢痰\u00135烙c\u0004󿜉塂Uk\u0016\u0010􌕟8\u001d󼞚𗁬R-x󴇝󶁑󶏺\u0010O,Z\u0003􆌧f*\u000c^>\u0004D\r\u000f_AQPO33𗣃/F\u001e𭍙y𓀞|Fn󶬼E<󿩫9\u0003[y`e𩍈ｺL\u001a@4i/*󷂯􍋍⍮Ih\u000fC1󻴈\t%?kFt\u0006\u0010\u001f\u001dN𩰟\u000c􋆋:\u0007V\u0003j䙞\u0016\u0016𤨷\u0019K􈤚𧥃鸶Uez)􇹨\u001c)8vT;\u001d呭ay\u0003\u000f\u001d{C=\u0019,\u0001\u0003O𧰫\u0003&\u00012%<2s\u000c\u0016\r6ivo{󺿷WN􁓱R󽸖󻟱󳆅𘉋[ :\u001fu𬆺^f􉤮\u0018𡪧𬰥N\u000f𣝶\u0019@pK􇖌9\r@Ze𥐣f\u0012xM痽;j\u0016珥K_~:v&Dpx~_\u0002:b;bv\u0013=㧜6\u001aꄚ\u001by0Ho.B\"u*{󸪴Vw\u001aW𡰗𪞫rbY쬎I{q󾏞\u0005&_Pt𬪎'󠀷5\u000b𤵫谺觻Ue@YM𨌙)\n\u0019\u001dn\u0004Z\u000e\\\u000c`f3T+_\u001e@\u0007\u001e𭤦}" } diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_13.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_13.json index 7ce0b18e5f7..03878d7165d 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_13.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_13.json @@ -1,4 +1,3 @@ { - "new_password": "\tY6b􅟘\u0018J0\u001e\u0013\u000cg]Ⅼ^\u0012󻏡S<\u0003n\u0010𧔞\u0000󶜅\"\u0000𠾿\u000fU󻄡K;la\u000e𠜻`쎩$0#䷉\u000c~\u001e􀙓kyBx\u0007\u0005<bY%􎆪{𣖓\u0005󵪒\u001a\n􏛶=􈊯\nl󺱶쌴\t:Z\\덧7,\u0017\\󾱀󽼁m^\u0005+\u0003epC\u0018VO2:!𦂲\n\u00186g}􌪂q6􁵋6<𩺐\u0001%yP𪳿\u0002\u0006o𫵞g􅨘p󵮋T󸬔\u0005\u000e0'F#^IVd\n𦗔𢞫A,@􁊙C-𬒓g``𨤳\u0000ṹ􀎏𡱼5}q쑜\u0016􉿉𠴦u(P芷\u000eP뤘e\n\u0011𨃁6􈤲\u0016M𩂹7󺻩\u00149󽭑O9 ,Op󰂺UR\u0013\u0000뮽􀔭>(󺙦\u0019_Nn8\u001cb𖩅r[p􏹻za1\u0012w\u0011慧\u001a𩛅\u001c_\u0018\u0004N6Vyi&)󷋢^𡈴\u0004\u0018ꂦBuJ\u0012`𓈢)qq^@$*\u0016𝅘𝅥𝅮P\u000bể\u0006g𠸹Mg}\u001b\u0019󲤜󼾦w󰍴-e窓p&\u000ed󹭘𒄔a㮰󽼋􁸞\u001e𢾀􁵈'E𬌖𗽈9\u0014\u0014A$𬆴h/A`\u0011l]3Qv㧗MR3W\u001csn] a\u0000:3`𗐴{`罕\n\u001f\u0012.𪂺:?y`\u0014􈼒_%S𥻲:\u0000𩷛\u0019k\"\u000cWYu8-jr)¸?D〴c􎘍􋲹􉽙^x\u0001{b3Sl:&0xgT321𬄏FU􄵹N􏽊P*L𣣿ﱔi:뻜\u0016𨏇0#\u0006뺗0v􀐍n\u000e𦴧P:", - "old_password": null + "new_password": "\tY6b􅟘\u0018J0\u001e\u0013\u000cg]Ⅼ^\u0012󻏡S<\u0003n\u0010𧔞\u0000󶜅\"\u0000𠾿\u000fU󻄡K;la\u000e𠜻`쎩$0#䷉\u000c~\u001e􀙓kyBx\u0007\u0005<bY%􎆪{𣖓\u0005󵪒\u001a\n􏛶=􈊯\nl󺱶쌴\t:Z\\덧7,\u0017\\󾱀󽼁m^\u0005+\u0003epC\u0018VO2:!𦂲\n\u00186g}􌪂q6􁵋6<𩺐\u0001%yP𪳿\u0002\u0006o𫵞g􅨘p󵮋T󸬔\u0005\u000e0'F#^IVd\n𦗔𢞫A,@􁊙C-𬒓g``𨤳\u0000ṹ􀎏𡱼5}q쑜\u0016􉿉𠴦u(P芷\u000eP뤘e\n\u0011𨃁6􈤲\u0016M𩂹7󺻩\u00149󽭑O9 ,Op󰂺UR\u0013\u0000뮽􀔭>(󺙦\u0019_Nn8\u001cb𖩅r[p􏹻za1\u0012w\u0011慧\u001a𩛅\u001c_\u0018\u0004N6Vyi&)󷋢^𡈴\u0004\u0018ꂦBuJ\u0012`𓈢)qq^@$*\u0016𝅘𝅥𝅮P\u000bể\u0006g𠸹Mg}\u001b\u0019󲤜󼾦w󰍴-e窓p&\u000ed󹭘𒄔a㮰󽼋􁸞\u001e𢾀􁵈'E𬌖𗽈9\u0014\u0014A$𬆴h/A`\u0011l]3Qv㧗MR3W\u001csn] a\u0000:3`𗐴{`罕\n\u001f\u0012.𪂺:?y`\u0014􈼒_%S𥻲:\u0000𩷛\u0019k\"\u000cWYu8-jr)¸?D〴c􎘍􋲹􉽙^x\u0001{b3Sl:&0xgT321𬄏FU􄵹N􏽊P*L𣣿ﱔi:뻜\u0016𨏇0#\u0006뺗0v􀐍n\u000e𦴧P:" } diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_14.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_14.json index 9ecfcc28252..1685f45fe13 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_14.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_14.json @@ -1,4 +1,3 @@ { - "new_password": "6go<􂵨fꃽY􈳇*KE󽤥])9󻆯􊕞K।􄉎1𘗢>qb2`\u00157*al\u000b3I*𦒁\u000e􊉪\u000c}\u0010𢁞~🩏@jjd\u0001O\u001a\u0001𗌗lv䃂B\u00083􄔙?Ih1bv\u000b\u001az\u0001\u001c😈0.\u0005b윮\u001cR<􏒫\u0004\u0011l\"E𞡊X6\u0015S󷂒?\u001b\u0004EKÒh팥䄰\u000c6󠁸>\u000b_Zd n<\u0012k􉖈s􅌻~\u0001󶹅\u0018r\u0010G󳶒\u0000`.)lj\u0010Rr/𤞸\\𫈘󴆴𭵝𗨦kI󾁓9\\.!\u0002pj&X?=r􅸤A5𩚏䤜\u0000ex`\u0001{ 𝩌\u0003󳽯^𘊏D􀩬𧵼𠐲m裠61JU\u0000tn@pCF3\u000cM𥸢ZrHM󺉄i𡔰zhn󶧼󰂧\u0005\u001b\u000b\u001f\u0003􇓚󺹼\u0014lU\u001d⥴[\u0011B\u0004 Y𧰏&cnLev俏awe\n𪵑+O𑀎N󽱴󰻦=x[7\"B\u001e\u0013\u0011\u0008Qy\u0010Nq~􌩔G*󾈲C𮨹Ho[𗜷9'󸤖6𭡑e#\u0017K샥W\u000e􎡥&kH7MQ\u0003\u0019,v2\u0001N/󾹍\tO𩑥\u000e󶩐b𭒦􈂫𤐕q󽖍􊙲ww}=$D\u0003w\u0010b􅀦\u0019~𢱜T\u001b\u0018𒑅Y~{\u000c{p𡱱*w􃑶Juo\n0𤵺sYXHT\u001fK\u0007󶡄\u0005\n%q iF𗙾\u001b\u001d.c\u001d󷪉􄞵\u001fW\u0019%x󵄢\u0015>\u0013􂟈", - "old_password": null + "new_password": "6go<􂵨fꃽY􈳇*KE󽤥])9󻆯􊕞K।􄉎1𘗢>qb2`\u00157*al\u000b3I*𦒁\u000e􊉪\u000c}\u0010𢁞~🩏@jjd\u0001O\u001a\u0001𗌗lv䃂B\u00083􄔙?Ih1bv\u000b\u001az\u0001\u001c😈0.\u0005b윮\u001cR<􏒫\u0004\u0011l\"E𞡊X6\u0015S󷂒?\u001b\u0004EKÒh팥䄰\u000c6󠁸>\u000b_Zd n<\u0012k􉖈s􅌻~\u0001󶹅\u0018r\u0010G󳶒\u0000`.)lj\u0010Rr/𤞸\\𫈘󴆴𭵝𗨦kI󾁓9\\.!\u0002pj&X?=r􅸤A5𩚏䤜\u0000ex`\u0001{ 𝩌\u0003󳽯^𘊏D􀩬𧵼𠐲m裠61JU\u0000tn@pCF3\u000cM𥸢ZrHM󺉄i𡔰zhn󶧼󰂧\u0005\u001b\u000b\u001f\u0003􇓚󺹼\u0014lU\u001d⥴[\u0011B\u0004 Y𧰏&cnLev俏awe\n𪵑+O𑀎N󽱴󰻦=x[7\"B\u001e\u0013\u0011\u0008Qy\u0010Nq~􌩔G*󾈲C𮨹Ho[𗜷9'󸤖6𭡑e#\u0017K샥W\u000e􎡥&kH7MQ\u0003\u0019,v2\u0001N/󾹍\tO𩑥\u000e󶩐b𭒦􈂫𤐕q󽖍􊙲ww}=$D\u0003w\u0010b􅀦\u0019~𢱜T\u001b\u0018𒑅Y~{\u000c{p𡱱*w􃑶Juo\n0𤵺sYXHT\u001fK\u0007󶡄\u0005\n%q iF𗙾\u001b\u001d.c\u001d󷪉􄞵\u001fW\u0019%x󵄢\u0015>\u0013􂟈" } diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_17.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_17.json index 079dbd79a9e..8dc1a26d5bb 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_17.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_17.json @@ -1,4 +1,3 @@ { - "new_password": "󿞫X2cZf\tI\u0010.3樑ꊩ󱊝\u000e𨳮糽𦡈U峖𦿤\u0012󲪍xy􍘒DB􋣨\u001fP!≈3뒗\u000c㤈.1󹇚󾭏ji𡆁C𗍮䉇酖䪛\u001f\u0000~BYB\u001eUYc\u0003􊘨e🈨𭱐ᄻ\"cN&\t.9􌉽?\u001d^\u000b\u0001\u0008\u0018ꊛ&㔋􎭙a󷪠)z6Z𫴦􊱴\u001bX\u000f㗿xJ\u0016֔\u0019-\u0011I\nB=󾉏n!l𠆗~U􅅖;𛰔X𭱩\u0004𦹁󹷹uY鴇z􁚺D󹃹\u000cFbZtt\u0018:\u0018YQ\u0001h󵬙W􏄺\u0010𩌧!1}k\\􁭿z+\u0015􎉯\u0001􋇸%䑂?v􎡃h\u000cN\u000c\u0012\u0000\u001a𮒗󳏵P\u001dbP􎜘>ie􌫲Ỵi𩃮-癈]4i-\u0002/\u001dA\u0008&\u000b󾶽<􍍵􎋯M\\󲇎-pG\u001c𩕵\u0010HEJO\u0007|\t(⏹D=x<\u0017 aV󷏱O󳺅n|mdg󾯸@􏌿f\u0007󺒝W𮨌䵨\u0010h𨯽􊨀\u0017~⦜K~􅴪\u001b|\rdi\u001dﱽ𗈵􇾁;󺩗8e^𢬼T/D\u001f\u0015󰌧hTTe|N8􇅇1􊮋tJR\u0007𥺘iJ2󳩶}赛瀩扱\u000e􎱴0ુ!y\u00011W\u001fzX\u00010󲄬s𝒳h𓊖𡈵#􆒳𡯮SR󱖟,V𬃧v\u0015𨑊1g\u001a\u001b𗶱􇻦\u0002Q):\u001f/E'𠆔\u0010z!\u000e@󹋾Hy5*R󶩿\u001a󱳖󾼹󷬼􃰇𫢬􃒛`솖\u0012.M􏺪W𩴰\u0006󺋆Imf#dHF\u0017c娛\u0013QcG􅝄B\u0000W<\u001eC􂭸󱔉󹡃L7", - "old_password": null + "new_password": "󿞫X2cZf\tI\u0010.3樑ꊩ󱊝\u000e𨳮糽𦡈U峖𦿤\u0012󲪍xy􍘒DB􋣨\u001fP!≈3뒗\u000c㤈.1󹇚󾭏ji𡆁C𗍮䉇酖䪛\u001f\u0000~BYB\u001eUYc\u0003􊘨e🈨𭱐ᄻ\"cN&\t.9􌉽?\u001d^\u000b\u0001\u0008\u0018ꊛ&㔋􎭙a󷪠)z6Z𫴦􊱴\u001bX\u000f㗿xJ\u0016֔\u0019-\u0011I\nB=󾉏n!l𠆗~U􅅖;𛰔X𭱩\u0004𦹁󹷹uY鴇z􁚺D󹃹\u000cFbZtt\u0018:\u0018YQ\u0001h󵬙W􏄺\u0010𩌧!1}k\\􁭿z+\u0015􎉯\u0001􋇸%䑂?v􎡃h\u000cN\u000c\u0012\u0000\u001a𮒗󳏵P\u001dbP􎜘>ie􌫲Ỵi𩃮-癈]4i-\u0002/\u001dA\u0008&\u000b󾶽<􍍵􎋯M\\󲇎-pG\u001c𩕵\u0010HEJO\u0007|\t(⏹D=x<\u0017 aV󷏱O󳺅n|mdg󾯸@􏌿f\u0007󺒝W𮨌䵨\u0010h𨯽􊨀\u0017~⦜K~􅴪\u001b|\rdi\u001dﱽ𗈵􇾁;󺩗8e^𢬼T/D\u001f\u0015󰌧hTTe|N8􇅇1􊮋tJR\u0007𥺘iJ2󳩶}赛瀩扱\u000e􎱴0ુ!y\u00011W\u001fzX\u00010󲄬s𝒳h𓊖𡈵#􆒳𡯮SR󱖟,V𬃧v\u0015𨑊1g\u001a\u001b𗶱􇻦\u0002Q):\u001f/E'𠆔\u0010z!\u000e@󹋾Hy5*R󶩿\u001a󱳖󾼹󷬼􃰇𫢬􃒛`솖\u0012.M􏺪W𩴰\u0006󺋆Imf#dHF\u0017c娛\u0013QcG􅝄B\u0000W<\u001eC􂭸󱔉󹡃L7" } diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_18.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_18.json index 9b87cd015c1..52c7a9d4b59 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_18.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_18.json @@ -1,4 +1,3 @@ { - "new_password": "$󾮝izIhＫE𥋌b\u000ci𨒼v=:\t9󻗨\r⣴!􀲃:󴽌&/#􊛋G𭿷$W󱲯>\u0019Do`F\nY\u0019L\u0004\t\u00005󳒈bC8ᑱBq󸢵$p\u0000\u000b┆R^\u0016GF&󷅀+]𦐧]壢鞈;:𠉵𦄍w􄉷\u0015\u0014\u0016􂾥󷺴gi\u000f\"\u000bqᢹvV󾃑\u0010Yya􍍕};,K3\u0010n\u0003\u0006\u0012+𭅵𢭯\u000e^q\u00134+Iby-\u0005􁎦𧮉_", - "old_password": null + "new_password": "$󾮝izIhＫE𥋌b\u000ci𨒼v=:\t9󻗨\r⣴!􀲃:󴽌&/#􊛋G𭿷$W󱲯>\u0019Do`F\nY\u0019L\u0004\t\u00005󳒈bC8ᑱBq󸢵$p\u0000\u000b┆R^\u0016GF&󷅀+]𦐧]壢鞈;:𠉵𦄍w􄉷\u0015\u0014\u0016􂾥󷺴gi\u000f\"\u000bqᢹvV󾃑\u0010Yya􍍕};,K3\u0010n\u0003\u0006\u0012+𭅵𢭯\u000e^q\u00134+Iby-\u0005􁎦𧮉_" } diff --git a/libs/wire-api/test/golden/testObject_PasswordChange_user_7.json b/libs/wire-api/test/golden/testObject_PasswordChange_user_7.json index aeb51f98f69..19fe98e5026 100644 --- a/libs/wire-api/test/golden/testObject_PasswordChange_user_7.json +++ b/libs/wire-api/test/golden/testObject_PasswordChange_user_7.json @@ -1,4 +1,3 @@ { - "new_password": "􇎃7ﻂ\u001eA󴇌k\u000b\u001b\u0015g&:\u00006K\u0000n>\u001a𝒦$\u001b8B'z\"Yc󻾅6\u001bU)\u0000\u0010􌵬Zj굡𔓻bJ-\u001f\"𠋜L\u0007􄫓y\u0010s-}𢨂}\u001d\u0018\u0006\rR}R\u0018L\u001cqkZ\n\t𮉈1|\u000c5󰏵L\u00178gL䝴5⨓cf\\V~\u0011Ⲕ\u0019𝠁󱮄1n\"*\u0017\u000faTxUcZ\r#5/\u0008k\u000b[\u0007`􎉒\u0000R;(\u0018\rFMN>󳆴\u001bt\u0006{'(𢣤\u0003\u0000T􂄷m\u000c6綠B\n󱋢", - "old_password": null + "new_password": "􇎃7ﻂ\u001eA󴇌k\u000b\u001b\u0015g&:\u00006K\u0000n>\u001a𝒦$\u001b8B'z\"Yc󻾅6\u001bU)\u0000\u0010􌵬Zj굡𔓻bJ-\u001f\"𠋜L\u0007􄫓y\u0010s-}𢨂}\u001d\u0018\u0006\rR}R\u0018L\u001cqkZ\n\t𮉈1|\u000c5󰏵L\u00178gL䝴5⨓cf\\V~\u0011Ⲕ\u0019𝠁󱮄1n\"*\u0017\u000faTxUcZ\r#5/\u0008k\u000b[\u0007`􎉒\u0000R;(\u0018\rFMN>󳆴\u001bt\u0006{'(𢣤\u0003\u0000T􂄷m\u000c6綠B\n󱋢" } diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index c26cfc4b431..dba6070fb59 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -161,6 +161,7 @@ library , currency-codes >=2.0 , deriving-aeson >=0.2 , deriving-swagger2 + , either , email-validate >=2.0 , errors , extended diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 58d92463152..b5830fe6657 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -39,6 +39,7 @@ import qualified Network.Wai.Utilities.Error as Wai import Servant.API.Status import Wire.API.ErrorDescription import Wire.API.Federation.Error +import Wire.API.User (ChangeHandleError (..), UpdateProfileError (..)) errorDescriptionToWai :: forall (code :: Nat) (lbl :: Symbol) (desc :: Symbol). @@ -110,18 +111,18 @@ connError InvalidTransition {} = StdError (errorDescriptionTypeToWai @InvalidTra connError NotConnected {} = StdError (errorDescriptionTypeToWai @NotConnected) connError InvalidUser {} = StdError (errorDescriptionTypeToWai @InvalidUser) connError ConnectNoIdentity {} = StdError (errorDescriptionToWai (noIdentity 0)) -connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const blacklistedPhone) k +connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k connError (ConnectInvalidEmail _ _) = StdError invalidEmail -connError ConnectInvalidPhone {} = StdError invalidPhone +connError ConnectInvalidPhone {} = StdError (errorDescriptionTypeToWai @InvalidPhone) connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers connError ConnectMissingLegalholdConsent = StdError (errorDescriptionTypeToWai @MissingLegalholdConsent) connError (ConnectFederationError e) = fedError e actError :: ActivationError -> Error -actError (UserKeyExists _) = StdError userKeyExists +actError (UserKeyExists _) = StdError (errorDescriptionTypeToWai @UserKeyExists) actError (InvalidActivationCode e) = StdError (invalidActivationCode e) actError (InvalidActivationEmail _ _) = StdError invalidEmail -actError (InvalidActivationPhone _) = StdError invalidPhone +actError (InvalidActivationPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) pwResetError :: PasswordResetError -> Error pwResetError InvalidPasswordResetKey = StdError invalidPwResetKey @@ -138,45 +139,35 @@ newUserError :: CreateUserError -> Error newUserError InvalidInvitationCode = StdError invalidInvitationCode newUserError MissingIdentity = StdError missingIdentity newUserError (InvalidEmail _ _) = StdError invalidEmail -newUserError (InvalidPhone _) = StdError invalidPhone -newUserError (DuplicateUserKey _) = StdError userKeyExists +newUserError (InvalidPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) +newUserError (DuplicateUserKey _) = StdError (errorDescriptionTypeToWai @UserKeyExists) newUserError (EmailActivationError e) = actError e newUserError (PhoneActivationError e) = actError e -newUserError (BlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const blacklistedPhone) k +newUserError (BlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k newUserError TooManyTeamMembers = StdError tooManyTeamMembers newUserError UserCreationRestricted = StdError userCreationRestricted newUserError (ExternalPreconditionFailed e) = StdError e sendLoginCodeError :: SendLoginCodeError -> Error -sendLoginCodeError (SendLoginInvalidPhone _) = StdError invalidPhone +sendLoginCodeError (SendLoginInvalidPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) sendLoginCodeError SendLoginPasswordExists = StdError passwordExists sendActCodeError :: SendActivationCodeError -> Error -sendActCodeError (InvalidRecipient k) = StdError $ foldKey (const invalidEmail) (const invalidPhone) k -sendActCodeError (UserKeyInUse _) = StdError userKeyExists -sendActCodeError (ActivationBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const blacklistedPhone) k +sendActCodeError (InvalidRecipient k) = StdError $ foldKey (const invalidEmail) (const (errorDescriptionTypeToWai @InvalidPhone)) k +sendActCodeError (UserKeyInUse _) = StdError (errorDescriptionTypeToWai @UserKeyExists) +sendActCodeError (ActivationBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k changeEmailError :: ChangeEmailError -> Error changeEmailError (InvalidNewEmail _ _) = StdError invalidEmail -changeEmailError (EmailExists _) = StdError userKeyExists +changeEmailError (EmailExists _) = StdError (errorDescriptionTypeToWai @UserKeyExists) changeEmailError (ChangeBlacklistedEmail _) = StdError blacklistedEmail changeEmailError EmailManagedByScim = StdError $ propertyManagedByScim "email" -changePhoneError :: ChangePhoneError -> Error -changePhoneError (InvalidNewPhone _) = StdError invalidPhone -changePhoneError (PhoneExists _) = StdError userKeyExists -changePhoneError (BlacklistedNewPhone _) = StdError blacklistedPhone - -changePwError :: ChangePasswordError -> Error -changePwError InvalidCurrentPassword = StdError (errorDescriptionTypeToWai @BadCredentials) -changePwError ChangePasswordNoIdentity = StdError (errorDescriptionToWai (noIdentity 1)) -changePwError ChangePasswordMustDiffer = StdError changePasswordMustDiffer - changeHandleError :: ChangeHandleError -> Error changeHandleError ChangeHandleNoIdentity = StdError (errorDescriptionToWai (noIdentity 2)) -changeHandleError ChangeHandleExists = StdError handleExists -changeHandleError ChangeHandleInvalid = StdError invalidHandle -changeHandleError ChangeHandleManagedByScim = StdError $ propertyManagedByScim "handle" +changeHandleError ChangeHandleExists = StdError (errorDescriptionToWai (mkErrorDescription :: HandleExists)) +changeHandleError ChangeHandleInvalid = StdError (errorDescriptionToWai (mkErrorDescription :: InvalidHandle)) +changeHandleError ChangeHandleManagedByScim = StdError (errorDescriptionToWai (mkErrorDescription :: HandleManagedByScim)) legalHoldLoginError :: LegalHoldLoginError -> Error legalHoldLoginError LegalHoldLoginNoBindingTeam = StdError noBindingTeam @@ -230,11 +221,6 @@ clientError ClientMissingLegalholdConsent = StdError (errorDescriptionTypeToWai fedError :: FederationError -> Error fedError = StdError . federationErrorToWai -idtError :: RemoveIdentityError -> Error -idtError LastIdentity = StdError lastIdentity -idtError NoPassword = StdError noPassword -idtError NoIdentity = StdError (errorDescriptionToWai (noIdentity 3)) - propDataError :: PropertiesDataError -> Error propDataError TooManyProperties = StdError tooManyProperties @@ -256,13 +242,13 @@ accountStatusError :: AccountStatusError -> Error accountStatusError InvalidAccountStatus = StdError invalidAccountStatus phoneError :: PhoneException -> Error -phoneError PhoneNumberUnreachable = StdError invalidPhone -phoneError PhoneNumberBarred = StdError blacklistedPhone +phoneError PhoneNumberUnreachable = StdError (errorDescriptionTypeToWai @InvalidPhone) +phoneError PhoneNumberBarred = StdError (errorDescriptionTypeToWai @BlacklistedPhone) phoneError (PhoneBudgetExhausted t) = RichError phoneBudgetExhausted (PhoneBudgetTimeout t) [] updateProfileError :: UpdateProfileError -> Error updateProfileError DisplayNameManagedByScim = StdError (propertyManagedByScim "name") -updateProfileError (ProfileNotFound _) = StdError (errorDescriptionTypeToWai @UserNotFound) +updateProfileError ProfileNotFound = StdError (errorDescriptionTypeToWai @UserNotFound) -- WAI Errors ----------------------------------------------------------------- @@ -281,12 +267,6 @@ clientCapabilitiesCannotBeRemoved = Wai.mkError status409 "client-capabilities-c noEmail :: Wai.Error noEmail = Wai.mkError status403 "no-email" "This operation requires the user to have a verified email address." -lastIdentity :: Wai.Error -lastIdentity = Wai.mkError status403 "last-identity" "The last user identity (email or phone number) cannot be removed." - -noPassword :: Wai.Error -noPassword = Wai.mkError status403 "no-password" "The user has no password." - invalidEmail :: Wai.Error invalidEmail = Wai.mkError status400 "invalid-email" "Invalid e-mail address." @@ -296,12 +276,6 @@ invalidPwResetKey = Wai.mkError status400 "invalid-key" "Invalid email or mobile resetPasswordMustDiffer :: Wai.Error resetPasswordMustDiffer = Wai.mkError status409 "password-must-differ" "For password reset, new and old password must be different." -changePasswordMustDiffer :: Wai.Error -changePasswordMustDiffer = Wai.mkError status409 "password-must-differ" "For password change, new and old password must be different." - -invalidPhone :: Wai.Error -invalidPhone = Wai.mkError status400 "invalid-phone" "Invalid mobile phone number." - invalidInvitationCode :: Wai.Error invalidInvitationCode = Wai.mkError status400 "invalid-invitation-code" "Invalid invitation code." @@ -314,21 +288,12 @@ invalidPwResetCode = Wai.mkError status400 "invalid-code" "Invalid password rese duplicatePwResetCode :: Wai.Error duplicatePwResetCode = Wai.mkError status409 "code-exists" "A password reset is already in progress." -userKeyExists :: Wai.Error -userKeyExists = Wai.mkError status409 "key-exists" "The given e-mail address or phone number is in use." - emailExists :: Wai.Error emailExists = Wai.mkError status409 "email-exists" "The given e-mail address is in use." phoneExists :: Wai.Error phoneExists = Wai.mkError status409 "phone-exists" "The given phone number is in use." -handleExists :: Wai.Error -handleExists = Wai.mkError status409 "handle-exists" "The given handle is already taken." - -invalidHandle :: Wai.Error -invalidHandle = Wai.mkError status400 "invalid-handle" "The given handle is invalid." - badRequest :: LText -> Wai.Error badRequest = Wai.mkError status400 "bad-request" @@ -379,14 +344,6 @@ blacklistedEmail = "The given e-mail address has been blacklisted due to a permanent bounce \ \or a complaint." -blacklistedPhone :: Wai.Error -blacklistedPhone = - Wai.mkError - status403 - "blacklisted-phone" - "The given phone number has been blacklisted due to suspected abuse \ - \or a complaint." - passwordExists :: Wai.Error passwordExists = Wai.mkError @@ -416,9 +373,6 @@ authMissingToken = Wai.mkError status403 "invalid-credentials" "Missing token" authMissingCookieAndToken :: Wai.Error authMissingCookieAndToken = Wai.mkError status403 "invalid-credentials" "Missing cookie and token" -invalidUserToken :: Wai.Error -invalidUserToken = Wai.mkError status403 "invalid-credentials" "Invalid user token" - invalidAccessToken :: Wai.Error invalidAccessToken = Wai.mkError status403 "invalid-credentials" "Invalid access token" @@ -437,9 +391,6 @@ authTokenInvalid = Wai.mkError status403 "invalid-credentials" "Invalid token" authTokenUnsupported :: Wai.Error authTokenUnsupported = Wai.mkError status403 "invalid-credentials" "Unsupported token operation for this token type" -incorrectPermissions :: Wai.Error -incorrectPermissions = Wai.mkError status403 "invalid-permissions" "Copy permissions must be a subset of self permissions" - -- | User's relation to the team is not what we expect it to be. Examples: -- -- * Requested action requires the user to be a team member, but the user doesn't belong to diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 0f9e108ceb4..355e5ca1b9d 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -593,7 +593,7 @@ updateUserName uid (NameUpdate nameUpd) = do checkHandleInternalH :: Text -> Handler Response checkHandleInternalH = API.checkHandle >=> \case - API.CheckHandleInvalid -> throwE (StdError invalidHandle) + API.CheckHandleInvalid -> throwE (StdError (errorDescriptionTypeToWai @InvalidHandle)) API.CheckHandleFound -> pure $ setStatus status200 empty API.CheckHandleNotFound -> pure $ setStatus status404 empty diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d35ad9c5e8e..850705a433d 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -170,6 +170,14 @@ servantSitemap = BrigAPI.getUserQualified = getUser, BrigAPI.getSelf = getSelf, BrigAPI.deleteSelf = deleteUser, + BrigAPI.putSelf = updateUser, + BrigAPI.changePhone = changePhone, + BrigAPI.removePhone = removePhone, + BrigAPI.removeEmail = removeEmail, + BrigAPI.checkPasswordExists = checkPasswordExists, + BrigAPI.changePassword = changePassword, + BrigAPI.changeLocale = changeLocale, + BrigAPI.changeHandle = changeHandle, BrigAPI.updateUserEmail = updateUserEmail, BrigAPI.getHandleInfoUnqualified = getHandleInfoUnqualifiedH, BrigAPI.getUserByHandleQualified = Handle.getHandleInfo, @@ -235,7 +243,7 @@ sitemap = do Doc.parameter Doc.Path "handle" Doc.bytes' $ Doc.description "Handle to check" Doc.response 200 "Handle is taken" Doc.end - Doc.errorResponse invalidHandle + Doc.errorResponse (errorDescriptionTypeToWai @InvalidHandle) Doc.errorResponse (errorDescriptionTypeToWai @HandleNotFound) -- some APIs moved to servant @@ -255,18 +263,6 @@ sitemap = do -- User Self API ------------------------------------------------------ - -- This endpoint can lead to the following events being sent: - -- - UserUpdated event to contacts of self - put "/self" (continue updateUserH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.UserUpdate - document "PUT" "updateSelf" $ do - Doc.summary "Update your profile" - Doc.body (Doc.ref Public.modelUserUpdate) $ - Doc.description "JSON body" - Doc.response 200 "Update successful." Doc.end - get "/self/name" (continue getUserDisplayNameH) $ accept "application" "json" .&. zauthUserId @@ -275,88 +271,6 @@ sitemap = do Doc.returns (Doc.ref Public.modelUserDisplayName) Doc.response 200 "Profile name found." Doc.end - put "/self/phone" (continue changePhoneH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.PhoneUpdate - document "PUT" "changePhone" $ do - Doc.summary "Change your phone number" - Doc.body (Doc.ref Public.modelPhoneUpdate) $ - Doc.description "JSON body" - Doc.response 202 "Update accepted and pending activation of the new phone number." Doc.end - Doc.errorResponse userKeyExists - - head - "/self/password" - (continue checkPasswordExistsH) - zauthUserId - document "HEAD" "checkPassword" $ do - Doc.summary "Check that your password is set" - Doc.response 200 "Password is set." Doc.end - Doc.response 404 "Password is not set." Doc.end - - put "/self/password" (continue changePasswordH) $ - zauthUserId - .&. jsonRequest @Public.PasswordChange - document "PUT" "changePassword" $ do - Doc.summary "Change your password" - Doc.body (Doc.ref Public.modelChangePassword) $ - Doc.description "JSON body" - Doc.response 200 "Password changed." Doc.end - Doc.errorResponse (errorDescriptionTypeToWai @BadCredentials) - Doc.errorResponse (errorDescriptionToWai (noIdentity 4)) - - put "/self/locale" (continue changeLocaleH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.LocaleUpdate - document "PUT" "changeLocale" $ do - Doc.summary "Change your locale" - Doc.body (Doc.ref Public.modelChangeLocale) $ - Doc.description "JSON body" - Doc.response 200 "Locale changed." Doc.end - - -- This endpoint can lead to the following events being sent: - -- - UserUpdated event to contacts of self - put "/self/handle" (continue changeHandleH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.HandleUpdate - document "PUT" "changeHandle" $ do - Doc.summary "Change your handle" - Doc.body (Doc.ref Public.modelChangeHandle) $ - Doc.description "JSON body" - Doc.errorResponse handleExists - Doc.errorResponse invalidHandle - Doc.response 200 "Handle changed." Doc.end - - -- This endpoint can lead to the following events being sent: - -- - UserIdentityRemoved event to self - delete "/self/phone" (continue removePhoneH) $ - zauthUserId - .&. zauthConnId - document "DELETE" "removePhone" $ do - Doc.summary "Remove your phone number." - Doc.notes - "Your phone number can only be removed if you also have an \ - \email address and a password." - Doc.response 200 "Phone number removed." Doc.end - Doc.errorResponse lastIdentity - Doc.errorResponse noPassword - - -- This endpoint can lead to the following events being sent: - -- - UserIdentityRemoved event to self - delete "/self/email" (continue removeEmailH) $ - zauthUserId - .&. zauthConnId - document "DELETE" "removeEmail" $ do - Doc.summary "Remove your email address." - Doc.notes - "Your email address can only be removed if you also have a \ - \phone number." - Doc.response 200 "Email address removed." Doc.end - Doc.errorResponse lastIdentity - -- TODO put where? -- This endpoint can lead to the following events being sent: @@ -466,10 +380,10 @@ sitemap = do Doc.errorResponse whitelistError Doc.errorResponse invalidInvitationCode Doc.errorResponse missingIdentity - Doc.errorResponse userKeyExists + Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) Doc.errorResponse activationCodeNotFound Doc.errorResponse blacklistedEmail - Doc.errorResponse blacklistedPhone + Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) -- This endpoint can lead to the following events being sent: -- - UserActivated event to the user, if account gets activated @@ -518,10 +432,10 @@ sitemap = do Doc.description "JSON body" Doc.response 200 "Activation code sent." Doc.end Doc.errorResponse invalidEmail - Doc.errorResponse invalidPhone - Doc.errorResponse userKeyExists + Doc.errorResponse (errorDescriptionTypeToWai @InvalidPhone) + Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) Doc.errorResponse blacklistedEmail - Doc.errorResponse blacklistedPhone + Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) Doc.errorResponse (customerExtensionBlockedDomain (either undefined id $ mkDomain "example.com")) post "/password-reset" (continue beginPasswordResetH) $ @@ -894,56 +808,41 @@ newtype GetActivationCodeResp instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] -updateUserH :: UserId ::: ConnId ::: JsonRequest Public.UserUpdate -> Handler Response -updateUserH (uid ::: conn ::: req) = do - uu <- parseJsonBody req - API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates !>> updateProfileError - return empty - -changePhoneH :: UserId ::: ConnId ::: JsonRequest Public.PhoneUpdate -> Handler Response -changePhoneH (u ::: c ::: req) = - setStatus status202 empty <$ (changePhone u c =<< parseJsonBody req) +updateUser :: UserId -> ConnId -> Public.UserUpdate -> Handler (Maybe Public.UpdateProfileError) +updateUser uid conn uu = do + eithErr <- lift $ runExceptT $ API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates + pure $ either Just (const Nothing) eithErr -changePhone :: UserId -> ConnId -> Public.PhoneUpdate -> Handler () -changePhone u _ (Public.puPhone -> phone) = do - (adata, pn) <- API.changePhone u phone !>> changePhoneError +changePhone :: UserId -> ConnId -> Public.PhoneUpdate -> Handler (Maybe Public.ChangePhoneError) +changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do + (adata, pn) <- API.changePhone u phone loc <- lift $ API.lookupLocale u let apair = (activationKey adata, activationCode adata) lift $ sendActivationSms pn apair loc -removePhoneH :: UserId ::: ConnId -> Handler Response -removePhoneH (self ::: conn) = do - API.removePhone self conn !>> idtError - return empty +removePhone :: UserId -> ConnId -> Handler (Maybe Public.RemoveIdentityError) +removePhone self conn = + lift . exceptTToMaybe $ API.removePhone self conn -removeEmailH :: UserId ::: ConnId -> Handler Response -removeEmailH (self ::: conn) = do - API.removeEmail self conn !>> idtError - return empty +removeEmail :: UserId -> ConnId -> Handler (Maybe Public.RemoveIdentityError) +removeEmail self conn = + lift . exceptTToMaybe $ API.removeEmail self conn -checkPasswordExistsH :: UserId -> Handler Response -checkPasswordExistsH self = do - exists <- lift $ isJust <$> API.lookupPassword self - return $ if exists then empty else setStatus status404 empty +checkPasswordExists :: UserId -> Handler Bool +checkPasswordExists = fmap isJust . lift . API.lookupPassword -changePasswordH :: UserId ::: JsonRequest Public.PasswordChange -> Handler Response -changePasswordH (u ::: req) = do - cp <- parseJsonBody req - API.changePassword u cp !>> changePwError - return empty +changePassword :: UserId -> Public.PasswordChange -> Handler (Maybe Public.ChangePasswordError) +changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp -changeLocaleH :: UserId ::: ConnId ::: JsonRequest Public.LocaleUpdate -> Handler Response -changeLocaleH (u ::: conn ::: req) = do - l <- parseJsonBody req - lift $ API.changeLocale u conn l - return empty +changeLocale :: UserId -> ConnId -> Public.LocaleUpdate -> Handler () +changeLocale u conn l = lift $ API.changeLocale u conn l -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) checkHandleH :: UserId ::: Text -> Handler Response checkHandleH (_uid ::: hndl) = API.checkHandle hndl >>= \case - API.CheckHandleInvalid -> throwE (StdError invalidHandle) + API.CheckHandleInvalid -> throwE (StdError (errorDescriptionTypeToWai @InvalidHandle)) API.CheckHandleFound -> pure $ setStatus status200 empty API.CheckHandleNotFound -> pure $ setStatus status404 empty @@ -964,15 +863,10 @@ getHandleInfoUnqualifiedH self handle = do Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandleH :: UserId ::: ConnId ::: JsonRequest Public.HandleUpdate -> Handler Response -changeHandleH (u ::: conn ::: req) = - empty <$ (changeHandle u conn =<< parseJsonBody req) - -changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> Handler () -changeHandle u conn (Public.HandleUpdate h) = do - handle <- API.validateHandle h - -- TODO check here - API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates !>> changeHandleError +changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> Handler (Maybe Public.ChangeHandleError) +changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do + handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h + API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates beginPasswordResetH :: JSON ::: JsonRequest Public.NewPasswordReset -> Handler Response beginPasswordResetH (_ ::: req) = diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 8d9359d29d4..663411d7937 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -101,10 +101,6 @@ data CreateUserError | -- | Some precondition on another Wire service failed. We propagate this error. ExternalPreconditionFailed Wai.Error -data UpdateProfileError - = DisplayNameManagedByScim - | ProfileNotFound UserId - data InvitationError = InviteeEmailExists UserId | InviteInvalidEmail Email @@ -156,28 +152,12 @@ data LoginError | LoginThrottled RetryAfter | LoginBlocked RetryAfter -data ChangePasswordError - = InvalidCurrentPassword - | ChangePasswordNoIdentity - | ChangePasswordMustDiffer - -data ChangePhoneError - = PhoneExists !Phone - | InvalidNewPhone !Phone - | BlacklistedNewPhone !Phone - data ChangeEmailError = InvalidNewEmail !Email !String | EmailExists !Email | ChangeBlacklistedEmail !Email | EmailManagedByScim -data ChangeHandleError - = ChangeHandleNoIdentity - | ChangeHandleExists - | ChangeHandleInvalid - | ChangeHandleManagedByScim - data SendActivationCodeError = InvalidRecipient UserKey | UserKeyInUse UserKey @@ -197,11 +177,6 @@ data ClientError | ClientCapabilitiesCannotBeRemoved | ClientMissingLegalholdConsent -data RemoveIdentityError - = LastIdentity - | NoPassword - | NoIdentity - data DeleteUserError = DeleteUserInvalid | DeleteUserInvalidCode diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 13e21692065..ccbb7df3623 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -153,6 +153,7 @@ import UnliftIO.Async import Wire.API.Federation.Error import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) +import Wire.API.User data AllowSCIMUpdates = AllowSCIMUpdates @@ -454,7 +455,7 @@ updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> Except updateUser uid mconn uu allowScim = do for_ (uupName uu) $ \newName -> do mbUser <- lift $ Data.lookupUser WithPendingInvitations uid - user <- maybe (throwE (ProfileNotFound uid)) pure mbUser + user <- maybe (throwE ProfileNotFound) pure mbUser unless ( userManagedBy user /= ManagedByScim || userDisplayName user == newName @@ -611,22 +612,21 @@ changePhone :: UserId -> Phone -> ExceptT ChangePhoneError AppIO (Activation, Ph changePhone u phone = do canonical <- maybe - (throwE $ InvalidNewPhone phone) + (throwE InvalidNewPhone) return =<< lift (validatePhone phone) let pk = userPhoneKey canonical available <- lift $ Data.keyAvailable pk (Just u) unless available $ - throwE $ - PhoneExists phone + throwE PhoneExists timeout <- setActivationTimeout <$> view settings blacklisted <- lift $ Blacklist.exists pk when blacklisted $ - throwE (BlacklistedNewPhone canonical) + throwE BlacklistedNewPhone -- check if any prefixes of this phone number are blocked prefixExcluded <- lift $ Blacklist.existsAnyPrefix canonical when prefixExcluded $ - throwE (BlacklistedNewPhone canonical) + throwE BlacklistedNewPhone act <- lift $ Data.newActivation pk timeout (Just u) return (act, canonical) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 3d4276d7f86..58d90d80c28 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -23,9 +23,11 @@ module Brig.API.Util validateHandle, logEmail, traverseConcurrentlyWithErrors, + exceptTToMaybe, ) where +import Brig.API.Error import qualified Brig.API.Error as Error import Brig.API.Handler import Brig.API.Types @@ -46,6 +48,7 @@ import qualified System.Logger as Log import UnliftIO.Async import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) +import Wire.API.ErrorDescription lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> Handler [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do @@ -68,7 +71,7 @@ lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount mk a = SelfProfile (accountUser a) validateHandle :: Text -> Handler Handle -validateHandle = maybe (throwE (Error.StdError Error.invalidHandle)) return . parseHandle +validateHandle = maybe (throwE (Error.StdError (errorDescriptionTypeToWai @InvalidHandle))) return . parseHandle logEmail :: Email -> (Msg -> Msg) logEmail email = @@ -86,3 +89,6 @@ traverseConcurrentlyWithErrors :: traverseConcurrentlyWithErrors f = ExceptT . try . (traverse (either throwIO pure) =<<) . pooledMapConcurrentlyN 8 (runExceptT . f) + +exceptTToMaybe :: Monad m => ExceptT e m () -> m (Maybe e) +exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index a55b9ffb59c..5f770008b65 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -332,11 +332,11 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- Validate phone inviteePhone <- for (irInviteePhone body) $ \p -> do - validatedPhone <- maybe (throwStd invalidPhone) return =<< lift (Phone.validatePhone p) + validatedPhone <- maybe (throwStd (errorDescriptionTypeToWai @InvalidPhone)) return =<< lift (Phone.validatePhone p) let ukp = userPhoneKey validatedPhone blacklistedPh <- lift $ Blacklist.exists ukp when blacklistedPh $ - throwStd blacklistedPhone + throwStd (errorDescriptionTypeToWai @BlacklistedPhone) phoneTaken <- lift $ isJust <$> Data.lookupKey ukp when phoneTaken $ throwStd phoneExists diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index bd81bc54cf8..dae3407e7ea 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -95,7 +95,7 @@ routesPublic = do Doc.description "JSON body" Doc.returns (Doc.ref Public.modelLoginCodeResponse) Doc.response 200 "Login code sent." Doc.end - Doc.errorResponse invalidPhone + Doc.errorResponse (errorDescriptionTypeToWai @InvalidPhone) Doc.errorResponse passwordExists Doc.errorResponse' loginCodePending Doc.pendingLoginError @@ -155,9 +155,9 @@ routesPublic = do Doc.response 202 "Update accepted and pending activation of the new email." Doc.end Doc.response 204 "No update, current and new email address are the same." Doc.end Doc.errorResponse invalidEmail - Doc.errorResponse userKeyExists + Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) Doc.errorResponse blacklistedEmail - Doc.errorResponse blacklistedPhone + Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) Doc.errorResponse missingAccessToken Doc.errorResponse invalidAccessToken Doc.errorResponse (errorDescriptionTypeToWai @BadCredentials) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 77074404f81..098c4b831e8 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -137,6 +137,7 @@ tests _ at opts p b c ch g aws = test' aws p "put /access/self/email - 2xx" $ testEmailUpdate b aws, test' aws p "put /self/phone - 202" $ testPhoneUpdate b, test' aws p "put /self/phone - 403" $ testPhoneUpdateBlacklisted b, + test' aws p "put /self/phone - 409" $ testPhoneUpdateConflict b, test' aws p "head /self/password - 200/404" $ testPasswordSet b, test' aws p "put /self/password - 200" $ testPasswordChange b, test' aws p "put /self/locale - 200" $ testUserLocaleUpdate b aws, @@ -823,12 +824,13 @@ testUserUpdate brig cannon aws = do bobUser <- randomUser brig liftIO $ Util.assertUserJournalQueue "user create bob" aws (userActivateJournaled bobUser) let bob = userId bobUser + aliceNewName <- randomName connectUsers brig alice (singleton bob) let newColId = Just 5 newAssets = Just [ImageAsset "abc" (Just AssetComplete)] - newName = Just $ Name "dogbert" + mNewName = Just $ aliceNewName newPic = Nothing -- Legacy - userUpdate = UserUpdate newName newPic newAssets newColId + userUpdate = UserUpdate mNewName newPic newAssets newColId update = RequestBodyLBS . encode $ userUpdate -- Update profile & receive notification WS.bracketRN cannon [alice, bob] $ \[aliceWS, bobWS] -> do @@ -840,7 +842,7 @@ testUserUpdate brig cannon aws = do -- get the updated profile get (brig . path "/self" . zUser alice) !!! do const 200 === statusCode - const (newName, newColId, newAssets) + const (mNewName, newColId, newAssets) === ( \u -> ( fmap userDisplayName u, fmap userAccentId u, @@ -851,7 +853,7 @@ testUserUpdate brig cannon aws = do -- get only the new name get (brig . path "/self/name" . zUser alice) !!! do const 200 === statusCode - const (String . fromName <$> newName) + const (String . fromName <$> mNewName) === ( \r -> do b <- responseBody r b ^? key "name" @@ -859,7 +861,7 @@ testUserUpdate brig cannon aws = do -- should appear in search by 'newName' suid <- userId <$> randomUser brig Search.refreshIndex brig - Search.assertCanFind brig suid aliceQ "dogbert" + Search.assertCanFind brig suid aliceQ (fromName aliceNewName) -- This tests the behavior of `/i/self/email` instead of `/self/email` or -- `/access/self/email`. tests for session token handling under `/access/self/email` are in @@ -934,6 +936,17 @@ testPhoneUpdateBlacklisted brig = do -- cleanup to avoid other tests failing sporadically deletePrefix brig (phonePrefix prefix) +testPhoneUpdateConflict :: Brig -> Http () +testPhoneUpdateConflict brig = do + uid1 <- userId <$> randomUser brig + phn <- randomPhone + updatePhone brig uid1 phn + + uid2 <- userId <$> randomUser brig + let phoneUpdate = RequestBodyLBS . encode $ PhoneUpdate phn + put (brig . path "/self/phone" . contentJson . zUser uid2 . zConn "c" . body phoneUpdate) + !!! (const 409 === statusCode) + testCreateAccountPendingActivationKey :: Opt.Opts -> Brig -> Http () testCreateAccountPendingActivationKey (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ = pure () testCreateAccountPendingActivationKey _ brig = do From e16ad2c3831281288889f50b2c207f3eb8b6d65f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 4 Feb 2022 09:18:31 +0100 Subject: [PATCH 10/58] Cleanup internal endpoints (#2086) * No more servant-generic in galley's internal API * Move LH internal endpoints to Internal module * Move CH internal endpoints to Internal module --- .../5-internal/move-internal-endpoints | 1 + .../src/Wire/API/Routes/Internal/Cargohold.hs | 24 + .../src/Wire/API/Routes/Internal/LegalHold.hs | 29 ++ .../src/Wire/API/Routes/Public/Cargohold.hs | 4 - .../src/Wire/API/Routes/Public/Galley.hs | 99 ++-- .../src/Wire/API/Routes/Public/LegalHold.hs | 12 +- libs/wire-api/wire-api.cabal | 2 + .../cargohold/src/CargoHold/API/Public.hs | 11 +- services/cargohold/src/CargoHold/Run.hs | 8 +- services/galley/src/Galley/API.hs | 4 +- services/galley/src/Galley/API/Internal.hs | 468 ++++++++---------- services/galley/src/Galley/Run.hs | 10 +- 12 files changed, 327 insertions(+), 345 deletions(-) create mode 100644 changelog.d/5-internal/move-internal-endpoints create mode 100644 libs/wire-api/src/Wire/API/Routes/Internal/Cargohold.hs create mode 100644 libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs diff --git a/changelog.d/5-internal/move-internal-endpoints b/changelog.d/5-internal/move-internal-endpoints new file mode 100644 index 00000000000..e92adfa6aa9 --- /dev/null +++ b/changelog.d/5-internal/move-internal-endpoints @@ -0,0 +1 @@ +Remove servant-generic from internal endpoints and remove them from Swagger diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Cargohold.hs new file mode 100644 index 00000000000..5900b31d96c --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Cargohold.hs @@ -0,0 +1,24 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Routes.Internal.Cargohold where + +import Servant +import Wire.API.Routes.MultiVerb + +type InternalAPI = + "i" :> "status" :> MultiVerb 'GET '() '[RespondEmpty 200 "OK"] () diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs new file mode 100644 index 00000000000..74f92ab591c --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs @@ -0,0 +1,29 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Routes.Internal.LegalHold where + +import Data.Id +import Servant.API hiding (Header) +import Wire.API.Team.Feature + +type InternalLegalHoldAPI = + "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" + :> Get '[JSON] (TeamFeatureStatus 'WithLockStatus 'TeamFeatureLegalHold) + :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" + :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) + :> Put '[] NoContent diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs index 4cadbd0661b..3a27e6cbeea 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs @@ -113,7 +113,6 @@ type ServantAPI = :<|> BaseAPIv3 'ProviderPrincipalTag :<|> QualifiedAPI :<|> LegacyAPI - :<|> InternalAPI type BaseAPIv3 (tag :: PrincipalTag) = ( Summary "Upload an asset" @@ -208,8 +207,5 @@ type LegacyAPI = :> GetAsset ) -type InternalAPI = - "i" :> "status" :> MultiVerb 'GET '() '[RespondEmpty 200 "OK"] () - swaggerDoc :: Swagger.Swagger swaggerDoc = toSwagger (Proxy @ServantAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 853f58e588b..47f9c19d212 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -48,8 +48,6 @@ import Wire.API.Team.Conversation import Wire.API.Team.Feature import Wire.API.Team.Permission (Perm (..)) --- import Wire.API.Team.Permission (Perm (..)) - instance AsHeaders '[ConvId] Conversation Conversation where toHeaders c = (I (qUnqualified (cnvQualifiedId c)) :* Nil, c) fromHeaders = snd @@ -755,59 +753,64 @@ type FeatureAPI = :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks -type FeatureStatusGet featureName = +type FeatureStatusGet f = Named - '("get", featureName) - ( Summary (AppendSymbol "Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (TeamFeatureStatus 'WithLockStatus featureName) - ) + '("get", f) + (ZUser :> FeatureStatusBaseGet 'WithLockStatus f) -type FeatureStatusPut featureName = +type FeatureStatusPut f = Named - '("put", featureName) - ( Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - ) + '("put", f) + (ZUser :> FeatureStatusBasePut f) --- | A type for a GET endpoint for a feature with a deprecated path -type FeatureStatusDeprecatedGet ps featureName = +type FeatureStatusDeprecatedGet l f = Named - '("get-deprecated", featureName) - ( Summary - (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (TeamFeatureStatus ps featureName) - ) + '("get-deprecated", f) + (ZUser :> FeatureStatusBaseDeprecatedGet l f) --- | A type for a PUT endpoint for a feature with a deprecated path -type FeatureStatusDeprecatedPut featureName = +type FeatureStatusDeprecatedPut f = Named - '("put-deprecated", featureName) - ( Summary - (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) - :> ZUser - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) - ) + '("put-deprecated", f) + (ZUser :> FeatureStatusBaseDeprecatedPut f) + +type FeatureStatusBaseGet lockStatus featureName = + Summary (AppendSymbol "Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> KnownTeamFeatureNameSymbol featureName + :> Get '[Servant.JSON] (TeamFeatureStatus lockStatus featureName) + +type FeatureStatusBasePut featureName = + Summary (AppendSymbol "Put config for " (KnownTeamFeatureNameSymbol featureName)) + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> KnownTeamFeatureNameSymbol featureName + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + +-- | A type for a GET endpoint for a feature with a deprecated path +type FeatureStatusBaseDeprecatedGet lockStatus featureName = + ( Summary + (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> DeprecatedFeatureName featureName + :> Get '[Servant.JSON] (TeamFeatureStatus lockStatus featureName) + ) + +-- | A type for a PUT endpoint for a feature with a deprecated path +type FeatureStatusBaseDeprecatedPut featureName = + Summary + (AppendSymbol "[deprecated] Get config for " (KnownTeamFeatureNameSymbol featureName)) + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> DeprecatedFeatureName featureName + :> ReqBody '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) + :> Put '[Servant.JSON] (TeamFeatureStatus 'WithoutLockStatus featureName) type FeatureConfigGet ps featureName = Named diff --git a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs index a89b2db516b..a4eb42ae5de 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/LegalHold.hs @@ -22,13 +22,10 @@ import Data.Proxy import Data.Swagger hiding (Header (..)) import Servant.API hiding (Header) import Servant.Swagger -import Wire.API.Team.Feature import Wire.API.Team.LegalHold -type ServantAPI = PublicAPI :<|> InternalAPI - -- FUTUREWORK: restructure this for readability and add missing bodies -type PublicAPI = +type ServantAPI = "teams" :> Capture "tid" TeamId :> "legalhold" :> "settings" :> ReqBody '[JSON] NewLegalHoldService :> Post '[JSON] ViewLegalHoldService @@ -50,12 +47,5 @@ type PublicAPI = -- :> ReqBody '[JSON] DisableLegalHoldForUserRequest :> Verb 'DELETE 204 '[] NoContent -type InternalAPI = - "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] (TeamFeatureStatus 'WithLockStatus 'TeamFeatureLegalHold) - :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) - :> Put '[] NoContent - swaggerDoc :: Swagger swaggerDoc = toSwagger (Proxy @ServantAPI) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index dba6070fb59..b358f7bda5f 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -49,6 +49,8 @@ library Wire.API.Routes.Internal.Brig Wire.API.Routes.Internal.Brig.Connection Wire.API.Routes.Internal.Brig.EJPD + Wire.API.Routes.Internal.Cargohold + Wire.API.Routes.Internal.LegalHold Wire.API.Routes.MultiTablePaging Wire.API.Routes.MultiTablePaging.State Wire.API.Routes.MultiVerb diff --git a/services/cargohold/src/CargoHold/API/Public.hs b/services/cargohold/src/CargoHold/API/Public.hs index b9c4514c9ec..41b15c2695d 100644 --- a/services/cargohold/src/CargoHold/API/Public.hs +++ b/services/cargohold/src/CargoHold/API/Public.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 CargoHold.API.Public (servantSitemap) where +module CargoHold.API.Public (servantSitemap, internalSitemap) where import qualified CargoHold.API.Legacy as LegacyAPI import CargoHold.API.Util @@ -36,17 +36,18 @@ import Servant.Server hiding (Handler) import URI.ByteString import Wire.API.Asset import Wire.API.Routes.AssetBody +import Wire.API.Routes.Internal.Cargohold import Wire.API.Routes.Public.Cargohold servantSitemap :: ServerT ServantAPI Handler servantSitemap = - renewTokenV3 :<|> deleteTokenV3 + renewTokenV3 + :<|> deleteTokenV3 :<|> userAPI :<|> botAPI :<|> providerAPI :<|> qualifiedAPI :<|> legacyAPI - :<|> internalAPI where userAPI :: forall tag. tag ~ 'UserPrincipalTag => ServerT (BaseAPIv3 tag) Handler userAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag @@ -56,7 +57,9 @@ servantSitemap = providerAPI = uploadAssetV3 @tag :<|> downloadAssetV3 @tag :<|> deleteAssetV3 @tag legacyAPI = legacyDownloadPlain :<|> legacyDownloadPlain :<|> legacyDownloadOtr qualifiedAPI = downloadAssetV4 :<|> deleteAssetV4 - internalAPI = pure () + +internalSitemap :: ServerT InternalAPI Handler +internalSitemap = pure () class HasLocation (tag :: PrincipalTag) where assetLocation :: Local AssetKey -> [Text] diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 7254b96efe4..245a41f5557 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -44,9 +44,10 @@ import qualified Servant import Servant.API import Servant.Server hiding (Handler, runHandler) import Util.Options -import qualified Wire.API.Routes.Public.Cargohold as Public +import Wire.API.Routes.Internal.Cargohold +import Wire.API.Routes.Public.Cargohold -type CombinedAPI = FederationAPI :<|> Public.ServantAPI +type CombinedAPI = FederationAPI :<|> ServantAPI :<|> InternalAPI run :: Opts -> IO () run o = lowerCodensity $ do @@ -77,7 +78,8 @@ mkApp o = Codensity $ \k -> (Proxy @CombinedAPI) ((o ^. optSettings . setFederationDomain) :. Servant.EmptyContext) ( hoistServer' @FederationAPI (toServantHandler e) federationSitemap - :<|> hoistServer' @Public.ServantAPI (toServantHandler e) servantSitemap + :<|> hoistServer' @ServantAPI (toServantHandler e) servantSitemap + :<|> hoistServer' @InternalAPI (toServantHandler e) internalSitemap ) r diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index bc6d83c4d6d..fe28713db29 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -22,7 +22,7 @@ module Galley.API where import qualified Data.Swagger.Build.Api as Doc -import qualified Galley.API.Internal as Internal +import Galley.API.Internal import qualified Galley.API.Public as Public import Galley.API.Public.Servant import Galley.App (GalleyEffects) @@ -33,4 +33,4 @@ sitemap :: Routes Doc.ApiBuilder (Sem GalleyEffects) () sitemap = do Public.sitemap Public.apiDocs - Internal.sitemap + internalSitemap diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 59f8d668d79..d6e98038b99 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -16,10 +16,9 @@ -- with this program. If not, see . module Galley.API.Internal - ( sitemap, - servantSitemap, - InternalApi, - ServantAPI, + ( internalSitemap, + internalAPI, + InternalAPI, deleteLoop, safeForever, ) @@ -41,18 +40,17 @@ import qualified Galley.API.CustomBackend as CustomBackend import Galley.API.Error import Galley.API.LegalHold (getTeamLegalholdWhitelistedH, setTeamLegalholdWhitelistedH, unsetTeamLegalholdWhitelistedH) import Galley.API.LegalHold.Conflicts -import qualified Galley.API.One2One as One2One +import Galley.API.One2One import qualified Galley.API.Query as Query import Galley.API.Teams (uncheckedDeleteTeamMember) import qualified Galley.API.Teams as Teams -import Galley.API.Teams.Features (DoAuth (..)) -import qualified Galley.API.Teams.Features as Features +import Galley.API.Teams.Features import qualified Galley.API.Update as Update import Galley.API.Util import Galley.App import Galley.Cassandra.Paging import qualified Galley.Data.Conversation as Data -import Galley.Data.TeamFeatures (MaybeHasLockStatusCol) +import Galley.Data.TeamFeatures import Galley.Effects import Galley.Effects.ClientStore import Galley.Effects.ConversationStore @@ -88,9 +86,7 @@ import Polysemy.Input import qualified Polysemy.TinyLog as P import Servant.API hiding (JSON) import qualified Servant.API as Servant -import Servant.API.Generic import Servant.Server -import Servant.Server.Generic (genericServerT) import System.Logger.Class hiding (Path, name) import qualified System.Logger.Class as Log import Wire.API.Conversation (ConvIdsPage, pattern GetPaginatedConversationIds) @@ -101,247 +97,124 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiVerb (MultiVerb, RespondEmpty) +import Wire.API.Routes.Named import Wire.API.Routes.Public (ZLocalUser, ZOptConn) -import Wire.API.Routes.Public.Galley (ConversationVerb) -import qualified Wire.API.Team.Feature as Public - -data InternalApi routes = InternalApi - { iStatusGet :: - routes - :- "i" - :> "status" - :> Get '[Servant.JSON] NoContent, - iStatusHead :: - routes - :- "i" - :> "status" - :> Verb 'HEAD 200 '[Servant.JSON] NoContent, - -- Team Feature Flag API (internal) ----------------------------------- - -- - -- Configuring some features should only be possible internally. - -- Viewing the config for features should be allowed for any admin. - iTeamFeatureStatusSSOGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSSO, - iTeamFeatureStatusSSOPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureSSO, - iTeamFeatureStatusLegalHoldGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureLegalHold, - iTeamFeatureStatusLegalHoldPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureLegalHold, - iTeamFeatureStatusSearchVisibilityGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, - iTeamFeatureStatusSearchVisibilityPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureSearchVisibility, - iTeamFeatureStatusSearchVisibilityDeprecatedGet :: - routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureSearchVisibility, - iTeamFeatureStatusSearchVisibilityDeprecatedPut :: - routes - :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureSearchVisibility, - iTeamFeatureStatusValidateSAMLEmailsGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, - iTeamFeatureStatusValidateSAMLEmailsPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureValidateSAMLEmails, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet :: - routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut :: - routes - :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureValidateSAMLEmails, - iTeamFeatureStatusDigitalSignaturesGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, - iTeamFeatureStatusDigitalSignaturesPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureDigitalSignatures, - iTeamFeatureStatusDigitalSignaturesDeprecatedGet :: - routes - :- IFeatureStatusDeprecatedGet 'Public.WithoutLockStatus 'Public.TeamFeatureDigitalSignatures, - iTeamFeatureStatusDigitalSignaturesDeprecatedPut :: - routes - :- IFeatureStatusDeprecatedPut 'Public.TeamFeatureDigitalSignatures, - iTeamFeatureStatusAppLockGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureAppLock, - iTeamFeatureStatusAppLockPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureAppLock, - iTeamFeatureStatusFileSharingGet :: - routes - :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureFileSharing, - iTeamFeatureStatusFileSharingPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureFileSharing, - iTeamFeatureLockStatusFileSharingPut :: - routes - :- IFeatureStatusLockStatusPut 'Public.TeamFeatureFileSharing, - iTeamFeatureStatusClassifiedDomainsGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains, - iTeamFeatureStatusConferenceCallingPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureConferenceCalling, - iTeamFeatureStatusConferenceCallingGet :: - routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureConferenceCalling, - iTeamFeatureStatusSelfDeletingMessagesPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureSelfDeletingMessages, - iTeamFeatureStatusSelfDeletingMessagesGet :: - routes - :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureSelfDeletingMessages, - iTeamFeatureLockStatusSelfDeletingMessagesPut :: - routes - :- IFeatureStatusLockStatusPut 'Public.TeamFeatureSelfDeletingMessages, - iTeamFeatureStatusGuestLinksGet :: - routes - :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks, - iTeamFeatureStatusGuestLinksPut :: - routes - :- IFeatureStatusPut 'Public.TeamFeatureGuestLinks, - iTeamFeatureLockStatusGuestLinksPut :: - routes - :- IFeatureStatusLockStatusPut 'Public.TeamFeatureGuestLinks, - -- This endpoint can lead to the following events being sent: - -- - MemberLeave event to members for all conversations the user was in - iDeleteUser :: - routes - :- Summary - "Remove a user from their teams and conversations and erase their clients" - :> ZLocalUser - :> ZOptConn - :> "i" - :> "user" - :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] (), - -- This endpoint can lead to the following events being sent: - -- - ConvCreate event to self, if conversation did not exist before - -- - ConvConnect event to self, if other didn't join the connect conversation before - iConnect :: - routes - :- Summary "Create a connect conversation (deprecated)" - :> ZLocalUser - :> ZOptConn - :> "i" - :> "conversations" - :> "connect" - :> ReqBody '[Servant.JSON] Connect - :> ConversationVerb, - iUpsertOne2OneConversation :: - routes - :- Summary "Create or Update a connect or one2one conversation." - :> "i" - :> "conversations" - :> "one2one" - :> "upsert" - :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest - :> Post '[Servant.JSON] UpsertOne2OneConversationResponse - } - deriving (Generic) - -type ServantAPI = ToServantApi InternalApi - -type IFeatureStatusGet lockStatus featureName = - Summary (AppendSymbol "Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.KnownTeamFeatureNameSymbol featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) - -type IFeatureStatusPut featureName = - Summary (AppendSymbol "Put config for " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.KnownTeamFeatureNameSymbol featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) +import Wire.API.Routes.Public.Galley +import Wire.API.Team.Feature + +type IFeatureAPI = + IFeatureStatus 'TeamFeatureSSO + :<|> IFeatureStatus 'TeamFeatureLegalHold + :<|> IFeatureStatus 'TeamFeatureSearchVisibility + :<|> IFeatureStatusDeprecated 'TeamFeatureSearchVisibility + :<|> IFeatureStatus 'TeamFeatureValidateSAMLEmails + :<|> IFeatureStatusDeprecated 'TeamFeatureValidateSAMLEmails + :<|> IFeatureStatus 'TeamFeatureDigitalSignatures + :<|> IFeatureStatusDeprecated 'TeamFeatureDigitalSignatures + :<|> IFeatureStatus 'TeamFeatureAppLock + :<|> IFeatureStatusWithLock 'TeamFeatureFileSharing + :<|> IFeatureStatusGet 'WithLockStatus 'TeamFeatureClassifiedDomains + :<|> IFeatureStatus 'TeamFeatureConferenceCalling + :<|> IFeatureStatusWithLock 'TeamFeatureSelfDeletingMessages + :<|> IFeatureStatusWithLock 'TeamFeatureGuestLinks + +type InternalAPI = + "i" + :> ( Named + "status" + ( "status" :> MultiVerb 'GET '[Servant.JSON] '[RespondEmpty 200 "OK"] () + ) + -- This endpoint can lead to the following events being sent: + -- - MemberLeave event to members for all conversations the user was in + :<|> Named + "delete-user" + ( Summary + "Remove a user from their teams and conversations and erase their clients" + :> ZLocalUser + :> ZOptConn + :> "user" + :> MultiVerb 'DELETE '[Servant.JSON] '[RespondEmpty 200 "Remove a user from Galley"] () + ) + -- This endpoint can lead to the following events being sent: + -- - ConvCreate event to self, if conversation did not exist before + -- - ConvConnect event to self, if other didn't join the connect conversation before + :<|> Named + "connect" + ( Summary "Create a connect conversation (deprecated)" + :> ZLocalUser + :> ZOptConn + :> "conversations" + :> "connect" + :> ReqBody '[Servant.JSON] Connect + :> ConversationVerb + ) + :<|> Named + "upsert-one2one" + ( Summary "Create or Update a connect or one2one conversation." + :> "conversations" + :> "one2one" + :> "upsert" + :> ReqBody '[Servant.JSON] UpsertOne2OneConversationRequest + :> Post '[Servant.JSON] UpsertOne2OneConversationResponse + ) + :<|> IFeatureAPI + ) + +type IFeatureStatusGet l f = Named '("iget", f) (FeatureStatusBaseGet l f) + +type IFeatureStatusPut f = Named '("iput", f) (FeatureStatusBasePut f) + +type IFeatureStatus f = IFeatureStatusGet 'WithoutLockStatus f :<|> IFeatureStatusPut f + +type IFeatureStatusDeprecated f = + Named '("iget-deprecated", f) (FeatureStatusBaseDeprecatedGet 'WithoutLockStatus f) + :<|> Named '("iput-deprecated", f) (FeatureStatusBaseDeprecatedPut f) type IFeatureStatusLockStatusPut featureName = - Summary (AppendSymbol "(Un-)lock " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.KnownTeamFeatureNameSymbol featureName - :> Capture "lockStatus" Public.LockStatusValue - :> Put '[Servant.JSON] Public.LockStatus - --- | A type for a GET endpoint for a feature with a deprecated path -type IFeatureStatusDeprecatedGet lockStatus featureName = - Summary (AppendSymbol "[deprecated] Get config for " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.DeprecatedFeatureName featureName - :> Get '[Servant.JSON] (Public.TeamFeatureStatus lockStatus featureName) - --- | A type for a PUT endpoint for a feature with a deprecated path -type IFeatureStatusDeprecatedPut featureName = - Summary (AppendSymbol "[deprecated] Put config for " (Public.KnownTeamFeatureNameSymbol featureName)) - :> "i" - :> "teams" - :> Capture "tid" TeamId - :> "features" - :> Public.DeprecatedFeatureName featureName - :> ReqBody '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - :> Put '[Servant.JSON] (Public.TeamFeatureStatus 'Public.WithoutLockStatus featureName) - -servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) -servantSitemap = - genericServerT $ - InternalApi - { iStatusGet = pure NoContent, - iStatusHead = pure NoContent, - iTeamFeatureStatusSSOGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSSO Features.getSSOStatusInternal, - iTeamFeatureStatusSSOPut = iPutTeamFeature @'Public.TeamFeatureSSO Features.setSSOStatusInternal, - iTeamFeatureStatusLegalHoldGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureLegalHold Features.getLegalholdStatusInternal, - iTeamFeatureStatusLegalHoldPut = iPutTeamFeature @'Public.TeamFeatureLegalHold (Features.setLegalholdStatusInternal @InternalPaging), - iTeamFeatureStatusSearchVisibilityGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureSearchVisibility Features.getTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusSearchVisibilityDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureLegalHold Features.setTeamSearchVisibilityAvailableInternal, - iTeamFeatureStatusValidateSAMLEmailsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails Features.getValidateSAMLEmailsInternal, - iTeamFeatureStatusValidateSAMLEmailsDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureValidateSAMLEmails Features.setValidateSAMLEmailsInternal, - iTeamFeatureStatusDigitalSignaturesGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesDeprecatedGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures Features.getDigitalSignaturesInternal, - iTeamFeatureStatusDigitalSignaturesDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, - iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, - iTeamFeatureStatusAppLockPut = iPutTeamFeature @'Public.TeamFeatureAppLock Features.setAppLockInternal, - iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, - iTeamFeatureStatusFileSharingPut = iPutTeamFeature @'Public.TeamFeatureFileSharing Features.setFileSharingInternal, - iTeamFeatureLockStatusFileSharingPut = Features.setLockStatus @'Public.TeamFeatureFileSharing, - iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, - iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, - iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, - iTeamFeatureStatusSelfDeletingMessagesPut = iPutTeamFeature @'Public.TeamFeatureSelfDeletingMessages Features.setSelfDeletingMessagesInternal, - iTeamFeatureStatusSelfDeletingMessagesGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages Features.getSelfDeletingMessagesInternal, - iTeamFeatureLockStatusSelfDeletingMessagesPut = Features.setLockStatus @'Public.TeamFeatureSelfDeletingMessages, - iTeamFeatureStatusGuestLinksGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks Features.getGuestLinkInternal, - iTeamFeatureStatusGuestLinksPut = iPutTeamFeature @'Public.TeamFeatureGuestLinks Features.setGuestLinkInternal, - iTeamFeatureLockStatusGuestLinksPut = Features.setLockStatus @'Public.TeamFeatureGuestLinks, - iDeleteUser = rmUser, - iConnect = Create.createConnectConversation, - iUpsertOne2OneConversation = One2One.iUpsertOne2OneConversation - } - -iGetTeamFeature :: - forall ps a r. - ( Public.KnownTeamFeatureName a, + Named + '("lock", featureName) + ( Summary (AppendSymbol "(Un-)lock " (KnownTeamFeatureNameSymbol featureName)) + :> "teams" + :> Capture "tid" TeamId + :> "features" + :> KnownTeamFeatureNameSymbol featureName + :> Capture "lockStatus" LockStatusValue + :> Put '[Servant.JSON] LockStatus + ) + +type IFeatureStatusWithLock f = + IFeatureStatusGet 'WithLockStatus f + :<|> IFeatureStatusPut f + :<|> IFeatureStatusLockStatusPut f + +internalAPI :: ServerT InternalAPI (Sem GalleyEffects) +internalAPI = + Named @"status" (pure ()) + :<|> Named @"delete-user" rmUser + :<|> Named @"connect" Create.createConnectConversation + :<|> Named @"upsert-one2one" iUpsertOne2OneConversation + :<|> featureAPI + +featureAPI :: ServerT IFeatureAPI (Sem GalleyEffects) +featureAPI = + featureStatus getSSOStatusInternal setSSOStatusInternal + :<|> featureStatus getLegalholdStatusInternal (setLegalholdStatusInternal @InternalPaging) + :<|> featureStatus getTeamSearchVisibilityAvailableInternal setTeamSearchVisibilityAvailableInternal + :<|> featureStatusDeprecated getTeamSearchVisibilityAvailableInternal setTeamSearchVisibilityAvailableInternal + :<|> featureStatus getValidateSAMLEmailsInternal setValidateSAMLEmailsInternal + :<|> featureStatusDeprecated getValidateSAMLEmailsInternal setValidateSAMLEmailsInternal + :<|> featureStatus getDigitalSignaturesInternal setDigitalSignaturesInternal + :<|> featureStatusDeprecated getDigitalSignaturesInternal setDigitalSignaturesInternal + :<|> featureStatus getAppLockInternal setAppLockInternal + :<|> featureStatusWithLock getFileSharingInternal setFileSharingInternal + :<|> featureStatusGet @'WithLockStatus getClassifiedDomainsInternal + :<|> featureStatus @'TeamFeatureConferenceCalling getConferenceCallingInternal setConferenceCallingInternal + :<|> featureStatusWithLock getSelfDeletingMessagesInternal setSelfDeletingMessagesInternal + :<|> featureStatusWithLock getGuestLinkInternal setGuestLinkInternal + +featureStatusGet :: + forall (l :: IncludeLockStatus) f r. + ( KnownTeamFeatureName f, Members '[ Error ActionError, Error NotATeamMember, @@ -350,33 +223,92 @@ iGetTeamFeature :: ] r ) => - (Features.GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus ps a)) -> - TeamId -> - Sem r (Public.TeamFeatureStatus ps a) -iGetTeamFeature getter = Features.getFeatureStatus @ps @a getter DontDoAuth - -iPutTeamFeature :: - forall a r. - ( Public.KnownTeamFeatureName a, - MaybeHasLockStatusCol a, + (GetFeatureInternalParam -> Sem r (TeamFeatureStatus l f)) -> + ServerT (IFeatureStatusGet l f) (Sem r) +featureStatusGet getter = + Named @'("iget", f) (getFeatureStatus @l @f getter DontDoAuth) + +featureStatusPut :: + forall f r. + ( KnownTeamFeatureName f, + MaybeHasLockStatusCol f, Members '[ Error ActionError, Error NotATeamMember, Error TeamError, - Error TeamFeatureError, - TeamStore, - TeamFeatureStore + TeamFeatureStore, + TeamStore + ] + r + ) => + (TeamId -> TeamFeatureStatus 'WithoutLockStatus f -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + ServerT (IFeatureStatusPut f) (Sem r) +featureStatusPut setter = + Named @'("iput", f) (setFeatureStatus @f setter DontDoAuth) + +featureStatus :: + forall f r. + ( KnownTeamFeatureName f, + MaybeHasLockStatusCol f, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamFeatureStore, + TeamStore + ] + r + ) => + (GetFeatureInternalParam -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + (TeamId -> TeamFeatureStatus 'WithoutLockStatus f -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + ServerT (IFeatureStatus f) (Sem r) +featureStatus getter setter = + featureStatusGet @'WithoutLockStatus @f getter :<|> featureStatusPut @f setter + +featureStatusDeprecated :: + forall f r. + ( KnownTeamFeatureName f, + MaybeHasLockStatusCol f, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamFeatureStore, + TeamStore + ] + r + ) => + (GetFeatureInternalParam -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + (TeamId -> TeamFeatureStatus 'WithoutLockStatus f -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + ServerT (IFeatureStatusDeprecated f) (Sem r) +featureStatusDeprecated getter setter = + Named @'("iget-deprecated", f) (getFeatureStatus @'WithoutLockStatus @f getter DontDoAuth) + :<|> Named @'("iput-deprecated", f) (setFeatureStatus @f setter DontDoAuth) + +featureStatusWithLock :: + forall f r. + ( KnownTeamFeatureName f, + HasLockStatusCol f, + MaybeHasLockStatusCol f, + Members + '[ Error ActionError, + Error NotATeamMember, + Error TeamError, + TeamFeatureStore, + TeamStore ] r ) => - (TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a)) -> - TeamId -> - Public.TeamFeatureStatus 'Public.WithoutLockStatus a -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus a) -iPutTeamFeature setter = Features.setFeatureStatus @a setter DontDoAuth - -sitemap :: Routes a (Sem GalleyEffects) () -sitemap = do + (GetFeatureInternalParam -> Sem r (TeamFeatureStatus 'WithLockStatus f)) -> + (TeamId -> TeamFeatureStatus 'WithoutLockStatus f -> Sem r (TeamFeatureStatus 'WithoutLockStatus f)) -> + ServerT (IFeatureStatusWithLock f) (Sem r) +featureStatusWithLock getter setter = + featureStatusGet @'WithLockStatus getter + :<|> featureStatusPut setter + :<|> Named @'("lock", f) (setLockStatus @f) + +internalSitemap :: Routes a (Sem GalleyEffects) () +internalSitemap = do -- Conversation API (internal) ---------------------------------------- put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index fcf0b8839ed..71bc3c454b9 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -38,7 +38,7 @@ import Data.String.Conversions (cs) import Data.Text (unpack) import qualified Galley.API as API import Galley.API.Federation (FederationAPI, federationSitemap) -import qualified Galley.API.Internal as Internal +import Galley.API.Internal import Galley.App import qualified Galley.App as App import Galley.Cassandra @@ -68,7 +68,7 @@ run o = do (portNumber $ fromIntegral $ o ^. optGalley . epPort) l (e ^. monitor) - deleteQueueThread <- Async.async $ runApp e Internal.deleteLoop + deleteQueueThread <- Async.async $ runApp e deleteLoop refreshMetricsThread <- Async.async $ runApp e refreshMetrics runSettingsWithShutdown s app 5 `finally` do Async.cancel deleteQueueThread @@ -106,7 +106,7 @@ mkApp o = do :. Servant.EmptyContext ) ( hoistServer' @GalleyAPI.ServantAPI (toServantHandler e) API.servantSitemap - :<|> hoistServer' @Internal.ServantAPI (toServantHandler e) Internal.servantSitemap + :<|> hoistServer' @InternalAPI (toServantHandler e) internalAPI :<|> hoistServer' @FederationAPI (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) ) @@ -152,7 +152,7 @@ bodyParserErrorFormatter' _ _ errMsg = type CombinedAPI = GalleyAPI.ServantAPI - :<|> Internal.ServantAPI + :<|> InternalAPI :<|> FederationAPI :<|> Servant.Raw @@ -160,7 +160,7 @@ refreshMetrics :: App () refreshMetrics = do m <- view monitor q <- view deleteQueue - Internal.safeForever "refreshMetrics" $ do + safeForever "refreshMetrics" $ do n <- Q.len q M.gaugeSet (fromIntegral n) (M.path "galley.deletequeue.len") m threadDelay 1000000 From 09710edef765e33a5e782db3655c49859909a35b Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 4 Feb 2022 09:21:32 +0100 Subject: [PATCH 11/58] Introduce named routes in brig (#2100) * Remove uses of generic-servant in brig * Split brig API into multiple sections * Fix typo in error message --- changelog.d/5-internal/brig-named-routes | 1 + .../wire-api/src/Wire/API/ErrorDescription.hs | 2 +- .../src/Wire/API/Routes/Public/Brig.hs | 964 ++++++++++-------- services/brig/src/Brig/API/Public.hs | 133 +-- services/brig/src/Brig/Run.hs | 7 +- 5 files changed, 599 insertions(+), 508 deletions(-) create mode 100644 changelog.d/5-internal/brig-named-routes diff --git a/changelog.d/5-internal/brig-named-routes b/changelog.d/5-internal/brig-named-routes new file mode 100644 index 00000000000..1d7179a9047 --- /dev/null +++ b/changelog.d/5-internal/brig-named-routes @@ -0,0 +1 @@ +Remove uses of servant-generics from brig diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 444e131a026..99e5fbe2a98 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -341,7 +341,7 @@ type HandleManagedByScim = ErrorDescription 403 "managed-by-scim" "Updating hand type InvalidPhone = ErrorDescription 400 "invalid-phone" "Invalid mobile phone number" -type UserKeyExists = ErrorDescription 409 "key-exists" "The give e-mail address or phone number is in use." +type UserKeyExists = ErrorDescription 409 "key-exists" "The given e-mail address or phone number is in use." type BlacklistedPhone = ErrorDescription 403 "blacklisted-phone" "The given phone number has been blacklisted due to suspected abuse or a complaint." diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 02adeba83da..525b3aabf9b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- This file is part of the Wire Server implementation. @@ -33,12 +32,12 @@ import Data.Swagger hiding (Contact, Header) import Imports hiding (head) import Servant (JSON) import Servant hiding (Handler, JSON, addHeader, respond) -import Servant.API.Generic import Servant.Swagger (HasSwagger (toSwagger)) import Servant.Swagger.Internal.Orphans () import Wire.API.Connection import Wire.API.ErrorDescription import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Named import Wire.API.Routes.Public (ZConn, ZUser) import Wire.API.Routes.Public.Util import Wire.API.Routes.QualifiedCapture @@ -89,303 +88,293 @@ instance AsUnion DeleteSelfResponses (Maybe Timeout) where type ConnectionUpdateResponses = UpdateResponses "Connection unchanged" "Connection updated" UserConnection -data Api routes = Api - { -- See Note [ephemeral user sideeffect] - getUserUnqualified :: - routes - :- Summary "Get a user by UserId (deprecated)" +type UserAPI = + -- See Note [ephemeral user sideeffect] + Named + "get-user-unqualified" + ( Summary "Get a user by UserId (deprecated)" :> ZUser :> "users" :> CaptureUserId "uid" - :> GetUserVerb, + :> GetUserVerb + ) + :<|> -- See Note [ephemeral user sideeffect] - getUserQualified :: - routes - :- Summary "Get a user by Domain and UserId" - :> ZUser - :> "users" - :> QualifiedCaptureUserId "uid" - :> GetUserVerb, - getSelf :: - routes - :- Summary "Get your own profile" + Named + "get-user-qualified" + ( Summary "Get a user by Domain and UserId" + :> ZUser + :> "users" + :> QualifiedCaptureUserId "uid" + :> GetUserVerb + ) + :<|> Named + "update-user-email" + ( Summary "Resend email address validation email." + :> Description "If the user has a pending email validation, the validation email will be resent." + :> ZUser + :> "users" + :> CaptureUserId "uid" + :> "email" + :> ReqBody '[JSON] EmailUpdate + :> Put '[JSON] () + ) + :<|> Named + "get-handle-info-unqualified" + ( Summary "(deprecated, use /search/contacts) Get information on a user handle" + :> ZUser + :> "users" + :> "handles" + :> Capture' '[Description "The user handle"] "handle" Handle + :> MultiVerb + 'GET + '[JSON] + '[ HandleNotFound, + Respond 200 "User found" UserHandleInfo + ] + (Maybe UserHandleInfo) + ) + :<|> Named + "get-user-by-handle-qualified" + ( Summary "(deprecated, use /search/contacts) Get information on a user handle" + :> ZUser + :> "users" + :> "by-handle" + :> QualifiedCapture' '[Description "The user handle"] "handle" Handle + :> MultiVerb + 'GET + '[JSON] + '[ HandleNotFound, + Respond 200 "User found" UserProfile + ] + (Maybe UserProfile) + ) + :<|> + -- See Note [ephemeral user sideeffect] + Named + "list-users-by-unqualified-ids-or-handles" + ( Summary "List users (deprecated)" + :> Description "The 'ids' and 'handles' parameters are mutually exclusive." + :> ZUser + :> "users" + :> QueryParam' [Optional, Strict, Description "User IDs of users to fetch"] "ids" (CommaSeparatedList UserId) + :> QueryParam' [Optional, Strict, Description "Handles of users to fetch, min 1 and max 4 (the check for handles is rather expensive)"] "handles" (Range 1 4 (CommaSeparatedList Handle)) + :> Get '[JSON] [UserProfile] + ) + :<|> + -- See Note [ephemeral user sideeffect] + Named + "list-users-by-ids-or-handles" + ( Summary "List users" + :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive." + :> ZUser + :> "list-users" + :> ReqBody '[JSON] ListUsersQuery + :> Post '[JSON] [UserProfile] + ) + +type SelfAPI = + Named + "get-self" + ( Summary "Get your own profile" :> ZUser :> "self" - :> Get '[JSON] SelfProfile, + :> Get '[JSON] SelfProfile + ) + :<|> -- This endpoint can lead to the following events being sent: -- - UserDeleted event to contacts of self -- - MemberLeave event to members for all conversations the user was in (via galley) - deleteSelf :: - routes - :- Summary "Initiate account deletion." - :> Description - "if the account has a verified identity, a verification \ - \code is sent and needs to be confirmed to authorise the \ - \deletion. if the account has no verified identity but a \ - \password, it must be provided. if password is correct, or if neither \ - \a verified identity nor a password exists, account deletion \ - \is scheduled immediately." - :> CanThrow InvalidUser - :> CanThrow InvalidCode - :> CanThrow BadCredentials - :> CanThrow MissingAuth - :> CanThrow DeleteCodePending - :> CanThrow OwnerDeletingSelf - :> ZUser - :> "self" - :> ReqBody '[JSON] DeleteUser - :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout), + Named + "delete-self" + ( Summary "Initiate account deletion." + :> Description + "if the account has a verified identity, a verification \ + \code is sent and needs to be confirmed to authorise the \ + \deletion. if the account has no verified identity but a \ + \password, it must be provided. if password is correct, or if neither \ + \a verified identity nor a password exists, account deletion \ + \is scheduled immediately." + :> CanThrow InvalidUser + :> CanThrow InvalidCode + :> CanThrow BadCredentials + :> CanThrow MissingAuth + :> CanThrow DeleteCodePending + :> CanThrow OwnerDeletingSelf + :> ZUser + :> "self" + :> ReqBody '[JSON] DeleteUser + :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout) + ) + :<|> -- This endpoint can lead to the following events being sent: -- - UserUpdated event to contacts of self - putSelf :: - routes - :- Summary "Update your profile." - :> ZUser - :> ZConn - :> "self" - :> ReqBody '[JSON] UserUpdate - :> MultiVerb 'PUT '[JSON] PutSelfResponses (Maybe UpdateProfileError), - changePhone :: - routes - :- Summary "Change your phone number." - :> ZUser - :> ZConn - :> "self" - :> "phone" - :> ReqBody '[JSON] PhoneUpdate - :> MultiVerb 'PUT '[JSON] ChangePhoneResponses (Maybe ChangePhoneError), + Named + "put-self" + ( Summary "Update your profile." + :> ZUser + :> ZConn + :> "self" + :> ReqBody '[JSON] UserUpdate + :> MultiVerb 'PUT '[JSON] PutSelfResponses (Maybe UpdateProfileError) + ) + :<|> Named + "change-phone" + ( Summary "Change your phone number." + :> ZUser + :> ZConn + :> "self" + :> "phone" + :> ReqBody '[JSON] PhoneUpdate + :> MultiVerb 'PUT '[JSON] ChangePhoneResponses (Maybe ChangePhoneError) + ) + :<|> -- This endpoint can lead to the following events being sent: -- - UserIdentityRemoved event to self - removePhone :: - routes - :- Summary "Remove your phone number." - :> Description - "Your phone number can only be removed if you also have an \ - \email address and a password." - :> ZUser - :> ZConn - :> "self" - :> "phone" - :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError), + Named + "remove-phone" + ( Summary "Remove your phone number." + :> Description + "Your phone number can only be removed if you also have an \ + \email address and a password." + :> ZUser + :> ZConn + :> "self" + :> "phone" + :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError) + ) + :<|> -- This endpoint can lead to the following events being sent: -- - UserIdentityRemoved event to self - removeEmail :: - routes - :- Summary "Remove your email address." - :> Description - "Your email address can only be removed if you also have a \ - \phone number." - :> ZUser - :> ZConn - :> "self" - :> "email" - :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError), - checkPasswordExists :: - routes - :- Summary "Check that your password is set." - :> ZUser - :> "self" - :> "password" - :> MultiVerb - 'HEAD - '() - '[ RespondEmpty 404 "Password is not set", - RespondEmpty 200 "Password is set" - ] - Bool, - changePassword :: - routes - :- Summary "Change your password." - :> ZUser - :> "self" - :> "password" - :> ReqBody '[JSON] PasswordChange - :> MultiVerb 'PUT '[JSON] ChangePasswordResponses (Maybe ChangePasswordError), - changeLocale :: - routes - :- Summary "Change your locale." - :> ZUser - :> ZConn - :> "self" - :> "locale" - :> ReqBody '[JSON] LocaleUpdate - :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Local Changed"] (), - changeHandle :: - routes - :- Summary "Change your handle." - :> ZUser - :> ZConn - :> "self" - :> "handle" - :> ReqBody '[JSON] HandleUpdate - :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError), - updateUserEmail :: - routes - :- Summary "Resend email address validation email." - :> Description "If the user has a pending email validation, the validation email will be resent." - :> ZUser - :> "users" - :> CaptureUserId "uid" - :> "email" - :> ReqBody '[JSON] EmailUpdate - :> Put '[JSON] (), - getHandleInfoUnqualified :: - routes - :- Summary "(deprecated, use /search/contacts) Get information on a user handle" - :> ZUser - :> "users" - :> "handles" - :> Capture' '[Description "The user handle"] "handle" Handle - :> MultiVerb - 'GET - '[JSON] - '[ HandleNotFound, - Respond 200 "User found" UserHandleInfo - ] - (Maybe UserHandleInfo), - getUserByHandleQualified :: - routes - :- Summary "(deprecated, use /search/contacts) Get information on a user handle" - :> ZUser - :> "users" - :> "by-handle" - :> QualifiedCapture' '[Description "The user handle"] "handle" Handle - :> MultiVerb - 'GET - '[JSON] - '[ HandleNotFound, - Respond 200 "User found" UserProfile - ] - (Maybe UserProfile), - -- See Note [ephemeral user sideeffect] - listUsersByUnqualifiedIdsOrHandles :: - routes - :- Summary "List users (deprecated)" - :> Description "The 'ids' and 'handles' parameters are mutually exclusive." - :> ZUser - :> "users" - :> QueryParam' [Optional, Strict, Description "User IDs of users to fetch"] "ids" (CommaSeparatedList UserId) - :> QueryParam' [Optional, Strict, Description "Handles of users to fetch, min 1 and max 4 (the check for handles is rather expensive)"] "handles" (Range 1 4 (CommaSeparatedList Handle)) - :> Get '[JSON] [UserProfile], - -- See Note [ephemeral user sideeffect] - listUsersByIdsOrHandles :: - routes - :- Summary "List users" - :> Description "The 'qualified_ids' and 'qualified_handles' parameters are mutually exclusive." - :> ZUser - :> "list-users" - :> ReqBody '[JSON] ListUsersQuery - :> Post '[JSON] [UserProfile], - getUserClientsUnqualified :: - routes - :- Summary "Get all of a user's clients (deprecated)." - :> "users" - :> CaptureUserId "uid" - :> "clients" - :> Get '[JSON] [PubClient], - getUserClientsQualified :: - routes - :- Summary "Get all of a user's clients." - :> "users" - :> QualifiedCaptureUserId "uid" - :> "clients" - :> Get '[JSON] [PubClient], - getUserClientUnqualified :: - routes - :- Summary "Get a specific client of a user (deprecated)." - :> "users" - :> CaptureUserId "uid" - :> "clients" - :> CaptureClientId "client" - :> Get '[JSON] PubClient, - getUserClientQualified :: - routes - :- Summary "Get a specific client of a user." - :> "users" - :> QualifiedCaptureUserId "uid" - :> "clients" - :> CaptureClientId "client" - :> Get '[JSON] PubClient, - listClientsBulk :: - routes - :- Summary "List all clients for a set of user ids (deprecated, use /users/list-clients/v2)" - :> ZUser - :> "users" - :> "list-clients" - :> ReqBody '[JSON] (Range 1 MaxUsersForListClientsBulk [Qualified UserId]) - :> Post '[JSON] (QualifiedUserMap (Set PubClient)), - listClientsBulkV2 :: - routes - :- Summary "List all clients for a set of user ids" - :> ZUser - :> "users" - :> "list-clients" - :> "v2" - :> ReqBody '[JSON] (LimitedQualifiedUserIdList MaxUsersForListClientsBulk) - :> Post '[JSON] (WrappedQualifiedUserMap (Set PubClient)), - getUsersPrekeysClientUnqualified :: - routes - :- Summary "(deprecated) Get a prekey for a specific client of a user." + Named + "remove-email" + ( Summary "Remove your email address." + :> Description + "Your email address can only be removed if you also have a \ + \phone number." + :> ZUser + :> ZConn + :> "self" + :> "email" + :> MultiVerb 'DELETE '[JSON] RemoveIdentityResponses (Maybe RemoveIdentityError) + ) + :<|> Named + "check-password-exists" + ( Summary "Check that your password is set." + :> ZUser + :> "self" + :> "password" + :> MultiVerb + 'HEAD + '() + '[ RespondEmpty 404 "Password is not set", + RespondEmpty 200 "Password is set" + ] + Bool + ) + :<|> Named + "change-password" + ( Summary "Change your password." + :> ZUser + :> "self" + :> "password" + :> ReqBody '[JSON] PasswordChange + :> MultiVerb 'PUT '[JSON] ChangePasswordResponses (Maybe ChangePasswordError) + ) + :<|> Named + "change-locale" + ( Summary "Change your locale." + :> ZUser + :> ZConn + :> "self" + :> "locale" + :> ReqBody '[JSON] LocaleUpdate + :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Local Changed"] () + ) + :<|> Named + "change-handle" + ( Summary "Change your handle." + :> ZUser + :> ZConn + :> "self" + :> "handle" + :> ReqBody '[JSON] HandleUpdate + :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError) + ) + +type PrekeyAPI = + Named + "get-users-prekeys-client-unqualified" + ( Summary "(deprecated) Get a prekey for a specific client of a user." :> ZUser :> "users" :> CaptureUserId "uid" :> "prekeys" :> CaptureClientId "client" - :> Get '[JSON] ClientPrekey, - getUsersPrekeysClientQualified :: - routes - :- Summary "Get a prekey for a specific client of a user." - :> ZUser - :> "users" - :> QualifiedCaptureUserId "uid" - :> "prekeys" - :> CaptureClientId "client" - :> Get '[JSON] ClientPrekey, - getUsersPrekeyBundleUnqualified :: - routes - :- Summary "(deprecated) Get a prekey for each client of a user." - :> ZUser - :> "users" - :> CaptureUserId "uid" - :> "prekeys" - :> Get '[JSON] PrekeyBundle, - getUsersPrekeyBundleQualified :: - routes - :- Summary "Get a prekey for each client of a user." - :> ZUser - :> "users" - :> QualifiedCaptureUserId "uid" - :> "prekeys" - :> Get '[JSON] PrekeyBundle, - getMultiUserPrekeyBundleUnqualified :: - routes - :- Summary - "(deprecated) Given a map of user IDs to client IDs return a \ - \prekey for each one. You can't request information for more users than \ - \maximum conversation size." - :> ZUser - :> "users" - :> "prekeys" - :> ReqBody '[JSON] UserClients - :> Post '[JSON] UserClientPrekeyMap, - getMultiUserPrekeyBundleQualified :: - routes - :- Summary - "Given a map of domain to (map of user IDs to client IDs) return a \ - \prekey for each one. You can't request information for more users than \ - \maximum conversation size." - :> ZUser - :> "users" - :> "list-prekeys" - :> ReqBody '[JSON] QualifiedUserClients - :> Post '[JSON] QualifiedUserClientPrekeyMap, - -- User Client API ---------------------------------------------------- + :> Get '[JSON] ClientPrekey + ) + :<|> Named + "get-users-prekeys-client-qualified" + ( Summary "Get a prekey for a specific client of a user." + :> ZUser + :> "users" + :> QualifiedCaptureUserId "uid" + :> "prekeys" + :> CaptureClientId "client" + :> Get '[JSON] ClientPrekey + ) + :<|> Named + "get-users-prekey-bundle-unqualified" + ( Summary "(deprecated) Get a prekey for each client of a user." + :> ZUser + :> "users" + :> CaptureUserId "uid" + :> "prekeys" + :> Get '[JSON] PrekeyBundle + ) + :<|> Named + "get-users-prekey-bundle-qualified" + ( Summary "Get a prekey for each client of a user." + :> ZUser + :> "users" + :> QualifiedCaptureUserId "uid" + :> "prekeys" + :> Get '[JSON] PrekeyBundle + ) + :<|> Named + "get-multi-user-prekey-bundle-unqualified" + ( Summary + "(deprecated) Given a map of user IDs to client IDs return a \ + \prekey for each one. You can't request information for more users than \ + \maximum conversation size." + :> ZUser + :> "users" + :> "prekeys" + :> ReqBody '[JSON] UserClients + :> Post '[JSON] UserClientPrekeyMap + ) + :<|> Named + "get-multi-user-prekey-bundle-qualified" + ( Summary + "Given a map of domain to (map of user IDs to client IDs) return a \ + \prekey for each one. You can't request information for more users than \ + \maximum conversation size." + :> ZUser + :> "users" + :> "list-prekeys" + :> ReqBody '[JSON] QualifiedUserClients + :> Post '[JSON] QualifiedUserClientPrekeyMap + ) - -- This endpoint can lead to the following events being sent: - -- - ClientAdded event to self - -- - ClientRemoved event to self, if removing old clients due to max number - addClient :: - routes :- Summary "Register a new client" +type UserClientAPI = + -- User Client API ---------------------------------------------------- + + -- This endpoint can lead to the following events being sent: + -- - ClientAdded event to self + -- - ClientRemoved event to self, if removing old clients due to max number + Named + "add-client" + ( Summary "Register a new client" :> CanThrow TooManyClients :> CanThrow MissingAuth :> CanThrow MalformedPrekeys @@ -394,66 +383,138 @@ data Api routes = Api :> "clients" :> Header "X-Forwarded-For" IpAddr :> ReqBody '[JSON] NewClient - :> Verb 'POST 201 '[JSON] NewClientResponse, - updateClient :: - routes :- Summary "Update a registered client" - :> CanThrow MalformedPrekeys - :> ZUser - :> "clients" - :> CaptureClientId "client" - :> ReqBody '[JSON] UpdateClient - :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Client updated"] (), + :> Verb 'POST 201 '[JSON] NewClientResponse + ) + :<|> Named + "update-client" + ( Summary "Update a registered client" + :> CanThrow MalformedPrekeys + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> ReqBody '[JSON] UpdateClient + :> MultiVerb 'PUT '[JSON] '[RespondEmpty 200 "Client updated"] () + ) + :<|> -- This endpoint can lead to the following events being sent: -- - ClientRemoved event to self - deleteClient :: - routes :- Summary "Delete an existing client" - :> ZUser - :> ZConn - :> "clients" - :> CaptureClientId "client" - :> ReqBody '[JSON] RmClient - :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Client deleted"] (), - listClients :: - routes :- Summary "List the registered clients" - :> ZUser - :> "clients" - :> Get '[JSON] [Client], - getClient :: - routes :- Summary "Get a registered client by ID" - :> ZUser - :> "clients" - :> CaptureClientId "client" - :> MultiVerb - 'GET - '[JSON] - '[ EmptyErrorForLegacyReasons 404 "Client not found", - Respond 200 "Client found" Client - ] - (Maybe Client), - getClientCapabilities :: - routes :- Summary "Read back what the client has been posting about itself" - :> ZUser - :> "clients" - :> CaptureClientId "client" - :> "capabilities" - :> Get '[JSON] ClientCapabilityList, - getClientPrekeys :: - routes :- Summary "List the remaining prekey IDs of a client" - :> ZUser + Named + "delete-client" + ( Summary "Delete an existing client" + :> ZUser + :> ZConn + :> "clients" + :> CaptureClientId "client" + :> ReqBody '[JSON] RmClient + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 200 "Client deleted"] () + ) + :<|> Named + "list-clients" + ( Summary "List the registered clients" + :> ZUser + :> "clients" + :> Get '[JSON] [Client] + ) + :<|> Named + "get-client" + ( Summary "Get a registered client by ID" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> MultiVerb + 'GET + '[JSON] + '[ EmptyErrorForLegacyReasons 404 "Client not found", + Respond 200 "Client found" Client + ] + (Maybe Client) + ) + :<|> Named + "get-client-capabilities" + ( Summary "Read back what the client has been posting about itself" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> "capabilities" + :> Get '[JSON] ClientCapabilityList + ) + :<|> Named + "get-client-prekeys" + ( Summary "List the remaining prekey IDs of a client" + :> ZUser + :> "clients" + :> CaptureClientId "client" + :> "prekeys" + :> Get '[JSON] [PrekeyId] + ) + +type ClientAPI = + Named + "get-user-clients-unqualified" + ( Summary "Get all of a user's clients (deprecated)." + :> "users" + :> CaptureUserId "uid" :> "clients" - :> CaptureClientId "client" - :> "prekeys" - :> Get '[JSON] [PrekeyId], - -- Connection API ----------------------------------------------------- - -- - -- This endpoint can lead to the following events being sent: - -- - ConnectionUpdated event to self and other, if any side's connection state changes - -- - MemberJoin event to self and other, if joining an existing connect conversation (via galley) - -- - ConvCreate event to self, if creating a connect conversation (via galley) - -- - ConvConnect event to self, in some cases (via galley), - -- for details see 'Galley.API.Create.createConnectConversation' - createConnectionUnqualified :: - routes :- Summary "Create a connection to another user. (deprecated)" + :> Get '[JSON] [PubClient] + ) + :<|> Named + "get-user-clients-qualified" + ( Summary "Get all of a user's clients." + :> "users" + :> QualifiedCaptureUserId "uid" + :> "clients" + :> Get '[JSON] [PubClient] + ) + :<|> Named + "get-user-client-unqualified" + ( Summary "Get a specific client of a user (deprecated)." + :> "users" + :> CaptureUserId "uid" + :> "clients" + :> CaptureClientId "client" + :> Get '[JSON] PubClient + ) + :<|> Named + "get-user-client-qualified" + ( Summary "Get a specific client of a user." + :> "users" + :> QualifiedCaptureUserId "uid" + :> "clients" + :> CaptureClientId "client" + :> Get '[JSON] PubClient + ) + :<|> Named + "list-clients-bulk" + ( Summary "List all clients for a set of user ids (deprecated, use /users/list-clients/v2)" + :> ZUser + :> "users" + :> "list-clients" + :> ReqBody '[JSON] (Range 1 MaxUsersForListClientsBulk [Qualified UserId]) + :> Post '[JSON] (QualifiedUserMap (Set PubClient)) + ) + :<|> Named + "list-clients-bulk-v2" + ( Summary "List all clients for a set of user ids" + :> ZUser + :> "users" + :> "list-clients" + :> "v2" + :> ReqBody '[JSON] (LimitedQualifiedUserIdList MaxUsersForListClientsBulk) + :> Post '[JSON] (WrappedQualifiedUserMap (Set PubClient)) + ) + +-- Connection API ----------------------------------------------------- +-- +-- This endpoint can lead to the following events being sent: +-- - ConnectionUpdated event to self and other, if any side's connection state changes +-- - MemberJoin event to self and other, if joining an existing connect conversation (via galley) +-- - ConvCreate event to self, if creating a connect conversation (via galley) +-- - ConvConnect event to self, in some cases (via galley), +-- for details see 'Galley.API.Create.createConnectConversation' +type ConnectionAPI = + Named + "create-connection-unqualified" + ( Summary "Create a connection to another user (deprecated)" :> CanThrow MissingLegalholdConsent :> CanThrow InvalidUser :> CanThrow ConnectionLimitReached @@ -471,125 +532,142 @@ data Api routes = Api 'POST '[JSON] (ResponsesForExistedCreated "Connection existed" "Connection was created" UserConnection) - (ResponseForExistedCreated UserConnection), - createConnection :: - routes :- Summary "Create a connection to another user" - :> CanThrow MissingLegalholdConsent - :> CanThrow InvalidUser - :> CanThrow ConnectionLimitReached - :> CanThrow NoIdentity - -- Config value 'setUserMaxConnections' value in production/by default - -- is currently 1000 and has not changed in the last few years. - -- While it would be more correct to use the config value here, that - -- might not be time well spent. - :> Description "You can have no more than 1000 connections in accepted or sent state" - :> ZUser - :> ZConn - :> "connections" - :> QualifiedCaptureUserId "uid" - :> MultiVerb - 'POST - '[JSON] - (ResponsesForExistedCreated "Connection existed" "Connection was created" UserConnection) - (ResponseForExistedCreated UserConnection), - listLocalConnections :: - routes :- Summary "List the local connections to other users. (deprecated)" - :> ZUser - :> "connections" - :> QueryParam' '[Optional, Strict, Description "User ID to start from when paginating"] "start" UserId - :> QueryParam' '[Optional, Strict, Description "Number of results to return (default 100, max 500)"] "size" (Range 1 500 Int32) - :> Get '[JSON] UserConnectionList, - listConnections :: - routes :- Summary "List the connections to other users, including remote users." - :> ZUser - :> "list-connections" - :> ReqBody '[JSON] ListConnectionsRequestPaginated - :> Post '[JSON] ConnectionsPage, - getConnectionUnqualified :: - routes :- Summary "Get an existing connection to another user. (deprecated)" - :> ZUser - :> "connections" - :> CaptureUserId "uid" - :> MultiVerb - 'GET - '[JSON] - '[ EmptyErrorForLegacyReasons 404 "Connection not found", - Respond 200 "Connection found" UserConnection - ] - (Maybe UserConnection), - getConnection :: - routes :- Summary "Get an existing connection to another user (local or remote)." - :> ZUser - :> "connections" - :> QualifiedCaptureUserId "uid" - :> MultiVerb - 'GET - '[JSON] - '[ EmptyErrorForLegacyReasons 404 "Connection not found", - Respond 200 "Connection found" UserConnection - ] - (Maybe UserConnection), + (ResponseForExistedCreated UserConnection) + ) + :<|> Named + "create-connection" + ( Summary "Create a connection to another user" + :> CanThrow MissingLegalholdConsent + :> CanThrow InvalidUser + :> CanThrow ConnectionLimitReached + :> CanThrow NoIdentity + -- Config value 'setUserMaxConnections' value in production/by default + -- is currently 1000 and has not changed in the last few years. + -- While it would be more correct to use the config value here, that + -- might not be time well spent. + :> Description "You can have no more than 1000 connections in accepted or sent state" + :> ZUser + :> ZConn + :> "connections" + :> QualifiedCaptureUserId "uid" + :> MultiVerb + 'POST + '[JSON] + (ResponsesForExistedCreated "Connection existed" "Connection was created" UserConnection) + (ResponseForExistedCreated UserConnection) + ) + :<|> Named + "list-local-connections" + ( Summary "List the local connections to other users (deprecated)" + :> ZUser + :> "connections" + :> QueryParam' '[Optional, Strict, Description "User ID to start from when paginating"] "start" UserId + :> QueryParam' '[Optional, Strict, Description "Number of results to return (default 100, max 500)"] "size" (Range 1 500 Int32) + :> Get '[JSON] UserConnectionList + ) + :<|> Named + "list-connections" + ( Summary "List the connections to other users, including remote users" + :> ZUser + :> "list-connections" + :> ReqBody '[JSON] ListConnectionsRequestPaginated + :> Post '[JSON] ConnectionsPage + ) + :<|> Named + "get-connection-unqualified" + ( Summary "Get an existing connection to another user (deprecated)" + :> ZUser + :> "connections" + :> CaptureUserId "uid" + :> MultiVerb + 'GET + '[JSON] + '[ EmptyErrorForLegacyReasons 404 "Connection not found", + Respond 200 "Connection found" UserConnection + ] + (Maybe UserConnection) + ) + :<|> Named + "get-connection" + ( Summary "Get an existing connection to another user (local or remote)" + :> ZUser + :> "connections" + :> QualifiedCaptureUserId "uid" + :> MultiVerb + 'GET + '[JSON] + '[ EmptyErrorForLegacyReasons 404 "Connection not found", + Respond 200 "Connection found" UserConnection + ] + (Maybe UserConnection) + ) + :<|> -- This endpoint can lead to the following events being sent: -- - ConnectionUpdated event to self and other, if their connection states change -- -- When changing the connection state to Sent or Accepted, this can cause events to be sent -- when joining the connect conversation: -- - MemberJoin event to self and other (via galley) - updateConnectionUnqualified :: - routes :- Summary "Update a connection to another user. (deprecated)" - :> CanThrow MissingLegalholdConsent - :> CanThrow InvalidUser - :> CanThrow ConnectionLimitReached - :> CanThrow NotConnected - :> CanThrow InvalidTransition - :> CanThrow NoIdentity - :> ZUser - :> ZConn - :> "connections" - :> CaptureUserId "uid" - :> ReqBody '[JSON] ConnectionUpdate - :> MultiVerb - 'PUT - '[JSON] - ConnectionUpdateResponses - (UpdateResult UserConnection), + Named + "update-connection-unqualified" + ( Summary "Update a connection to another user (deprecated)" + :> CanThrow MissingLegalholdConsent + :> CanThrow InvalidUser + :> CanThrow ConnectionLimitReached + :> CanThrow NotConnected + :> CanThrow InvalidTransition + :> CanThrow NoIdentity + :> ZUser + :> ZConn + :> "connections" + :> CaptureUserId "uid" + :> ReqBody '[JSON] ConnectionUpdate + :> MultiVerb + 'PUT + '[JSON] + ConnectionUpdateResponses + (UpdateResult UserConnection) + ) + :<|> -- This endpoint can lead to the following events being sent: -- - ConnectionUpdated event to self and other, if their connection states change -- -- When changing the connection state to Sent or Accepted, this can cause events to be sent -- when joining the connect conversation: -- - MemberJoin event to self and other (via galley) - updateConnection :: - routes :- Summary "Update a connection to another user. (deprecated)" - :> CanThrow MissingLegalholdConsent - :> CanThrow InvalidUser - :> CanThrow ConnectionLimitReached - :> CanThrow NotConnected - :> CanThrow InvalidTransition - :> CanThrow NoIdentity - :> ZUser - :> ZConn - :> "connections" - :> QualifiedCaptureUserId "uid" - :> ReqBody '[JSON] ConnectionUpdate - :> MultiVerb - 'PUT - '[JSON] - ConnectionUpdateResponses - (UpdateResult UserConnection), - searchContacts :: - routes :- Summary "Search for users" - :> ZUser - :> "search" - :> "contacts" - :> QueryParam' '[Required, Strict, Description "Search query"] "q" Text - :> QueryParam' '[Optional, Strict, Description "Searched domain. Note: This is optional only for backwards compatibility, future versions will mandate this."] "domain" Domain - :> QueryParam' '[Optional, Strict, Description "Number of results to return (min: 1, max: 500, default 15)"] "size" (Range 1 500 Int32) - :> Get '[Servant.JSON] (SearchResult Contact) - } - deriving (Generic) + Named + "update-connection" + ( Summary "Update a connection to another user (deprecatd)" + :> CanThrow MissingLegalholdConsent + :> CanThrow InvalidUser + :> CanThrow ConnectionLimitReached + :> CanThrow NotConnected + :> CanThrow InvalidTransition + :> CanThrow NoIdentity + :> ZUser + :> ZConn + :> "connections" + :> QualifiedCaptureUserId "uid" + :> ReqBody '[JSON] ConnectionUpdate + :> MultiVerb + 'PUT + '[JSON] + ConnectionUpdateResponses + (UpdateResult UserConnection) + ) + :<|> Named + "search-contacts" + ( Summary "Search for users" + :> ZUser + :> "search" + :> "contacts" + :> QueryParam' '[Required, Strict, Description "Search query"] "q" Text + :> QueryParam' '[Optional, Strict, Description "Searched domain. Note: This is optional only for backwards compatibility, future versions will mandate this."] "domain" Domain + :> QueryParam' '[Optional, Strict, Description "Number of results to return (min: 1, max: 500, default 15)"] "size" (Range 1 500 Int32) + :> Get '[Servant.JSON] (SearchResult Contact) + ) -type ServantAPI = ToServantApi Api +type BrigAPI = UserAPI :<|> SelfAPI :<|> ClientAPI :<|> PrekeyAPI :<|> UserClientAPI :<|> ConnectionAPI -swagger :: Swagger -swagger = toSwagger (Proxy @ServantAPI) +brigSwagger :: Swagger +brigSwagger = toSwagger (Proxy @BrigAPI) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 850705a433d..3d46601e1c5 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -22,7 +22,6 @@ module Brig.API.Public apiDocs, servantSitemap, swaggerDocsAPI, - ServantAPI, SwaggerDocsAPI, ) where @@ -93,7 +92,6 @@ import qualified Network.Wai.Utilities.Swagger as Doc import Network.Wai.Utilities.ZAuth (zauthConnId, zauthUserId) import Servant hiding (Handler, JSON, addHeader, respond) import qualified Servant -import Servant.Server.Generic (genericServerT) import Servant.Swagger.Internal.Orphans () import Servant.Swagger.UI import qualified System.Logger.Class as Log @@ -102,8 +100,8 @@ import qualified Wire.API.Connection as Public import Wire.API.ErrorDescription import qualified Wire.API.Properties as Public import qualified Wire.API.Routes.MultiTablePaging as Public -import Wire.API.Routes.Public.Brig (Api (updateConnectionUnqualified)) -import qualified Wire.API.Routes.Public.Brig as BrigAPI +import Wire.API.Routes.Named +import Wire.API.Routes.Public.Brig import qualified Wire.API.Routes.Public.Cannon as CannonAPI import qualified Wire.API.Routes.Public.Cargohold as CargoholdAPI import qualified Wire.API.Routes.Public.Galley as GalleyAPI @@ -128,12 +126,10 @@ import qualified Wire.API.Wrapped as Public type SwaggerDocsAPI = "api" :> SwaggerSchemaUI "swagger-ui" "swagger.json" -type ServantAPI = BrigAPI.ServantAPI - swaggerDocsAPI :: Servant.Server SwaggerDocsAPI swaggerDocsAPI = swaggerSchemaUIServer $ - ( BrigAPI.swagger + ( brigSwagger <> GalleyAPI.swaggerDoc <> LegalHoldAPI.swaggerDoc <> SparAPI.swaggerDoc @@ -162,56 +158,71 @@ swaggerDocsAPI = . (S.required %~ nubOrd) . (S.enum_ . _Just %~ nub) -servantSitemap :: ServerT ServantAPI Handler -servantSitemap = - genericServerT $ - BrigAPI.Api - { BrigAPI.getUserUnqualified = getUserUnqualifiedH, - BrigAPI.getUserQualified = getUser, - BrigAPI.getSelf = getSelf, - BrigAPI.deleteSelf = deleteUser, - BrigAPI.putSelf = updateUser, - BrigAPI.changePhone = changePhone, - BrigAPI.removePhone = removePhone, - BrigAPI.removeEmail = removeEmail, - BrigAPI.checkPasswordExists = checkPasswordExists, - BrigAPI.changePassword = changePassword, - BrigAPI.changeLocale = changeLocale, - BrigAPI.changeHandle = changeHandle, - BrigAPI.updateUserEmail = updateUserEmail, - BrigAPI.getHandleInfoUnqualified = getHandleInfoUnqualifiedH, - BrigAPI.getUserByHandleQualified = Handle.getHandleInfo, - BrigAPI.listUsersByUnqualifiedIdsOrHandles = listUsersByUnqualifiedIdsOrHandles, - BrigAPI.listUsersByIdsOrHandles = listUsersByIdsOrHandles, - BrigAPI.getUserClientsUnqualified = getUserClientsUnqualified, - BrigAPI.getUserClientsQualified = getUserClientsQualified, - BrigAPI.getUserClientUnqualified = getUserClientUnqualified, - BrigAPI.getUserClientQualified = getUserClientQualified, - BrigAPI.listClientsBulk = listClientsBulk, - BrigAPI.listClientsBulkV2 = listClientsBulkV2, - BrigAPI.getUsersPrekeysClientUnqualified = getPrekeyUnqualifiedH, - BrigAPI.getUsersPrekeysClientQualified = getPrekeyH, - BrigAPI.getUsersPrekeyBundleUnqualified = getPrekeyBundleUnqualifiedH, - BrigAPI.getUsersPrekeyBundleQualified = getPrekeyBundleH, - BrigAPI.getMultiUserPrekeyBundleUnqualified = getMultiUserPrekeyBundleUnqualifiedH, - BrigAPI.getMultiUserPrekeyBundleQualified = getMultiUserPrekeyBundleH, - BrigAPI.addClient = addClient, - BrigAPI.updateClient = updateClient, - BrigAPI.deleteClient = deleteClient, - BrigAPI.listClients = listClients, - BrigAPI.getClient = getClient, - BrigAPI.getClientCapabilities = getClientCapabilities, - BrigAPI.getClientPrekeys = getClientPrekeys, - BrigAPI.createConnectionUnqualified = createConnectionUnqualified, - BrigAPI.createConnection = createConnection, - BrigAPI.listLocalConnections = listLocalConnections, - BrigAPI.listConnections = listConnections, - BrigAPI.getConnectionUnqualified = getLocalConnection, - BrigAPI.getConnection = getConnection, - BrigAPI.updateConnectionUnqualified = updateLocalConnection, - BrigAPI.updateConnection = updateConnection, - BrigAPI.searchContacts = Search.search - } +servantSitemap :: ServerT BrigAPI Handler +servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI + where + userAPI :: ServerT UserAPI Handler + userAPI = + Named @"get-user-unqualified" getUserUnqualifiedH + :<|> Named @"get-user-qualified" getUser + :<|> Named @"update-user-email" updateUserEmail + :<|> Named @"get-handle-info-unqualified" getHandleInfoUnqualifiedH + :<|> Named @"get-user-by-handle-qualified" Handle.getHandleInfo + :<|> Named @"list-users-by-unqualified-ids-or-handles" listUsersByUnqualifiedIdsOrHandles + :<|> Named @"list-users-by-ids-or-handles" listUsersByIdsOrHandles + + selfAPI :: ServerT SelfAPI Handler + selfAPI = + Named @"get-self" getSelf + :<|> Named @"delete-self" deleteUser + :<|> Named @"put-self" updateUser + :<|> Named @"change-phone" changePhone + :<|> Named @"remove-phone" removePhone + :<|> Named @"remove-email" removeEmail + :<|> Named @"check-password-exists" checkPasswordExists + :<|> Named @"change-password" changePassword + :<|> Named @"change-locale" changeLocale + :<|> Named @"change-handle" changeHandle + + clientAPI :: ServerT ClientAPI Handler + clientAPI = + Named @"get-user-clients-unqualified" getUserClientsUnqualified + :<|> Named @"get-user-clients-qualified" getUserClientsQualified + :<|> Named @"get-user-client-unqualified" getUserClientUnqualified + :<|> Named @"get-user-client-qualified" getUserClientQualified + :<|> Named @"list-clients-bulk" listClientsBulk + :<|> Named @"list-clients-bulk-v2" listClientsBulkV2 + + prekeyAPI :: ServerT PrekeyAPI Handler + prekeyAPI = + Named @"get-users-prekeys-client-unqualified" getPrekeyUnqualifiedH + :<|> Named @"get-users-prekeys-client-qualified" getPrekeyH + :<|> Named @"get-users-prekey-bundle-unqualified" getPrekeyBundleUnqualifiedH + :<|> Named @"get-users-prekey-bundle-qualified" getPrekeyBundleH + :<|> Named @"get-multi-user-prekey-bundle-unqualified" getMultiUserPrekeyBundleUnqualifiedH + :<|> Named @"get-multi-user-prekey-bundle-qualified" getMultiUserPrekeyBundleH + + userClientAPI :: ServerT UserClientAPI Handler + userClientAPI = + Named @"add-client" addClient + :<|> Named @"update-client" updateClient + :<|> Named @"delete-client" deleteClient + :<|> Named @"list-clients" listClients + :<|> Named @"get-client" getClient + :<|> Named @"get-client-capabilities" getClientCapabilities + :<|> Named @"get-client-prekeys" getClientPrekeys + + connectionAPI :: ServerT ConnectionAPI Handler + connectionAPI = + Named @"create-connection-unqualified" createConnectionUnqualified + :<|> Named @"create-connection" createConnection + :<|> Named @"list-local-connections" listLocalConnections + :<|> Named @"list-connections" listConnections + :<|> Named @"get-connection-unqualified" getLocalConnection + :<|> Named @"get-connection" getConnection + :<|> Named @"update-connection-unqualified" updateLocalConnection + :<|> Named @"update-connection" updateConnection + :<|> Named @"search-contacts" Search.search -- Note [ephemeral user sideeffect] -- If the user is ephemeral and expired, it will be removed upon calling @@ -588,14 +599,14 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do throwErrorDescriptionType @TooManyClients API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError -addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> Handler BrigAPI.NewClientResponse +addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> Handler NewClientResponse addClient usr con ip new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ throwE (clientError ClientLegalHoldCannotBeAdded) clientResponse <$> API.addClient usr (Just con) (ipAddr <$> ip) new !>> clientError where - clientResponse :: Public.Client -> BrigAPI.NewClientResponse + clientResponse :: Public.Client -> NewClientResponse clientResponse client = Servant.addHeader (Public.clientId client) client deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> Handler () @@ -626,11 +637,11 @@ getUserClientUnqualified uid cid = do x <- API.lookupPubClient (Qualified uid localdomain) cid !>> clientError ifNothing (notFound "client not found") x -listClientsBulk :: UserId -> Range 1 BrigAPI.MaxUsersForListClientsBulk [Qualified UserId] -> Handler (Public.QualifiedUserMap (Set Public.PubClient)) +listClientsBulk :: UserId -> Range 1 MaxUsersForListClientsBulk [Qualified UserId] -> Handler (Public.QualifiedUserMap (Set Public.PubClient)) listClientsBulk _zusr limitedUids = API.lookupPubClientsBulk (fromRange limitedUids) !>> clientError -listClientsBulkV2 :: UserId -> Public.LimitedQualifiedUserIdList BrigAPI.MaxUsersForListClientsBulk -> Handler (Public.WrappedQualifiedUserMap (Set Public.PubClient)) +listClientsBulkV2 :: UserId -> Public.LimitedQualifiedUserIdList MaxUsersForListClientsBulk -> Handler (Public.WrappedQualifiedUserMap (Set Public.PubClient)) listClientsBulkV2 zusr userIds = Public.Wrapped <$> listClientsBulk zusr (Public.qualifiedUsers userIds) getUserClientQualified :: Qualified UserId -> ClientId -> Handler Public.PubClient diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 579b5746b47..f4352769120 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -27,7 +27,7 @@ import Brig.API (sitemap) import Brig.API.Federation import Brig.API.Handler import qualified Brig.API.Internal as IAPI -import Brig.API.Public (ServantAPI, SwaggerDocsAPI, servantSitemap, swaggerDocsAPI) +import Brig.API.Public (SwaggerDocsAPI, servantSitemap, swaggerDocsAPI) import qualified Brig.API.User as API import Brig.AWS (sesQueue) import qualified Brig.AWS as AWS @@ -68,6 +68,7 @@ import qualified Servant import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options +import Wire.API.Routes.Public.Brig -- FUTUREWORK: If any of these async threads die, we will have no clue about it -- and brig could start misbehaving. We should ensure that brig dies whenever a @@ -123,7 +124,7 @@ mkApp o = do (Proxy @ServantCombinedAPI) (customFormatters :. Servant.EmptyContext) ( swaggerDocsAPI - :<|> Servant.hoistServer (Proxy @ServantAPI) (toServantHandler e) servantSitemap + :<|> Servant.hoistServer (Proxy @BrigAPI) (toServantHandler e) servantSitemap :<|> Servant.hoistServer (Proxy @IAPI.API) (toServantHandler e) IAPI.servantSitemap :<|> Servant.hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap :<|> Servant.Tagged (app e) @@ -131,7 +132,7 @@ mkApp o = do type ServantCombinedAPI = ( SwaggerDocsAPI - :<|> ServantAPI + :<|> BrigAPI :<|> IAPI.API :<|> FederationAPI :<|> Servant.Raw From e8595a0e712f0050da98af82ed0537069247edfa Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 4 Feb 2022 09:57:03 +0100 Subject: [PATCH 12/58] SQSERVICES 1239 remove unused locale setting in brig's values.yaml (#2099) * removed redundant setDefaultTemplateLocale from brig config * changelog --- changelog.d/5-internal/pr-2099 | 1 + charts/brig/templates/configmap.yaml | 1 - charts/brig/values.yaml | 1 - services/brig/brig.integration.yaml | 1 - 4 files changed, 1 insertion(+), 3 deletions(-) create mode 100644 changelog.d/5-internal/pr-2099 diff --git a/changelog.d/5-internal/pr-2099 b/changelog.d/5-internal/pr-2099 new file mode 100644 index 00000000000..22d10b62f50 --- /dev/null +++ b/changelog.d/5-internal/pr-2099 @@ -0,0 +1 @@ +Removed redundant `setDefaultTemplateLocale` config from the brig helm template. diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index f2374810aba..2a1e2402c31 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -204,7 +204,6 @@ data: suspendTimeout: {{ .setSuspendInactiveUsers.suspendTimeout }} {{- end }} setRichInfoLimit: {{ .setRichInfoLimit }} - setDefaultTemplateLocale: en setDefaultUserLocale: {{ .setDefaultUserLocale }} setMaxTeamSize: {{ .setMaxTeamSize }} setMaxConvSize: {{ .setMaxConvSize }} diff --git a/charts/brig/values.yaml b/charts/brig/values.yaml index bb67cc4c495..9751bc1cff1 100644 --- a/charts/brig/values.yaml +++ b/charts/brig/values.yaml @@ -63,7 +63,6 @@ config: stdDev: 3000 retryAfter: 86400 setRichInfoLimit: 5000 - setDefaultTemplateLocale: en setDefaultUserLocale: en setMaxTeamSize: 500 setMaxConvSize: 500 diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index fa2d13ffe14..57a98b11fef 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -152,7 +152,6 @@ optSettings: setSuspendInactiveUsers: # if this is omitted: never suspend inactive users. suspendTimeout: 10 setRichInfoLimit: 5000 # should be in sync with Spar - setDefaultTemplateLocale: en setDefaultUserLocale: en setMaxTeamSize: 32 setMaxConvSize: 16 From 8d2a0f85c9a019c0d757d760be0b02c57d8dbea5 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Fri, 4 Feb 2022 15:36:28 +0100 Subject: [PATCH 13/58] Servantify Cannon's internal API (#2081) * Single notification pushes are strict in their HTTP body The websockets library does not support streaming (https://github.com/jaspervdj/websockets/issues/119). So, there is no value in superficially transforming data to a stream that later won't be streamed. However, WebSocketsData enables us to be polymorphic in the message type, i.e. let the endpoints type decide what to use. This would make streaming easier to enable (if it's ever implemented by the library) and safes us from some nasty conversion code. * Forward the pushed notification as is This reflects the prior behavior of Cannon (that should not change). The type RawJson represents json content as plain text. --- cabal.project | 18 +-- .../5-internal/servantify-cannon-internal-api | 1 + .../wire-api/src/Wire/API/ErrorDescription.hs | 4 + libs/wire-api/src/Wire/API/RawJson.hs | 29 ++++ .../src/Wire/API/Routes/Public/Cannon.hs | 34 ++-- libs/wire-api/wire-api.cabal | 1 + services/cannon/cannon.cabal | 2 + services/cannon/package.yaml | 2 + services/cannon/src/Cannon/API/Internal.hs | 151 +++++++++++------- services/cannon/src/Cannon/API/Public.hs | 10 +- services/cannon/src/Cannon/App.hs | 2 +- services/cannon/src/Cannon/Run.hs | 19 ++- services/cannon/src/Cannon/WS.hs | 26 +-- services/cannon/test/Main.hs | 7 +- .../test/unit/Test/Federator/Client.hs | 2 +- services/gundeck/test/integration/API.hs | 21 ++- stack.yaml | 6 +- stack.yaml.lock | 54 +++---- 18 files changed, 246 insertions(+), 143 deletions(-) create mode 100644 changelog.d/5-internal/servantify-cannon-internal-api create mode 100644 libs/wire-api/src/Wire/API/RawJson.hs diff --git a/cabal.project b/cabal.project index be2bc1ee317..09c5a8a6a80 100644 --- a/cabal.project +++ b/cabal.project @@ -69,6 +69,15 @@ source-repository-package location: https://github.com/haskell-servant/servant-swagger tag: bb0a84faa073fa9530f60337610d7da3d5b9393c +source-repository-package + type: git + location: https://github.com/haskell-servant/servant.git + tag: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 + subdir: servant + servant-client + servant-client-core + servant-server + source-repository-package type: git location: https://github.com/kim/hs-collectd @@ -142,15 +151,6 @@ source-repository-package location: https://github.com/wireapp/saml2-web-sso tag: 4227e38be5c0810012dc472fc6931f6087fbce68 -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 diff --git a/changelog.d/5-internal/servantify-cannon-internal-api b/changelog.d/5-internal/servantify-cannon-internal-api new file mode 100644 index 00000000000..ee053807a07 --- /dev/null +++ b/changelog.d/5-internal/servantify-cannon-internal-api @@ -0,0 +1 @@ +Migrate the internal API of Cannon to Servant. diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 99e5fbe2a98..df14482b916 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -354,3 +354,7 @@ type ChangePasswordMustDiffer = ErrorDescription 409 "password-must-differ" "For type HandleExists = ErrorDescription 409 "handle-exists" "The given handle is already taken." type InvalidHandle = ErrorDescription 400 "invalid-handle" "The given handle is invalid." + +type PresenceNotRegistered = ErrorDescription 404 "not-found" "presence not registered" + +type ClientGone = ErrorDescription 410 "general" "client gone" diff --git a/libs/wire-api/src/Wire/API/RawJson.hs b/libs/wire-api/src/Wire/API/RawJson.hs new file mode 100644 index 00000000000..295202c1ed0 --- /dev/null +++ b/libs/wire-api/src/Wire/API/RawJson.hs @@ -0,0 +1,29 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.RawJson where + +import Imports +import Servant + +-- | Wrap json content as plain 'LByteString' +-- This type is intented to be used to receive json content as 'LByteString'. +-- Warning: There is no validation of the json content. It may be any string. +newtype RawJson = RawJson {rawJsonBytes :: LByteString} + +instance {-# OVERLAPPING #-} MimeUnrender JSON RawJson where + mimeUnrender _ = pure . RawJson diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs index 8f9745b5035..ceacf45518a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs @@ -21,23 +21,27 @@ import Data.Id import Data.Swagger import Servant import Servant.Swagger +import Wire.API.Routes.Named import Wire.API.Routes.Public (ZConn, ZUser) import Wire.API.Routes.WebSocket -type ServantAPI = - Summary "Establish websocket connection" - :> "await" - :> ZUser - :> ZConn - :> QueryParam' - [ Optional, - Strict, - Description "Client ID" - ] - "client" - ClientId - -- FUTUREWORK: Consider higher-level web socket combinator - :> WebSocketPending +type PublicAPI = + Named + "await-notifications" + ( Summary "Establish websocket connection" + :> "await" + :> ZUser + :> ZConn + :> QueryParam' + [ Optional, + Strict, + Description "Client ID" + ] + "client" + ClientId + -- FUTUREWORK: Consider higher-level web socket combinator + :> WebSocketPending + ) swaggerDoc :: Swagger -swaggerDoc = toSwagger (Proxy @ServantAPI) +swaggerDoc = toSwagger (Proxy @PublicAPI) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b358f7bda5f..4a03c4b246a 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -45,6 +45,7 @@ library Wire.API.Provider.Service.Tag Wire.API.Push.Token Wire.API.Push.V2.Token + Wire.API.RawJson Wire.API.Routes.AssetBody Wire.API.Routes.Internal.Brig Wire.API.Routes.Internal.Brig.Connection diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index c8571bd1fa2..afe223905a5 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -85,6 +85,7 @@ library , bilge >=0.12 , bytestring >=0.10 , bytestring-conversion >=0.2 + , conduit >=1.3.4.2 , data-default >=0.5 , data-timeout >=0.3 , exceptions >=0.6 @@ -100,6 +101,7 @@ library , retry >=0.7 , safe-exceptions , servant + , servant-conduit , servant-server , strict >=0.3.2 , swagger >=0.2 diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index c784a2bc4bd..274eca7524b 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -22,6 +22,7 @@ library: - bilge >=0.12 - bytestring >=0.10 - bytestring-conversion >=0.2 + - conduit >=1.3.4.2 - data-default >=0.5 - data-timeout >=0.3 - exceptions >=0.6 @@ -35,6 +36,7 @@ library: - retry >=0.7 - safe-exceptions - servant + - servant-conduit - servant-server - strict >=0.3.2 - swagger >=0.2 diff --git a/services/cannon/src/Cannon/API/Internal.hs b/services/cannon/src/Cannon/API/Internal.hs index de3f20d495b..03c895687a7 100644 --- a/services/cannon/src/Cannon/API/Internal.hs +++ b/services/cannon/src/Cannon/API/Internal.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -16,7 +20,8 @@ -- with this program. If not, see . module Cannon.API.Internal - ( sitemap, + ( InternalAPI, + internalServer, ) where @@ -26,61 +31,82 @@ import Cannon.Types import Cannon.WS import Control.Monad.Catch import Data.Aeson (encode) -import qualified Data.ByteString.Lazy as L -import Data.Id (ConnId, UserId) -import Data.Swagger.Build.Api hiding (Response) +import Data.Id hiding (client) import Gundeck.Types import Gundeck.Types.BulkPush -import Imports hiding (head) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Predicate -import Network.Wai.Routing -import Network.Wai.Utilities +import Imports +import Network.WebSockets +import Servant +import Servant.Conduit () import System.Logger.Class (msg, val) import qualified System.Logger.Class as LC +import Wire.API.ErrorDescription +import Wire.API.RawJson +import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Named -sitemap :: Routes ApiBuilder Cannon () -sitemap = do - get "/i/status" (continue (const $ return empty)) true - head "/i/status" (continue (const $ return empty)) true - - post "/i/push/:user/:conn" (continue pushH) $ - capture "user" .&. capture "conn" .&. request - - post "/i/bulkpush" (continue bulkpushH) $ - request - - head "/i/presences/:uid/:conn" (continue checkPresenceH) $ - param "uid" .&. param "conn" - -pushH :: UserId ::: ConnId ::: Request -> Cannon Response -pushH (user ::: conn ::: req) = - singlePush (readBody req) (PushTarget user conn) >>= \case - PushStatusOk -> return empty - PushStatusGone -> return $ errorRs status410 "general" "client gone" +type InternalAPI = + "i" + :> ( Named + "get-status" + ( "status" + :> MultiVerb + 'GET + '[PlainText] + '[RespondEmpty 200 "Service is alive."] + () + ) + :<|> Named + "push-notification" + ( "push" + :> Capture "user" UserId + :> Capture "conn" ConnId + :> ReqBody '[JSON] RawJson + :> MultiVerb + 'POST + '[JSON] + '[ ClientGone, + RespondEmpty 200 "Successfully pushed." + ] + (Maybe ()) + ) + :<|> Named + "bulk-push-notifications" + ( "bulkpush" + :> ReqBody '[JSON] BulkPushRequest + :> Post '[JSON] BulkPushResponse + ) + :<|> Named + "check-presence" + ( "presences" + :> Capture "uid" UserId + :> Capture "conn" ConnId + :> MultiVerb + 'HEAD + '[JSON] + '[ PresenceNotRegistered, + RespondEmpty 200 "Presence checked successfully." + ] + (Maybe ()) + ) + ) --- | Parse the entire list of notifcations and targets, then call 'singlePush' on the each of them --- in order. -bulkpushH :: Request -> Cannon Response -bulkpushH req = json <$> (parseBody' (JsonRequest req) >>= bulkpush) +internalServer :: ServerT InternalAPI Cannon +internalServer = + Named @"get-status" (pure ()) + :<|> Named @"push-notification" pushHandler + :<|> Named @"bulk-push-notifications" bulkPushHandler + :<|> Named @"check-presence" checkPresenceHandler --- | The typed part of 'bulkpush'. -bulkpush :: BulkPushRequest -> Cannon BulkPushResponse -bulkpush (BulkPushRequest notifs) = - BulkPushResponse . mconcat . zipWith compileResp notifs <$> (uncurry doNotif `mapM` notifs) - where - doNotif :: Notification -> [PushTarget] -> Cannon [PushStatus] - doNotif (pure . encode -> notif) = mapConcurrentlyCannon (singlePush notif) - compileResp :: - (Notification, [PushTarget]) -> - [PushStatus] -> - [(NotificationId, PushTarget, PushStatus)] - compileResp (notif, prcs) pss = zip3 (repeat (ntfId notif)) prcs pss +pushHandler :: UserId -> ConnId -> RawJson -> Cannon (Maybe ()) +pushHandler user conn body = + singlePush (rawJsonBytes body) (PushTarget user conn) >>= \case + PushStatusOk -> pure $ Just () + PushStatusGone -> pure Nothing --- | Take a serialized 'Notification' string and send it to the 'PushTarget'. -singlePush :: Cannon L.ByteString -> PushTarget -> Cannon PushStatus -singlePush notification (PushTarget usrid conid) = do +-- | Take notification @n@ and send it to the 'PushTarget'. +singlePush :: (WebSocketsData a) => a -> PushTarget -> Cannon PushStatus +singlePush n (PushTarget usrid conid) = do let k = mkKey usrid conid d <- clients LC.debug $ client (key2bytes k) . msg (val "push") @@ -91,15 +117,28 @@ singlePush notification (PushTarget usrid conid) = do return PushStatusGone Just x -> do e <- wsenv - b <- notification - runWS e $ - (sendMsg b k x >> return PushStatusOk) - `catchAll` const (terminate k x >> return PushStatusGone) + runWS e $ do + catchAll + (runWS e (sendMsg n k x) >> pure PushStatusOk) + (const (terminate k x >> pure PushStatusGone)) + +bulkPushHandler :: BulkPushRequest -> Cannon BulkPushResponse +bulkPushHandler (BulkPushRequest ns) = + BulkPushResponse . mconcat . zipWith compileResp ns <$> (uncurry doNotify `Imports.mapM` ns) + where + doNotify :: Notification -> [PushTarget] -> Cannon [PushStatus] + doNotify (encode -> notification) = + mapConcurrentlyCannon (singlePush notification) + compileResp :: + (Notification, [PushTarget]) -> + [PushStatus] -> + [(NotificationId, PushTarget, PushStatus)] + compileResp (notif, prcs) pss = zip3 (repeat (ntfId notif)) prcs pss -checkPresenceH :: UserId ::: ConnId -> Cannon Response -checkPresenceH (u ::: c) = do +checkPresenceHandler :: UserId -> ConnId -> Cannon (Maybe ()) +checkPresenceHandler u c = do e <- wsenv registered <- runWS e $ isRemoteRegistered u c if registered - then return empty - else return $ errorRs status404 "not-found" "presence not registered" + then pure $ Just () + else pure Nothing diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index 8e6fff49065..0eb81bf5fb1 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -16,8 +16,7 @@ -- with this program. If not, see . module Cannon.API.Public - ( API, - publicAPIServer, + ( publicAPIServer, ) where @@ -29,12 +28,11 @@ import Data.Id import GHC.Base import Network.WebSockets.Connection import Servant +import Wire.API.Routes.Named import Wire.API.Routes.Public.Cannon -type API = ServantAPI :<|> Raw - -publicAPIServer :: ServerT ServantAPI Cannon -publicAPIServer = streamData +publicAPIServer :: ServerT PublicAPI Cannon +publicAPIServer = Named @"await-notifications" streamData streamData :: UserId -> ConnId -> Maybe ClientId -> PendingConnection -> Cannon () streamData userId connId clientId con = do diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 4435d779e4c..a49e3681911 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -149,7 +149,7 @@ readLoop ws s = loop (DataMessage _ _ _ (Text "ping" _)) -> True (DataMessage _ _ _ (Binary "ping")) -> True _ -> False - sendAppLevelPong = sendMsgIO "pong" ws + sendAppLevelPong = sendMsgIO @ByteString "pong" ws rejectOnError :: PendingConnection -> HandshakeException -> IO a rejectOnError p x = do diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index d4902460d39..1f01bd7a90b 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -17,6 +17,7 @@ module Cannon.Run ( run, + CombinedAPI, ) where @@ -26,7 +27,7 @@ import Cannon.API.Public import Cannon.App (maxPingInterval) import qualified Cannon.Dict as D import Cannon.Options -import Cannon.Types (Cannon, applog, clients, mkEnv, monitor, runCannon, runCannon', runCannonToServant) +import Cannon.Types (Cannon, applog, clients, mkEnv, monitor, runCannon', runCannonToServant) import Cannon.WS hiding (env) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -50,6 +51,8 @@ import qualified System.Logger.Extended as L import System.Random.MWC (createSystemRandom) import Wire.API.Routes.Public.Cannon +type CombinedAPI = PublicAPI :<|> InternalAPI + run :: Opts -> IO () run o = do ext <- loadExternal @@ -66,17 +69,17 @@ run o = do <*> mkClock refreshMetricsThread <- Async.async $ runCannon' e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) m (Just idleTimeout) - let rtree = compile sitemap - internalApp r k = runCannon e (Network.Wai.Utilities.Server.route rtree r k) r - middleware :: Wai.Middleware + let middleware :: Wai.Middleware middleware = - servantPlusWAIPrometheusMiddleware sitemap (Proxy @ServantAPI) + servantPrometheusMiddleware (Proxy @CombinedAPI) . Gzip.gzip Gzip.def . catchErrors g [Right m] app :: Application - app = middleware (serve (Proxy @API) server) - server :: Servant.Server API - server = hoistServer (Proxy @ServantAPI) (runCannonToServant e) publicAPIServer :<|> Tagged internalApp + app = middleware (serve (Proxy @CombinedAPI) server) + server :: Servant.Server CombinedAPI + server = + hoistServer (Proxy @PublicAPI) (runCannonToServant e) publicAPIServer + :<|> hoistServer (Proxy @InternalAPI) (runCannonToServant e) internalServer runSettings s app `finally` do Async.cancel refreshMetricsThread L.close (applog e) diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index 76035acdc4b..cbcaaf0f72d 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -29,7 +29,6 @@ module Cannon.WS unregisterLocal, isRemoteRegistered, registerRemote, - sendMsg, sendMsgIO, Clock, mkClock, @@ -42,6 +41,7 @@ module Cannon.WS mkKey, key2bytes, client, + sendMsg, ) where @@ -50,6 +50,7 @@ import Bilge.RPC import Bilge.Retry import Cannon.Dict (Dict) import qualified Cannon.Dict as D +import Conduit import Control.Concurrent.Timeout import Control.Monad.Catch import Control.Retry @@ -224,16 +225,23 @@ isRemoteRegistered u c = do cs <- map connId <$> parseResponse (mkError status502 "server-error") rs return $ c `elem` cs -sendMsg :: L.ByteString -> Key -> Websocket -> WS () -sendMsg m k c = do - let kb = key2bytes k - trace $ client kb . msg (val "sendMsg: \"" +++ L.take 128 m +++ val "...\"") - liftIO $ sendMsgIO m c - -sendMsgIO :: L.ByteString -> Websocket -> IO () -sendMsgIO m c = do +sendMsgIO :: (WebSocketsData a) => a -> Websocket -> IO () +sendMsgIO m c = recoverAll retry3x $ const $ sendBinaryData (connection c) m +sendMsg :: (WebSocketsData a) => a -> Key -> Websocket -> WS () +sendMsg message k c = do + traceLog message + liftIO $ sendMsgIO message c + where + traceLog :: (WebSocketsData a) => a -> WS () + traceLog m = trace $ client kb . msg (logMsg m) + + logMsg :: (WebSocketsData a) => a -> Builder + logMsg m = val "sendMsgConduit: \"" +++ L.take 128 (toLazyByteString m) +++ val "...\"" + + kb = key2bytes k + close :: Key -> Websocket -> WS () close k c = do let kb = key2bytes k diff --git a/services/cannon/test/Main.hs b/services/cannon/test/Main.hs index cd5591198ab..534aa711a82 100644 --- a/services/cannon/test/Main.hs +++ b/services/cannon/test/Main.hs @@ -17,11 +17,10 @@ module Main where -import qualified Cannon.API.Internal +import Cannon.API.Internal +import Data.Metrics.Servant (routesToPaths) import Data.Metrics.Test (pathsConsistencyCheck) -import Data.Metrics.WaiRoute (treeToPaths) import Imports -import Network.Wai.Utilities.Server (compile) import qualified Test.Cannon.Dict as D import Test.Tasty import Test.Tasty.HUnit @@ -35,6 +34,6 @@ main = assertEqual "inconcistent sitemap" mempty - (pathsConsistencyCheck . treeToPaths . compile $ Cannon.API.Internal.sitemap), + (pathsConsistencyCheck $ routesToPaths @InternalAPI), D.tests ] diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index 225a2dbd071..ddd318e02d2 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -36,7 +36,7 @@ import qualified Network.HTTP2.Client as HTTP2 import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Wai import Servant.API -import Servant.Client +import Servant.Client hiding ((//)) import Servant.Client.Core import Servant.Types.SourceT import Test.QuickCheck (arbitrary, generate) diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 32e509661b7..4dad766a03b 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -76,6 +76,7 @@ tests s = test s "Replace presence" replacePresence, test s "Remove stale presence" removeStalePresence, test s "Single user push" singleUserPush, + test s "Single user push with large message" singleUserPushLargeMessage, test s "Push many to Cannon via bulkpush (via gundeck; group notif)" $ bulkPush False 50 8, test s "Push many to Cannon via bulkpush (via gundeck; e2e notif)" $ bulkPush True 50 8, test s "Send a push, ensure origin does not receive it" sendSingleUserNoPiggyback, @@ -195,7 +196,13 @@ removeStalePresence = do push u us = newPush u (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev") singleUserPush :: TestM () -singleUserPush = do +singleUserPush = testSingleUserPush smallMsgPayload + where + -- JSON: {"foo":42} + smallMsgPayload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] + +testSingleUserPush :: List1 Object -> TestM () +testSingleUserPush msgPayload = do ca <- view tsCannon uid <- randomId ch <- connectUser ca uid =<< randomConnId @@ -205,12 +212,18 @@ singleUserPush = do assertBool "No push message received" (isJust msg) assertEqual "Payload altered during transmission" - (Just pload) + (Just msgPayload) (ntfPayload <$> (decode . fromStrict . fromJust) msg) where - pload = List1.singleton $ HashMap.fromList ["foo" .= (42 :: Int)] - push u us = newPush (Just u) (toRecipients us) pload & pushOriginConnection .~ Just (ConnId "dev") + push u us = newPush (Just u) (toRecipients us) msgPayload & pushOriginConnection .~ Just (ConnId "dev") + +singleUserPushLargeMessage :: TestM () +singleUserPushLargeMessage = testSingleUserPush largeMsgPayload + where + -- JSON: {"list":["1","2", ... ,"10000"]} + largeMsgPayload = List1.singleton $ HashMap.fromList ["list" .= [show i | i <- [1 .. 10000] :: [Int]]] +-- | Create a number of users with a number of connections each, and connect each user's connections -- | Create a number of users with a number of connections each, and connect each user's connections -- to one of two cannons at random. Push either encrypted notifications (@isE2E == True@) or -- notifications from server (@isE2E == False@) to all connections, and make sure they all arrive at diff --git a/stack.yaml b/stack.yaml index 392e1c4906b..ec593380e81 100644 --- a/stack.yaml +++ b/stack.yaml @@ -193,10 +193,10 @@ extra-deps: - git: https://github.com/haskell-servant/servant-swagger commit: bb0a84faa073fa9530f60337610d7da3d5b9393c -# For changes from https://github.com/haskell-servant/servant/pull/1420 +# For changes from https://github.com/haskell-servant/servant/pull/1502 # Not released to hackage yet -- git: https://github.com/wireapp/servant.git - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 +- git: https://github.com/haskell-servant/servant.git + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 subdirs: - servant - servant-server diff --git a/stack.yaml.lock b/stack.yaml.lock index 29788eece7e..93c1f9bb6e5 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -517,55 +517,55 @@ packages: - completed: subdir: servant name: servant - version: 0.18.2 - git: https://github.com/wireapp/servant.git + version: 0.18.3 + git: https://github.com/haskell-servant/servant.git pantry-tree: - size: 2809 - sha256: 22348fceac7bca97f5c349d9db0b157e401ed273d151d8cbcbd767f4d06791e8 - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + size: 2949 + sha256: 091d8a742ea95490b787f497bfa26eaed46733945721396158f571aea7ed6dca + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 original: subdir: servant - git: https://github.com/wireapp/servant.git - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + git: https://github.com/haskell-servant/servant.git + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 - completed: subdir: servant-server name: servant-server - version: 0.18.2 - git: https://github.com/wireapp/servant.git + version: 0.18.3 + git: https://github.com/haskell-servant/servant.git pantry-tree: size: 2727 - sha256: 55d3c9747550555f3861b5fabfe7cc0385c64ccaf3e5b051aa3064bddb8661ad - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + sha256: 43d23c42011f5c3ff3f298b1910d7f2b43a66144e92e2e762b0efffe63634af4 + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 original: subdir: servant-server - git: https://github.com/wireapp/servant.git - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + git: https://github.com/haskell-servant/servant.git + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 - completed: subdir: servant-client name: servant-client - version: 0.18.2 - git: https://github.com/wireapp/servant.git + version: 0.18.3 + git: https://github.com/haskell-servant/servant.git pantry-tree: - size: 1346 - sha256: 9245621a9097c0b4d5ecbd61616d00c69112e1539db8803a0fda010de484e7ba - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + size: 1481 + sha256: 86025a0c5ae0b0da07db48eed1456011ba7c0093f2dbc04b1ef3fe99e1cc0567 + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 original: subdir: servant-client - git: https://github.com/wireapp/servant.git - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + git: https://github.com/haskell-servant/servant.git + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 - completed: subdir: servant-client-core name: servant-client-core - version: 0.18.2 - git: https://github.com/wireapp/servant.git + version: 0.18.3 + git: https://github.com/haskell-servant/servant.git pantry-tree: - size: 1444 - sha256: b5a7abf78d2ee0887bf05d7d4ba71e3c689b65a9b2e7386c394f4bdb6ff8e55d - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + size: 1445 + sha256: 528c07a5fe7d7482636b9e11bbb54d92930a7db3d9635f920f250fed51a8a2fd + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 original: subdir: servant-client-core - git: https://github.com/wireapp/servant.git - commit: a4e15fe75f294816d9ead19ed8a48cae8e0b76e7 + git: https://github.com/haskell-servant/servant.git + commit: 75db4a5327d6d04ae2460bd5ffd008fe16197ba8 - completed: hackage: HsOpenSSL-x509-system-0.1.0.4@sha256:86be72558de4cee8f4e32f9cb8b63610d7624219910cfc205a23326078658676,1777 pantry-tree: From 20759bf05726519534b02d888494a501f9e61818 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 7 Feb 2022 08:24:34 +0100 Subject: [PATCH 14/58] Brig: Delete `GET /self/name` endpoint (#2101) --- changelog.d/1-api-changes/delete-self-name | 1 + libs/wire-api/src/Wire/API/Swagger.hs | 1 - libs/wire-api/src/Wire/API/User/Profile.hs | 7 ------- services/brig/src/Brig/API/Public.hs | 19 ------------------- .../brig/test/integration/API/User/Account.hs | 8 -------- 5 files changed, 1 insertion(+), 35 deletions(-) create mode 100644 changelog.d/1-api-changes/delete-self-name diff --git a/changelog.d/1-api-changes/delete-self-name b/changelog.d/1-api-changes/delete-self-name new file mode 100644 index 00000000000..312f54d95d3 --- /dev/null +++ b/changelog.d/1-api-changes/delete-self-name @@ -0,0 +1 @@ +Delete `GET /self/name` endpoint \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 1aa893026bc..4fbc4ed77ca 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -168,7 +168,6 @@ models = User.Handle.modelCheckHandles, User.Password.modelNewPasswordReset, User.Password.modelCompletePasswordReset, - User.Profile.modelUserDisplayName, User.Profile.modelAsset, User.RichInfo.modelRichInfo, User.RichInfo.modelRichField, diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index bdca14b31e6..b5950500fec 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -48,7 +48,6 @@ module Wire.API.User.Profile noPict, -- * Swagger - modelUserDisplayName, modelAsset, typeManagedBy, ) @@ -89,12 +88,6 @@ newtype Name = Name mkName :: Text -> Either String Name mkName txt = Name . fromRange <$> checkedEitherMsg @_ @1 @128 "Name" txt -modelUserDisplayName :: Doc.Model -modelUserDisplayName = Doc.defineModel "UserDisplayName" $ do - Doc.description "User name" - Doc.property "name" Doc.string' $ - Doc.description "User name" - instance ToSchema Name where schema = Name <$> fromName .= untypedRangedSchema 1 128 schema diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 3d46601e1c5..101008ee77b 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -272,18 +272,6 @@ sitemap = do Doc.response 200 "RichInfo" Doc.end Doc.errorResponse insufficientTeamPermissions - -- User Self API ------------------------------------------------------ - - get "/self/name" (continue getUserDisplayNameH) $ - accept "application" "json" - .&. zauthUserId - document "GET" "selfName" $ do - Doc.summary "Get your profile name" - Doc.returns (Doc.ref Public.modelUserDisplayName) - Doc.response 200 "Profile name found." Doc.end - - -- TODO put where? - -- This endpoint can lead to the following events being sent: -- UserDeleted event to contacts of deleted user -- MemberLeave event to members for all conversations the user was in (via galley) @@ -767,13 +755,6 @@ getUser self qualifiedUserId = do lself <- qualifyLocal self API.lookupProfile lself qualifiedUserId !>> fedError -getUserDisplayNameH :: JSON ::: UserId -> Handler Response -getUserDisplayNameH (_ ::: self) = do - name :: Maybe Public.Name <- lift $ API.lookupName self - return $ case name of - Just n -> json $ object ["name" .= n] - Nothing -> setStatus status404 empty - -- FUTUREWORK: Make servant understand that at least one of these is required listUsersByUnqualifiedIdsOrHandles :: UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> Handler [Public.UserProfile] listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 098c4b831e8..86ebf716563 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -850,14 +850,6 @@ testUserUpdate brig cannon aws = do ) ) . responseJsonMaybe - -- get only the new name - get (brig . path "/self/name" . zUser alice) !!! do - const 200 === statusCode - const (String . fromName <$> mNewName) - === ( \r -> do - b <- responseBody r - b ^? key "name" - ) -- should appear in search by 'newName' suid <- userId <$> randomUser brig Search.refreshIndex brig From 0a233d4dd93421ad0b866254351f6d7a15aa2530 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 7 Feb 2022 13:42:01 +0100 Subject: [PATCH 15/58] SQCORE 1173: Servantify the Galley Conversation API (#2016) * Servantify POST /conversations/:cnv/join * Servantify POST /conversations/code-check * Servantify POST /conversations/join * Servantify POST /conversations/:cnv/code * Servantify DELETE /conversations/:cnv/code * Servantify GET /conversations/:cnv/code * Servantify POST /conversations/:cnv/typing * Servantify POST /broadcast/otr/messages * Fix broadcast integration tests * Remove old broadcast code * Servantify POST /bot/messages * Update the developer's documentation - Add ZConversation in the Servant doc * Remove a non used nonBindingTeam WAI error Co-authored-by: Paolo Capriotti --- .../5-internal/servantify-conversations | 1 + docs/developer/servant.md | 1 + .../wire-api/src/Wire/API/ErrorDescription.hs | 14 +- .../src/Wire/API/Event/Conversation.hs | 5 + libs/wire-api/src/Wire/API/Routes/Public.hs | 11 + .../src/Wire/API/Routes/Public/Galley.hs | 174 +++- services/galley/src/Galley/API/Error.hs | 21 +- services/galley/src/Galley/API/Federation.hs | 4 +- services/galley/src/Galley/API/Message.hs | 376 +++++++-- services/galley/src/Galley/API/Public.hs | 189 +---- .../galley/src/Galley/API/Public/Servant.hs | 13 +- services/galley/src/Galley/API/Teams.hs | 21 +- services/galley/src/Galley/API/Update.hs | 792 ++++-------------- .../galley/src/Galley/Effects/TeamStore.hs | 18 + services/galley/test/integration/API/Teams.hs | 93 +- services/galley/test/integration/API/Util.hs | 26 +- .../test/unit/Test/Galley/API/Message.hs | 9 + 17 files changed, 759 insertions(+), 1009 deletions(-) create mode 100644 changelog.d/5-internal/servantify-conversations diff --git a/changelog.d/5-internal/servantify-conversations b/changelog.d/5-internal/servantify-conversations new file mode 100644 index 00000000000..44171f8c7ee --- /dev/null +++ b/changelog.d/5-internal/servantify-conversations @@ -0,0 +1 @@ +Convert galley conversation endpoints to Servant diff --git a/docs/developer/servant.md b/docs/developer/servant.md index e514c6934fe..6873f446b3b 100644 --- a/docs/developer/servant.md +++ b/docs/developer/servant.md @@ -17,6 +17,7 @@ This is a family of combinators to handle the headers that nginx adds to request - `ZUser`: extracts the `UserId` in the `Z-User` header. - `ZLocalUser`: same as `ZUser`, but as a `Local` object (i.e. qualified by the local domain); this is useful when writing federation-aware handlers. - `ZConn`: extracts the `ConnId` in the `Z-Connection` header. + - `ZConversation`: extracts the `ConvId` in the `Z-Conversation` header. ## `MultiVerb` diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index df14482b916..888b5289a39 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -211,11 +211,15 @@ type ConvNotFound = ErrorDescription 404 "no-conversation" "Conversation not fou type ConvMemberNotFound = ErrorDescription 404 "no-conversation-member" "Conversation member not found" +type TooManyMembers = ErrorDescription 403 "too-many-members" "Maximum number of members per conversation reached." + type UnknownClient = ErrorDescription 403 "unknown-client" "Unknown Client" type ClientNotFound = ErrorDescription 404 "client-not-found" "Client not found" -type TeamNotFound = ErrorDescription 404 "no-team" "team not found" +type TeamNotFound = ErrorDescription 404 "no-team" "Team not found" + +type NonBindingTeam = ErrorDescription 404 "non-binding-team" "Not member of a binding team" type NotConnected = ErrorDescription 403 "not-connected" "Users are not connected" @@ -329,6 +333,8 @@ type InvalidOpConnectConv = InvalidOp "invalid operation for connect conversatio type InvalidTargetAccess = InvalidOp "invalid target access" +type InvalidAccessOp = InvalidOp "invalid operation for conversation without 'code' access" + type AssetTooLarge = ErrorDescription 413 "client-error" "Asset too large" type InvalidLength = ErrorDescription 400 "invalid-length" "Invalid content length" @@ -358,3 +364,9 @@ type InvalidHandle = ErrorDescription 400 "invalid-handle" "The given handle is type PresenceNotRegistered = ErrorDescription 404 "not-found" "presence not registered" type ClientGone = ErrorDescription 410 "general" "client gone" + +type BroadcastLimitExceeded = + ErrorDescription + 400 + "too-many-users-to-broadcast" + "Too many users to fan out the broadcast event to." diff --git a/libs/wire-api/src/Wire/API/Event/Conversation.hs b/libs/wire-api/src/Wire/API/Event/Conversation.hs index fe6331e58b0..b87b9369ee0 100644 --- a/libs/wire-api/src/Wire/API/Event/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Event/Conversation.hs @@ -23,6 +23,7 @@ module Wire.API.Event.Conversation Event (..), EventType (..), EventData (..), + AddCodeResult (..), -- * Event lenses _EdMembersJoin, @@ -450,6 +451,10 @@ modelMemberUpdateData = Doc.defineModel "MemberUpdateData" $ do Doc.description "Name of the conversation role to update to" Doc.optional +data AddCodeResult + = CodeAdded Event + | CodeAlreadyExisted ConversationCode + data OtrMessage = OtrMessage { otrSender :: ClientId, otrRecipient :: ClientId, diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index 569e3aba901..0fe291c1f2e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -26,6 +26,7 @@ module Wire.API.Routes.Public ZOptUser, ZOptConn, ZBot, + ZConversation, ZProvider, -- * Swagger combinators @@ -75,6 +76,7 @@ data ZType | -- | Get a 'ConnId' from the Z-Conn header ZAuthConn | ZAuthBot + | ZAuthConv | ZAuthProvider class @@ -122,6 +124,13 @@ instance IsZType 'ZAuthBot ctx where qualifyZParam _ = id +instance IsZType 'ZAuthConv ctx where + type ZHeader 'ZAuthConv = "Z-Conversation" + type ZParam 'ZAuthConv = ConvId + type ZQualifiedParam 'ZAuthConv = ConvId + + qualifyZParam _ = id + instance HasTokenType 'ZAuthBot where tokenType = Just "bot" @@ -153,6 +162,8 @@ type ZConn = ZAuthServant 'ZAuthConn InternalAuthDefOpts type ZBot = ZAuthServant 'ZAuthBot InternalAuthDefOpts +type ZConversation = ZAuthServant 'ZAuthConv InternalAuthDefOpts + type ZProvider = ZAuthServant 'ZAuthProvider InternalAuthDefOpts type ZOptUser = ZAuthServant 'ZAuthUser '[Servant.Optional, Servant.Strict] 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 47f9c19d212..9a9658d9393 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -71,8 +71,30 @@ type ConversationVerb = ] ConversationResponse +type CreateConversationCodeVerb = + MultiVerb + 'POST + '[JSON] + '[ Respond 200 "Conversation code already exists." ConversationCode, + Respond 201 "Conversation code created." Event + ] + AddCodeResult + +instance + (ResponseType r1 ~ ConversationCode, ResponseType r2 ~ Event) => + AsUnion '[r1, r2] AddCodeResult + where + toUnion (CodeAlreadyExisted c) = Z (I c) + toUnion (CodeAdded e) = S (Z (I e)) + + fromUnion (Z (I c)) = CodeAlreadyExisted c + fromUnion (S (Z (I e))) = CodeAdded e + fromUnion (S (S x)) = case x of + type ConvUpdateResponses = UpdateResponses "Conversation unchanged" "Conversation updated" Event +type ConvJoinResponses = UpdateResponses "Conversation unchanged" "Conversation joined" Event + type RemoveFromConversationVerb = MultiVerb 'DELETE @@ -86,6 +108,7 @@ type ServantAPI = ConversationAPI :<|> TeamConversationAPI :<|> MessagingAPI + :<|> BotAPI :<|> TeamAPI :<|> FeatureAPI @@ -281,6 +304,108 @@ type ConversationAPI = :> MultiVerb 'POST '[Servant.JSON] ConvUpdateResponses (UpdateResult Event) ) -- This endpoint can lead to the following events being sent: + -- - MemberJoin event to members + :<|> Named + "join-conversation-by-id-unqualified" + ( Summary "Join a conversation by its ID (if link access enabled)" + :> CanThrow ConvNotFound + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "join" + :> MultiVerb 'POST '[Servant.JSON] ConvJoinResponses (UpdateResult Event) + ) + -- This endpoint can lead to the following events being sent: + -- - MemberJoin event to members + :<|> Named + "join-conversation-by-code-unqualified" + ( Summary "Join a conversation using a reusable code" + :> CanThrow CodeNotFound + :> CanThrow ConvNotFound + :> CanThrow TooManyMembers + :> ZLocalUser + :> ZConn + :> "conversations" + :> "join" + :> ReqBody '[Servant.JSON] ConversationCode + :> MultiVerb 'POST '[Servant.JSON] ConvJoinResponses (UpdateResult Event) + ) + :<|> Named + "code-check" + ( Summary "Check validity of a conversation code" + :> CanThrow CodeNotFound + :> "conversations" + :> "code-check" + :> ReqBody '[Servant.JSON] ConversationCode + :> MultiVerb + 'POST + '[JSON] + '[RespondEmpty 200 "Valid"] + () + ) + -- this endpoint can lead to the following events being sent: + -- - ConvCodeUpdate event to members, if code didn't exist before + :<|> Named + "create-conversation-code-unqualified" + ( Summary "Create or recreate a conversation code" + :> CanThrow ConvNotFound + :> CanThrow InvalidAccessOp + :> ZUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "code" + :> CreateConversationCodeVerb + ) + -- This endpoint can lead to the following events being sent: + -- - ConvCodeDelete event to members + :<|> Named + "remove-code-unqualified" + ( Summary "Delete conversation code" + :> CanThrow ConvNotFound + :> CanThrow InvalidAccessOp + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "code" + :> MultiVerb + 'DELETE + '[JSON] + '[Respond 200 "Conversation code deleted." Event] + Event + ) + :<|> Named + "get-code" + ( Summary "Get existing conversation code" + :> CanThrow ConvNotFound + :> CanThrow InvalidAccessOp + :> ZLocalUser + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "code" + :> MultiVerb + 'GET + '[JSON] + '[Respond 200 "Conversation Code" ConversationCode] + ConversationCode + ) + -- This endpoint can lead to the following events being sent: + -- - Typing event to members + :<|> Named + "member-typing-unqualified" + ( Summary "Sending typing notifications" + :> CanThrow ConvNotFound + :> ZLocalUser + :> ZConn + :> "conversations" + :> Capture' '[Description "Conversation ID"] "cnv" ConvId + :> "typing" + :> ReqBody '[JSON] TypingData + :> MultiVerb 'POST '[JSON] '[RespondEmpty 200 "Notification sent"] () + ) + -- This endpoint can lead to the following events being sent: -- - MemberLeave event to members :<|> Named "remove-member-unqualified" @@ -689,17 +814,38 @@ type MessagingAPI = :> ZConn :> "conversations" :> Capture "cnv" ConvId - :> QueryParam "ignore_missing" IgnoreMissing - :> QueryParam "report_missing" ReportMissing :> "otr" :> "messages" - :> ReqBody '[Servant.JSON, Proto] NewOtrMessage + :> QueryParam "ignore_missing" IgnoreMissing + :> QueryParam "report_missing" ReportMissing + :> ReqBody '[JSON, Proto] NewOtrMessage :> MultiVerb 'POST '[Servant.JSON] (PostOtrResponses ClientMismatch) - (Either (MessageNotSent ClientMismatch) ClientMismatch) + (PostOtrResponse ClientMismatch) ) + :<|> Named + "post-otr-broadcast-unqualified" + ( Summary "Broadcast an encrypted message to all team members and all contacts (accepts JSON or Protobuf)" + :> Description PostOtrDescriptionUnqualified + :> ZLocalUser + :> ZConn + :> CanThrow TeamNotFound + :> CanThrow BroadcastLimitExceeded + :> CanThrow NonBindingTeam + :> "broadcast" + :> "otr" + :> "messages" + :> QueryParam "ignore_missing" IgnoreMissing + :> QueryParam "report_missing" ReportMissing + :> ReqBody '[JSON, Proto] NewOtrMessage + :> MultiVerb + 'POST + '[JSON] + (PostOtrResponses ClientMismatch) + (PostOtrResponse ClientMismatch) + ) :<|> Named "post-proteus-message" ( Summary "Post an encrypted message to a conversation (accepts only Protobuf)" @@ -718,6 +864,23 @@ type MessagingAPI = (Either (MessageNotSent MessageSendingStatus) MessageSendingStatus) ) +type BotAPI = + Named + "post-bot-message-unqualified" + ( ZBot + :> ZConversation + :> "bot" + :> "messages" + :> QueryParam "ignore_missing" IgnoreMissing + :> QueryParam "report_missing" ReportMissing + :> ReqBody '[JSON] NewOtrMessage + :> MultiVerb + 'POST + '[Servant.JSON] + (PostOtrResponses ClientMismatch) + (PostOtrResponse ClientMismatch) + ) + type FeatureAPI = FeatureStatusGet 'TeamFeatureSSO :<|> FeatureStatusGet 'TeamFeatureLegalHold @@ -831,6 +994,9 @@ type AllFeatureConfigsGet = :> Get '[Servant.JSON] AllFeatureConfigs ) +-- This is a work-around for the fact that we sometimes want to send larger lists of user ids +-- in the filter query than fits the url length limit. For details, see +-- https://github.com/zinfra/backend-issues/issues/1248 type PostOtrDescriptionUnqualified = "This endpoint ensures that the list of clients is correct and only sends the message if the list is correct.\n\ \To override this, the endpoint accepts two query params:\n\ diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index d6eb0aa94b1..7993acc8c80 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -86,7 +86,7 @@ instance APIError ActionError where toWai NotConnected = errorDescriptionTypeToWai @NotConnected toWai InvalidTargetUserOp = invalidTargetUserOp toWai NoAddToManaged = noAddToManaged - toWai BroadcastLimitExceeded = broadcastLimitExceeded + toWai BroadcastLimitExceeded = errorDescriptionTypeToWai @BroadcastLimitExceeded toWai InvalidTeamStatusUpdate = invalidTeamStatusUpdate toWai InvalidPermissions = invalidPermissions @@ -127,7 +127,7 @@ data ConversationError instance APIError ConversationError where toWai ConvAccessDenied = errorDescriptionTypeToWai @ConvAccessDenied toWai ConvNotFound = errorDescriptionTypeToWai @ConvNotFound - toWai TooManyMembers = tooManyMembers + toWai TooManyMembers = errorDescriptionTypeToWai @TooManyMembers toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound toWai NoBindingTeamMembers = noBindingTeamMembers toWai NoManagedTeamConv = noManagedTeamConv @@ -148,9 +148,9 @@ data TeamError instance APIError TeamError where toWai NoBindingTeam = noBindingTeam toWai NoAddToBinding = noAddToBinding - toWai NotABindingTeamMember = nonBindingTeam + toWai NotABindingTeamMember = errorDescriptionTypeToWai @NonBindingTeam toWai NotAOneMemberTeam = notAOneMemberTeam - toWai TeamNotFound = teamNotFound + toWai TeamNotFound = errorDescriptionTypeToWai @TeamNotFound toWai TeamMemberNotFound = teamMemberNotFound toWai TeamSearchVisibilityNotEnabled = teamSearchVisibilityNotEnabled toWai UserBindingExists = userBindingExists @@ -367,19 +367,9 @@ bulkGetMemberLimitExceeded = "too-many-uids" ("Can only process " <> cs (show @Int hardTruncationLimit) <> " user ids per request.") -broadcastLimitExceeded :: Error -broadcastLimitExceeded = - mkError - status400 - "too-many-users-to-broadcast" - ("Too many users to fan out the broadcast event to.") - noAddToManaged :: Error noAddToManaged = mkError status403 "no-add-to-managed" "Adding users/bots directly to managed conversation is not allowed." -teamNotFound :: Error -teamNotFound = mkError status404 "no-team" "team not found" - invalidPermissions :: Error invalidPermissions = mkError status403 "invalid-permissions" "The specified permissions are invalid." @@ -410,9 +400,6 @@ noAddToBinding = mkError status403 "binding-team" "Cannot add users to binding t deleteQueueFull :: Error deleteQueueFull = mkError status503 "queue-full" "The delete queue is full. No further delete requests can be processed at the moment." -nonBindingTeam :: Error -nonBindingTeam = mkError status404 "non-binding-team" "not member of a binding team" - noBindingTeamMembers :: Error noBindingTeamMembers = mkError status403 "non-binding-team-members" "Both users must be members of the same binding team." diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 496bb26cfe4..2c86e342fe6 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -301,13 +301,15 @@ onMessageSent domain rmUnqualified = do ByteString ) localMembers <- sequence $ Map.fromSet mkLocalMember (Set.fromList members) + loc <- qualifyLocal () void $ sendLocalMessages + loc (F.rmTime rm) (F.rmSender rm) (F.rmSenderClient rm) Nothing - convId + (Just convId) localMembers msgMetadata msgs diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4de70882086..f8fb535398e 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -15,31 +15,47 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.API.Message where +module Galley.API.Message + ( UserType (..), + sendLocalMessages, + postQualifiedOtrMessage, + postBroadcast, + postRemoteOtrMessage, + legacyClientMismatchStrategy, + Unqualify (..), + userToProtectee, + MessageMetadata (..), + + -- * Only exported for tests + checkMessageClients, + QualifiedMismatch (..), + mkQualifiedUserClients, + clientMismatchStrategyApply, + ) +where import Control.Lens import Control.Monad.Except (throwError) import Control.Monad.Extra (eitherM) import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (encode) +import Data.Bifunctor import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain) -import Data.Id (ClientId, ConnId, ConvId, UserId) +import Data.Id import Data.Json.Util - ( Base64ByteString (..), - UTCTimeMillis, - toBase64Text, - toUTCTimeMillis, - ) import Data.List1 (singleton) import qualified Data.Map as Map import Data.Map.Lens (toMapOf) import Data.Qualified +import Data.Range import qualified Data.Set as Set import Data.Set.Lens import Data.Time.Clock (UTCTime) +import Galley.API.Error import Galley.API.LegalHold.Conflicts import Galley.API.Util +import Galley.Data.Conversation import Galley.Data.Services as Data import Galley.Effects import Galley.Effects.BrigAccess @@ -49,6 +65,7 @@ import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess import Galley.Effects.GundeckAccess hiding (Push) import Galley.Effects.MemberStore +import Galley.Effects.TeamStore import Galley.Intra.Push import Galley.Options import qualified Galley.Types.Clients as Clients @@ -67,6 +84,7 @@ import Wire.API.Federation.API.Galley import Wire.API.Federation.Error import Wire.API.Message import Wire.API.Team.LegalHold +import Wire.API.Team.Member import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) @@ -228,6 +246,111 @@ postRemoteOtrMessage sender conv rawMsg = do rpc = fedClient @'Galley @"send-message" msr msResponse <$> runFederated conv rpc +postBroadcast :: + Members + '[ BrigAccess, + ClientStore, + Error ActionError, + Error TeamError, + GundeckAccess, + Input Opts, + Input UTCTime, + TeamStore, + P.TinyLog + ] + r => + Local UserId -> + Maybe ConnId -> + QualifiedNewOtrMessage -> + Sem r (PostOtrResponse MessageSendingStatus) +postBroadcast lusr con msg = runError $ do + let senderClient = qualifiedNewOtrSender msg + senderDomain = tDomain lusr + senderUser = tUnqualified lusr + rcps = + Map.findWithDefault mempty senderDomain + . qualifiedUserClientMap + . qualifiedOtrRecipientsMap + . qualifiedNewOtrRecipients + $ msg + now <- input + + tid <- lookupBindingTeam senderUser + limit <- fromIntegral . fromRange <$> fanoutLimit + -- If we are going to fan this out to more than limit, we want to fail early + unless (Map.size 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. + tMembers <- + fmap (view userId) <$> case qualifiedNewOtrClientMismatchStrategy msg of + -- Note: remote ids are not in a local team + MismatchReportOnly qus -> + maybeFetchLimitedTeamMemberList + limit + tid + (fst (partitionQualified lusr qus)) + rcps + _ -> maybeFetchAllMembersInTeam tid + contacts <- getContactList senderUser + let users = toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) + + isInternal <- useIntraClientListing + localClients <- + if isInternal + then Clients.fromUserClients <$> lookupClients users + else getClients users + let qualifiedLocalClients = + Map.mapKeys (tDomain lusr,) + . makeUserMap (Set.fromList users) + . Clients.toMap + $ localClients + + let (sendMessage, validMessages, mismatch) = + checkMessageClients + (senderDomain, senderUser, senderClient) + qualifiedLocalClients + (flattenMap $ qualifiedNewOtrRecipients msg) + (qualifiedNewOtrClientMismatchStrategy msg) + otrResult = mkMessageSendingStatus (toUTCTimeMillis now) mismatch mempty + unless sendMessage $ do + let lhProtectee = qualifiedUserToProtectee (tDomain lusr) User (qUntagged lusr) + missingClients = qmMissing mismatch + + mapError @LegalholdConflicts @(MessageNotSent MessageSendingStatus) + (const MessageNotSentLegalhold) + $ runLocalInput lusr $ + guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients + throw $ MessageNotSentClientMissing otrResult + + failedToSend <- + sendBroadcastMessages + lusr + now + (qUntagged lusr) + senderClient + con + (qualifiedNewOtrMetadata msg) + validMessages + pure otrResult {mssFailedToSend = failedToSend} + where + maybeFetchLimitedTeamMemberList limit tid localUserIdsInFilter rcps = do + let localUserIdsInRcps = Map.keys rcps + let localUserIdsToLookup = Set.toList $ Set.union (Set.fromList localUserIdsInFilter) (Set.fromList localUserIdsInRcps) + unless (length localUserIdsToLookup <= limit) $ + throw BroadcastLimitExceeded + selectTeamMembers tid localUserIdsToLookup + maybeFetchAllMembersInTeam :: + Members '[Error ActionError, TeamStore] r => + TeamId -> + Sem r [TeamMember] + maybeFetchAllMembersInTeam tid = do + mems <- getTeamMembersForFanout tid + when (mems ^. teamMemberListType == ListTruncated) $ + throw BroadcastLimitExceeded + pure (mems ^. teamMembers) + postQualifiedOtrMessage :: Members '[ BrigAccess, @@ -325,7 +448,7 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = runExceptT $ do failedToSend <- lift $ - sendMessages + sendMessages @'NormalMessage now sender senderClient @@ -335,21 +458,23 @@ postQualifiedOtrMessage senderType sender mconn lcnv msg = runExceptT $ do (qualifiedNewOtrMetadata msg) validMessages pure otrResult {mssFailedToSend = failedToSend} - where - makeUserMap :: Set UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId) - makeUserMap keys = (<> Map.fromSet (const mempty) keys) + +makeUserMap :: Set UserId -> Map UserId (Set ClientId) -> Map UserId (Set ClientId) +makeUserMap keys = (<> Map.fromSet (const mempty) keys) -- | Send both local and remote messages, return the set of clients for which -- sending has failed. sendMessages :: - Members '[GundeckAccess, ExternalAccess, FederatorAccess, Input (Local ()), P.TinyLog] r => - -- FUTUREWORK: remove Input (Local ()) effect + forall t r. + ( t ~ 'NormalMessage, + Members '[GundeckAccess, ExternalAccess, FederatorAccess, P.TinyLog] r + ) => UTCTime -> Qualified UserId -> ClientId -> Maybe ConnId -> Local ConvId -> - Map UserId LocalMember -> + LocalMemberMap t -> MessageMetadata -> Map (Domain, UserId, ClientId) ByteString -> Sem r QualifiedUserClients @@ -358,33 +483,52 @@ sendMessages now sender senderClient mconn lcnv localMemberMap metadata messages let send dom = foldQualified lcnv - (\_ -> sendLocalMessages now sender senderClient mconn (qUntagged lcnv) localMemberMap metadata) + (\l -> sendLocalMessages l now sender senderClient mconn (Just (qUntagged lcnv)) localMemberMap metadata) (\r -> sendRemoteMessages r now sender senderClient lcnv metadata) (Qualified () dom) - mkQualifiedUserClientsByDomain <$> Map.traverseWithKey send messageMap - where - byDomain :: Map (Domain, UserId, ClientId) a -> Map Domain (Map (UserId, ClientId) a) - byDomain = - Map.foldrWithKey - (\(d, u, c) t -> Map.insertWith (<>) d (Map.singleton (u, c) t)) - mempty + +sendBroadcastMessages :: + Members '[GundeckAccess, P.TinyLog] r => + Local x -> + UTCTime -> + Qualified UserId -> + ClientId -> + Maybe ConnId -> + MessageMetadata -> + Map (Domain, UserId, ClientId) ByteString -> + Sem r QualifiedUserClients +sendBroadcastMessages loc now sender senderClient mconn metadata messages = do + let messageMap = byDomain $ fmap toBase64Text messages + localMessages = Map.findWithDefault mempty (tDomain loc) messageMap + failed <- sendLocalMessages loc now sender senderClient mconn Nothing () metadata localMessages + pure . mkQualifiedUserClientsByDomain $ Map.singleton (tDomain loc) failed + +byDomain :: Map (Domain, UserId, ClientId) a -> Map Domain (Map (UserId, ClientId) a) +byDomain = + Map.foldrWithKey + (\(d, u, c) t -> Map.insertWith (<>) d (Map.singleton (u, c) t)) + mempty sendLocalMessages :: - Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => + forall t r x. + ( RunMessagePush t, + Members (MessagePushEffects t) r, + Monoid (MessagePush t) + ) => + Local x -> UTCTime -> Qualified UserId -> ClientId -> Maybe ConnId -> - Qualified ConvId -> - Map UserId LocalMember -> + Maybe (Qualified ConvId) -> + LocalMemberMap t -> MessageMetadata -> Map (UserId, ClientId) Text -> Sem r (Set (UserId, ClientId)) -sendLocalMessages now sender senderClient mconn qcnv localMemberMap metadata localMessages = do - loc <- qualifyLocal () +sendLocalMessages loc now sender senderClient mconn qcnv localMemberMap metadata localMessages = do let events = - localMessages & reindexed snd itraversed + localMessages & reindexed (first (qualifyAs loc)) itraversed %@~ newMessageEvent qcnv sender @@ -394,7 +538,7 @@ sendLocalMessages now sender senderClient mconn qcnv localMemberMap metadata loc pushes = events & itraversed %@~ newMessagePush loc localMemberMap mconn metadata - runMessagePush qcnv (pushes ^. traversed) + runMessagePush @t loc qcnv (pushes ^. traversed) pure mempty sendRemoteMessages :: @@ -439,86 +583,134 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand Log.~~ Log.msg ("Remote message sending failed" :: Text) pure (Map.keysSet messages) -flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) -flatten = - setOf $ - (itraversed <.> itraversed <. folded) - . withIndex - . to (\((d, u), c) -> (d, u, c)) - flattenMap :: QualifiedOtrRecipients -> Map (Domain, UserId, ClientId) ByteString flattenMap (QualifiedOtrRecipients (QualifiedUserClientMap m)) = toMapOf (reindexed (\(d, (u, c)) -> (d, u, c)) (itraversed <.> itraversed <.> itraversed)) m -data MessagePush = MessagePush +data MessageType = NormalMessage | Broadcast + +data family MessagePush (t :: MessageType) + +data instance MessagePush 'NormalMessage = NormalMessagePush { userPushes :: [Push], botPushes :: [(BotMember, Event)] } -instance Semigroup MessagePush where - MessagePush us1 bs1 <> MessagePush us2 bs2 = MessagePush (us1 <> us2) (bs1 <> bs2) +data instance MessagePush 'Broadcast = BroadcastPush + {broadcastPushes :: [Push]} -instance Monoid MessagePush where - mempty = MessagePush mempty mempty +instance Semigroup (MessagePush 'NormalMessage) where + NormalMessagePush us1 bs1 <> NormalMessagePush us2 bs2 = + NormalMessagePush (us1 <> us2) (bs1 <> bs2) -newUserPush :: Push -> MessagePush -newUserPush p = MessagePush {userPushes = pure p, botPushes = mempty} +instance Monoid (MessagePush 'NormalMessage) where + mempty = NormalMessagePush mempty mempty -newBotPush :: BotMember -> Event -> MessagePush -newBotPush b e = MessagePush {userPushes = mempty, botPushes = pure (b, e)} +instance Semigroup (MessagePush 'Broadcast) where + BroadcastPush us1 <> BroadcastPush us2 = BroadcastPush (us1 <> us2) -runMessagePush :: - forall r. - Members '[GundeckAccess, ExternalAccess, Input (Local ()), P.TinyLog] r => - Qualified ConvId -> - MessagePush -> - Sem r () -runMessagePush qcnv mp = do - push (userPushes mp) - pushToBots (botPushes mp) - where - pushToBots :: [(BotMember, Event)] -> Sem r () - pushToBots pushes = do - localDomain <- tDomain <$> qualifyLocal () - if localDomain /= qDomain qcnv - then unless (null pushes) $ do - P.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) - else deliverAndDeleteAsync (qUnqualified qcnv) pushes - -newMessageEvent :: Qualified ConvId -> Qualified UserId -> ClientId -> Maybe Text -> UTCTime -> ClientId -> Text -> Event -newMessageEvent convId sender senderClient dat time receiverClient cipherText = - Event OtrMessageAdd convId sender time . EdOtrMessage $ - OtrMessage - { otrSender = senderClient, - otrRecipient = receiverClient, - otrCiphertext = cipherText, - otrData = dat - } +instance Monoid (MessagePush 'Broadcast) where + mempty = BroadcastPush mempty + +class HasUserPush (t :: MessageType) where + newUserPush :: Push -> MessagePush t + +instance HasUserPush 'NormalMessage where + newUserPush p = NormalMessagePush {userPushes = pure p, botPushes = mempty} + +instance HasUserPush 'Broadcast where + newUserPush p = BroadcastPush (pure p) + +newBotPush :: BotMember -> Event -> MessagePush 'NormalMessage +newBotPush b e = NormalMessagePush {userPushes = mempty, botPushes = pure (b, e)} -newMessagePush :: - Ord k => +type family LocalMemberMap (t :: MessageType) = (m :: *) | m -> t where + LocalMemberMap 'NormalMessage = Map UserId LocalMember + LocalMemberMap 'Broadcast = () + +newMessageEvent :: + Maybe (Qualified ConvId) -> + Qualified UserId -> + ClientId -> + Maybe Text -> + UTCTime -> + (Local UserId, ClientId) -> + Text -> + Event +newMessageEvent mconvId sender senderClient dat time (receiver, receiverClient) cipherText = + let convId = fromMaybe (qUntagged (fmap selfConv receiver)) mconvId + in Event OtrMessageAdd convId sender time . EdOtrMessage $ + OtrMessage + { otrSender = senderClient, + otrRecipient = receiverClient, + otrCiphertext = cipherText, + otrData = dat + } + +class RunMessagePush (t :: MessageType) where + type MessagePushEffects t :: [Effect] + newMessagePush :: + Local x -> + LocalMemberMap t -> + Maybe ConnId -> + MessageMetadata -> + (UserId, ClientId) -> + Event -> + MessagePush t + runMessagePush :: + Members (MessagePushEffects t) r => + Local x -> + Maybe (Qualified ConvId) -> + MessagePush t -> + Sem r () + +instance RunMessagePush 'NormalMessage where + type MessagePushEffects 'NormalMessage = '[ExternalAccess, GundeckAccess, P.TinyLog] + newMessagePush loc members mconn mm (k, client) e = fold $ do + member <- Map.lookup k members + newBotMessagePush member <|> newUserMessagePush loc mconn mm (lmId member) client e + where + newBotMessagePush :: LocalMember -> Maybe (MessagePush 'NormalMessage) + newBotMessagePush member = newBotPush <$> newBotMember member <*> pure e + runMessagePush loc mqcnv mp = do + push (userPushes mp) + pushToBots (botPushes mp) + where + pushToBots :: + Members '[ExternalAccess, P.TinyLog] r => + [(BotMember, Event)] -> + Sem r () + pushToBots pushes = for_ mqcnv $ \qcnv -> + if tDomain loc /= qDomain qcnv + then unless (null pushes) $ do + P.warn $ Log.msg ("Ignoring messages for local bots in a remote conversation" :: ByteString) . Log.field "conversation" (show qcnv) + else deliverAndDeleteAsync (qUnqualified qcnv) pushes + +instance RunMessagePush 'Broadcast where + type MessagePushEffects 'Broadcast = '[GundeckAccess] + newMessagePush loc () mconn mm (user, client) e = + fold $ + newUserMessagePush loc mconn mm user client e + + runMessagePush _ _ mp = push (broadcastPushes mp) + +newUserMessagePush :: + HasUserPush t => Local x -> - Map k LocalMember -> Maybe ConnId -> MessageMetadata -> - (k, ClientId) -> + UserId -> + ClientId -> Event -> - MessagePush -newMessagePush loc members mconn mm (k, client) e = fromMaybe mempty $ do - member <- Map.lookup k members - newBotMessagePush member <|> newUserMessagePush member - where - newBotMessagePush :: LocalMember -> Maybe MessagePush - newBotMessagePush member = newBotPush <$> newBotMember member <*> pure e - newUserMessagePush :: LocalMember -> Maybe MessagePush - newUserMessagePush member = - fmap newUserPush $ - newConversationEventPush e (qualifyAs loc [lmId member]) - <&> set pushConn mconn - . set pushNativePriority (mmNativePriority mm) - . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) - . set pushTransient (mmTransient mm) - . set (pushRecipients . traverse . recipientClients) (RecipientClientsSome (singleton client)) + Maybe (MessagePush t) +newUserMessagePush loc mconn mm user cli e = + fmap newUserPush $ + newConversationEventPush e (qualifyAs loc [user]) + <&> set pushConn mconn + . set pushNativePriority (mmNativePriority mm) + . set pushRoute (bool RouteDirect RouteAny (mmNativePush mm)) + . set pushTransient (mmTransient mm) + . set (pushRecipients . traverse . recipientClients) (RecipientClientsSome (singleton cli)) data MessageMetadata = MessageMetadata { mmNativePush :: Bool, diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 3112574d1ec..99dc38c63ca 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -37,7 +37,6 @@ import qualified Galley.API.LegalHold as LegalHold import qualified Galley.API.Query as Query import qualified Galley.API.Teams as Teams import qualified Galley.API.Teams.Features as Features -import qualified Galley.API.Update as Update import Galley.App import Imports hiding (head) import Network.HTTP.Types @@ -50,8 +49,6 @@ import Network.Wai.Utilities import Network.Wai.Utilities.Swagger import Network.Wai.Utilities.ZAuth hiding (ZAuthUser) import Polysemy -import qualified Wire.API.Conversation.Code as Public -import qualified Wire.API.Conversation.Typing as Public import qualified Wire.API.CustomBackend as Public import qualified Wire.API.ErrorDescription as Error import qualified Wire.API.Event.Team as Public () @@ -175,7 +172,7 @@ sitemap = do description "Maximum number of events to return (1..10000; default: 1000)" returns (ref Public.modelNotificationList) response 200 "List of team notifications" end - errorResponse Error.teamNotFound + errorResponse (Error.errorDescriptionTypeToWai @Error.TeamNotFound) errorResponse Error.invalidTeamNotificationId post "/teams/:tid/members" (continue Teams.addTeamMemberH) $ @@ -358,190 +355,6 @@ sitemap = do .&. zauthConvId .&. accept "application" "json" - -- This endpoint can lead to the following events being sent: - -- - OtrMessageAdd event to recipients - post "/bot/messages" (continue Update.postBotMessageH) $ - zauth ZAuthBot - .&> zauthBotId - .&. zauthConvId - .&. def Public.OtrReportAllMissing filterMissing - .&. jsonRequest @Public.NewOtrMessage - .&. accept "application" "json" - - -- Conversation API --------------------------------------------------- - - -- This endpoint can lead to the following events being sent: - -- - MemberJoin event to members - post "/conversations/:cnv/join" (continue Update.joinConversationByIdH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. accept "application" "json" - document "POST" "joinConversationById" $ do - summary "Join a conversation by its ID (if link access enabled)" - parameter Path "cnv" bytes' $ - description "Conversation ID" - returns (ref Public.modelEvent) - response 200 "Conversation joined." end - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - - post "/conversations/code-check" (continue Update.checkReusableCodeH) $ - jsonRequest @Public.ConversationCode - document "POST" "checkConversationCode" $ do - summary "Check validity of a conversation code" - response 200 "Valid" end - body (ref Public.modelConversationCode) $ - description "JSON body" - errorResponse (Error.errorDescriptionTypeToWai @Error.CodeNotFound) - - -- This endpoint can lead to the following events being sent: - -- - MemberJoin event to members - post "/conversations/join" (continue Update.joinConversationByReusableCodeH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @Public.ConversationCode - document "POST" "joinConversationByCode" $ do - summary "Join a conversation using a reusable code" - returns (ref Public.modelEvent) - response 200 "Conversation joined." end - body (ref Public.modelConversationCode) $ - description "JSON body" - errorResponse (Error.errorDescriptionTypeToWai @Error.CodeNotFound) - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse Error.tooManyMembers - - -- This endpoint can lead to the following events being sent: - -- - ConvCodeUpdate event to members, if code didn't exist before - post "/conversations/:cnv/code" (continue Update.addCodeH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - document "POST" "createConversationCode" $ do - summary "Create or recreate a conversation code" - parameter Path "cnv" bytes' $ - description "Conversation ID" - returns (ref Public.modelEvent) - returns (ref Public.modelConversationCode) - response 201 "Conversation code created." (model Public.modelEvent) - response 200 "Conversation code already exists." (model Public.modelConversationCode) - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse Error.invalidAccessOp - - -- This endpoint can lead to the following events being sent: - -- - ConvCodeDelete event to members - delete "/conversations/:cnv/code" (continue Update.rmCodeH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - document "DELETE" "deleteConversationCode" $ do - summary "Delete conversation code" - parameter Path "cnv" bytes' $ - description "Conversation ID" - returns (ref Public.modelEvent) - response 200 "Conversation code deleted." end - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse Error.invalidAccessOp - - get "/conversations/:cnv/code" (continue Update.getCodeH) $ - zauthUserId - .&. capture "cnv" - document "GET" "getConversationCode" $ do - summary "Get existing conversation code" - parameter Path "cnv" bytes' $ - description "Conversation ID" - returns (ref Public.modelConversationCode) - response 200 "Conversation Code" end - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - errorResponse Error.invalidAccessOp - - -- This endpoint can lead to the following events being sent: - -- - Typing event to members - post "/conversations/:cnv/typing" (continue Update.isTypingH) $ - zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. jsonRequest @Public.TypingData - document "POST" "isTyping" $ do - summary "Sending typing notifications" - parameter Path "cnv" bytes' $ - description "Conversation ID" - body (ref Public.modelTyping) $ - description "JSON body" - errorResponse (Error.errorDescriptionTypeToWai @Error.ConvNotFound) - - -- This endpoint can lead to the following events being sent: - -- - OtrMessageAdd event to recipients - post "/broadcast/otr/messages" (continue Update.postOtrBroadcastH) $ - zauthUserId - .&. zauthConnId - .&. def Public.OtrReportAllMissing filterMissing - .&. jsonRequest @Public.NewOtrMessage - document "POST" "postOtrBroadcast" $ do - summary "Broadcast an encrypted message to all team members and all contacts (accepts JSON)" - parameter Query "ignore_missing" bool' $ do - description - "Force message delivery even when clients are missing. \ - \NOTE: can also be a comma-separated list of user IDs, \ - \in which case it specifies who exactly is allowed to \ - \have missing clients." - optional - parameter Query "report_missing" bool' $ do - description - "Don't allow message delivery when clients are missing \ - \('ignore_missing' takes precedence when present). \ - \NOTE: can also be a comma-separated list of user IDs, \ - \in which case it specifies who exactly is forbidden from \ - \having missing clients. \ - \To support large lists of user IDs exceeding the allowed \ - \URL length, you can also put this list in the body, in \ - \the optional field 'report_missing'. That body field takes \ - \precedence over both query params." - optional - body (ref Public.modelNewOtrMessage) $ - description "JSON body" - returns (ref Public.modelClientMismatch) - response 201 "Message posted" end - response 412 "Missing clients" end - errorResponse Error.teamNotFound - errorResponse Error.nonBindingTeam - errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) - errorResponse Error.broadcastLimitExceeded - - -- This endpoint can lead to the following events being sent: - -- - OtrMessageAdd event to recipients - post "/broadcast/otr/messages" (continue Update.postProtoOtrBroadcastH) $ - zauthUserId - .&. zauthConnId - .&. def Public.OtrReportAllMissing filterMissing - .&. request - .&. contentType "application" "x-protobuf" - document "POST" "postOtrBroadcast" $ do - summary "Broadcast an encrypted message to all team members and all contacts (accepts Protobuf)" - parameter Query "ignore_missing" bool' $ do - description - "Force message delivery even when clients are missing. \ - \NOTE: can also be a comma-separated list of user IDs, \ - \in which case it specifies who exactly is allowed to \ - \have missing clients." - optional - parameter Query "report_missing" bool' $ do - description - "Don't allow message delivery when clients are missing \ - \('ignore_missing' takes precedence when present). \ - \NOTE: can also be a comma-separated list of user IDs, \ - \in which case it specifies who exactly is forbidden from \ - \having missing clients." - optional - body (ref Public.modelNewOtrMessage) $ - description "Protobuf body" - returns (ref Public.modelClientMismatch) - response 201 "Message posted" end - response 412 "Missing clients" end - errorResponse Error.teamNotFound - errorResponse Error.nonBindingTeam - errorResponse (Error.errorDescriptionTypeToWai @Error.UnknownClient) - errorResponse Error.broadcastLimitExceeded - apiDocs :: Routes ApiBuilder (Sem r) () apiDocs = get "/conversations/api-docs" (continue docs) $ diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index 8f55c10c9c6..db412c0198b 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -33,7 +33,7 @@ import Wire.API.Routes.Public.Galley import Wire.API.Team.Feature servantSitemap :: ServerT ServantAPI (Sem GalleyEffects) -servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team :<|> features +servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> bot :<|> team :<|> features where conversations = Named @"get-unqualified-conversation" getUnqualifiedConversation @@ -49,6 +49,13 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team : :<|> Named @"create-one-to-one-conversation" createOne2OneConversation :<|> Named @"add-members-to-conversation-unqualified" addMembersUnqualified :<|> Named @"add-members-to-conversation" addMembers + :<|> Named @"join-conversation-by-id-unqualified" joinConversationById + :<|> Named @"join-conversation-by-code-unqualified" joinConversationByReusableCode + :<|> Named @"code-check" checkReusableCode + :<|> Named @"create-conversation-code-unqualified" addCodeUnqualified + :<|> Named @"remove-code-unqualified" rmCodeUnqualified + :<|> Named @"get-code" getCode + :<|> Named @"member-typing-unqualified" isTypingUnqualified :<|> Named @"remove-member-unqualified" removeMemberUnqualified :<|> Named @"remove-member" removeMemberQualified :<|> Named @"update-other-member-unqualified" updateOtherMemberUnqualified @@ -74,8 +81,12 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team : messaging = Named @"post-otr-message-unqualified" postOtrMessageUnqualified + :<|> Named @"post-otr-broadcast-unqualified" postOtrBroadcastUnqualified :<|> Named @"post-proteus-message" postProteusMessage + bot = + Named @"post-bot-message-unqualified" postBotMessageUnqualified + team = Named @"create-non-binding-team" createNonBindingTeamH :<|> Named @"update-team" updateTeamH diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index ae1ffb0e88b..d0dbaacad84 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1410,24 +1410,8 @@ finishCreateTeam team owner others zcon = do let r = membersToRecipients Nothing others E.push1 $ newPushLocal1 ListComplete zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon --- FUTUREWORK: Get rid of CPS -withBindingTeam :: - Members '[Error TeamError, TeamStore] r => - UserId -> - (TeamId -> Sem r b) -> - Sem r b -withBindingTeam zusr callback = do - tid <- E.getOneUserTeam zusr >>= note TeamNotFound - binding <- E.getTeamBinding tid >>= note TeamNotFound - case binding of - Binding -> callback tid - NonBinding -> throw NotABindingTeamMember - getBindingTeamIdH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response -getBindingTeamIdH = fmap json . getBindingTeamId - -getBindingTeamId :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r TeamId -getBindingTeamId zusr = withBindingTeam zusr pure +getBindingTeamIdH = fmap json . E.lookupBindingTeam getBindingTeamMembersH :: Members '[Error TeamError, TeamStore] r => UserId -> Sem r Response getBindingTeamMembersH = fmap json . getBindingTeamMembers @@ -1440,7 +1424,8 @@ getBindingTeamMembers :: r => UserId -> Sem r TeamMemberList -getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> +getBindingTeamMembers zusr = do + tid <- E.lookupBindingTeam zusr getTeamMembersForFanout tid canUserJoinTeamH :: diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index ede7fb6ee5a..b341cc9ebdd 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -20,12 +20,12 @@ module Galley.API.Update acceptConvH, blockConvH, unblockConvH, - checkReusableCodeH, - joinConversationByIdH, - joinConversationByReusableCodeH, - addCodeH, - rmCodeH, - getCodeH, + checkReusableCode, + joinConversationByReusableCode, + joinConversationById, + addCodeUnqualified, + rmCodeUnqualified, + getCode, updateUnqualifiedConversationName, updateConversationName, updateConversationReceiptModeUnqualified, @@ -52,16 +52,15 @@ module Galley.API.Update -- * Talking postProteusMessage, postOtrMessageUnqualified, - postOtrBroadcastH, - postProtoOtrBroadcastH, - isTypingH, + postOtrBroadcastUnqualified, + isTypingUnqualified, -- * External Services addServiceH, rmServiceH, Galley.API.Update.addBotH, rmBotH, - postBotMessageH, + postBotMessageUnqualified, ) where @@ -70,16 +69,14 @@ import Control.Lens import Control.Monad.State import Data.Code import Data.Id -import Data.Json.Util (fromBase64TextLenient, toUTCTimeMillis) +import Data.Json.Util import Data.List1 import qualified Data.Map.Strict as Map 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 import Galley.API.Mapping import Galley.API.Message import qualified Galley.API.Query as Query @@ -88,7 +85,6 @@ 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.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 @@ -103,13 +99,9 @@ import Galley.Intra.Push 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.Members (newMember) import Galley.Types.Conversations.Roles (Action (..), roleNameWireMember) import Galley.Types.Teams hiding (Event, EventData (..), EventType (..), self) import Galley.Types.UserList -import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports hiding (forkIO) import Network.HTTP.Types import Network.Wai @@ -119,15 +111,14 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog -import qualified Wire.API.Conversation as Public -import qualified Wire.API.Conversation.Code as Public +import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.ErrorDescription -import qualified Wire.API.Event.Conversation as Public +import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley import Wire.API.Federation.Error -import qualified Wire.API.Message as Public +import Wire.API.Message import Wire.API.Routes.Public.Util (UpdateResult (..)) import Wire.API.ServantProto (RawProto (..)) import Wire.API.User.Client @@ -277,7 +268,7 @@ updateConversationAccess :: Local UserId -> ConnId -> Qualified ConvId -> - Public.ConversationAccessData -> + ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccess lusr con qcnv update = do let doUpdate = @@ -308,7 +299,7 @@ updateConversationAccessUnqualified :: Local UserId -> ConnId -> ConvId -> - Public.ConversationAccessData -> + ConversationAccessData -> Sem r (UpdateResult Event) updateConversationAccessUnqualified lusr zcon cnv update = do let lcnv = qualifyAs lusr cnv @@ -335,7 +326,7 @@ updateLocalConversationAccess :: Local ConvId -> Local UserId -> ConnId -> - Public.ConversationAccessData -> + ConversationAccessData -> Sem r (UpdateResult Event) updateLocalConversationAccess lcnv lusr con = getUpdateResult @@ -346,7 +337,7 @@ updateRemoteConversationAccess :: Remote ConvId -> Local UserId -> ConnId -> - Public.ConversationAccessData -> + ConversationAccessData -> Sem r (UpdateResult Event) updateRemoteConversationAccess _ _ _ _ = throw FederationNotImplemented @@ -366,7 +357,7 @@ updateConversationReceiptMode :: Local UserId -> ConnId -> Qualified ConvId -> - Public.ConversationReceiptModeUpdate -> + ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateConversationReceiptMode lusr zcon qcnv update = do let doUpdate = @@ -391,7 +382,7 @@ updateConversationReceiptModeUnqualified :: Local UserId -> ConnId -> ConvId -> - Public.ConversationReceiptModeUpdate -> + ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateConversationReceiptModeUnqualified lusr zcon cnv update = do let lcnv = qualifyAs lusr cnv @@ -412,7 +403,7 @@ updateLocalConversationReceiptMode :: Local ConvId -> Local UserId -> ConnId -> - Public.ConversationReceiptModeUpdate -> + ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateLocalConversationReceiptMode lcnv lusr con update = getUpdateResult $ @@ -423,7 +414,7 @@ updateRemoteConversationReceiptMode :: Remote ConvId -> Local UserId -> ConnId -> - Public.ConversationReceiptModeUpdate -> + ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) updateRemoteConversationReceiptMode _ _ _ _ = throw FederationNotImplemented @@ -442,7 +433,7 @@ updateConversationMessageTimerUnqualified :: Local UserId -> ConnId -> ConvId -> - Public.ConversationMessageTimerUpdate -> + ConversationMessageTimerUpdate -> Sem r (UpdateResult Event) updateConversationMessageTimerUnqualified lusr zcon cnv update = do let lcnv = qualifyAs lusr cnv @@ -464,7 +455,7 @@ updateConversationMessageTimer :: Local UserId -> ConnId -> Qualified ConvId -> - Public.ConversationMessageTimerUpdate -> + ConversationMessageTimerUpdate -> Sem r (UpdateResult Event) updateConversationMessageTimer lusr zcon qcnv update = do foldQualified @@ -489,7 +480,7 @@ updateLocalConversationMessageTimer :: Local UserId -> ConnId -> Local ConvId -> - Public.ConversationMessageTimerUpdate -> + ConversationMessageTimerUpdate -> Sem r (UpdateResult Event) updateLocalConversationMessageTimer lusr con lcnv update = getUpdateResult $ @@ -522,7 +513,7 @@ deleteLocalConversation lusr con lcnv = getUpdateResult :: Sem (Error NoChanges ': r) a -> Sem r (UpdateResult a) getUpdateResult = fmap (either (const Unchanged) Updated) . runError -addCodeH :: +addCodeUnqualified :: forall r. ( Member CodeStore r, Member ConversationStore r, @@ -534,18 +525,14 @@ addCodeH :: Member (Input Opts) r, Member TeamFeatureStore r ) => - UserId ::: ConnId ::: ConvId -> - Sem r Response -addCodeH (usr ::: zcon ::: cnv) = do + UserId -> + ConnId -> + ConvId -> + Sem r AddCodeResult +addCodeUnqualified usr zcon cnv = do lusr <- qualifyLocal usr lcnv <- qualifyLocal cnv - addCode lusr zcon lcnv <&> \case - CodeAdded event -> json event & setStatus status201 - CodeAlreadyExisted conversationCode -> json conversationCode & setStatus status200 - -data AddCodeResult - = CodeAdded Public.Event - | CodeAlreadyExisted Public.ConversationCode + addCode lusr zcon lcnv addCode :: forall r. @@ -591,7 +578,7 @@ addCode lusr zcon lcnv = do ensureGuestsOrNonTeamMembersAllowed conv = unless (GuestAccessRole `Set.member` convAccessRoles conv || NonTeamMemberAccessRole `Set.member` convAccessRoles conv) $ throw ConvAccessDenied -rmCodeH :: +rmCodeUnqualified :: Members '[ CodeStore, ConversationStore, @@ -602,12 +589,13 @@ rmCodeH :: Input UTCTime ] r => - UserId ::: ConnId ::: ConvId -> - Sem r Response -rmCodeH (usr ::: zcon ::: cnv) = do - lusr <- qualifyLocal usr + Local UserId -> + ConnId -> + ConvId -> + Sem r Event +rmCodeUnqualified lusr zcon cnv = do lcnv <- qualifyLocal cnv - setStatus status200 . json <$> rmCode lusr zcon lcnv + rmCode lusr zcon lcnv rmCode :: Members @@ -622,7 +610,7 @@ rmCode :: Local UserId -> ConnId -> Local ConvId -> - Sem r Public.Event + Sem r Event rmCode lusr zcon lcnv = do conv <- E.getConversation (tUnqualified lcnv) >>= note ConvNotFound @@ -636,20 +624,6 @@ rmCode lusr zcon lcnv = do pushConversationEvent (Just zcon) event (qualifyAs lusr (map lmId users)) bots pure event -getCodeH :: - forall r. - ( Member CodeStore r, - Member ConversationStore r, - Member (Error CodeError) r, - Member (Error ConversationError) r, - Member (Input Opts) r, - Member TeamFeatureStore r - ) => - UserId ::: ConvId -> - Sem r Response -getCodeH (usr ::: cnv) = - setStatus status200 . json <$> getCode usr cnv - getCode :: forall r. ( Member CodeStore r, @@ -659,66 +633,30 @@ getCode :: Member (Input Opts) r, Member TeamFeatureStore r ) => - UserId -> + Local UserId -> ConvId -> - Sem r Public.ConversationCode -getCode usr cnv = do + Sem r ConversationCode +getCode lusr cnv = do conv <- E.getConversation cnv >>= note ConvNotFound Query.ensureGuestLinksEnabled conv ensureAccess conv CodeAccess - ensureConvMember (Data.convLocalMembers conv) usr + ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) key <- E.makeKey cnv c <- E.getCode key ReusableCode >>= note CodeNotFound returnCode c -returnCode :: Member CodeStore r => Code -> Sem r Public.ConversationCode +returnCode :: Member CodeStore r => Code -> Sem r ConversationCode returnCode c = do - Public.mkConversationCode (codeKey c) (codeValue c) <$> E.getConversationCodeURI - -checkReusableCodeH :: - Members '[CodeStore, Error CodeError, WaiRoutes] r => - JsonRequest Public.ConversationCode -> - Sem r Response -checkReusableCodeH req = do - convCode <- fromJsonBody req - checkReusableCode convCode - pure empty + mkConversationCode (codeKey c) (codeValue c) <$> E.getConversationCodeURI checkReusableCode :: Members '[CodeStore, Error CodeError] r => - Public.ConversationCode -> + ConversationCode -> Sem r () checkReusableCode convCode = void $ verifyReusableCode convCode -joinConversationByReusableCodeH :: - Members - '[ BrigAccess, - CodeStore, - ConversationStore, - FederatorAccess, - Error ActionError, - Error CodeError, - Error ConversationError, - Error NotATeamMember, - ExternalAccess, - GundeckAccess, - Input (Local ()), - Input Opts, - Input UTCTime, - MemberStore, - TeamStore, - WaiRoutes - ] - r => - UserId ::: ConnId ::: JsonRequest Public.ConversationCode -> - Sem r Response -joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do - lusr <- qualifyLocal zusr - convCode <- fromJsonBody req - handleUpdateResult <$> joinConversationByReusableCode lusr zcon convCode - joinConversationByReusableCode :: Members '[ BrigAccess, @@ -739,35 +677,12 @@ joinConversationByReusableCode :: r => Local UserId -> ConnId -> - Public.ConversationCode -> + ConversationCode -> Sem r (UpdateResult Event) joinConversationByReusableCode lusr zcon convCode = do c <- verifyReusableCode convCode joinConversation lusr zcon (codeConversation c) CodeAccess -joinConversationByIdH :: - Members - '[ BrigAccess, - FederatorAccess, - ConversationStore, - Error ActionError, - Error ConversationError, - Error NotATeamMember, - ExternalAccess, - GundeckAccess, - Input (Local ()), - Input Opts, - Input UTCTime, - MemberStore, - TeamStore - ] - r => - UserId ::: ConnId ::: ConvId ::: JSON -> - Sem r Response -joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = do - lusr <- qualifyLocal zusr - handleUpdateResult <$> joinConversationById lusr zcon cnv - joinConversationById :: Members '[ BrigAccess, @@ -855,11 +770,11 @@ addMembersUnqualified :: Local UserId -> ConnId -> ConvId -> - Public.Invite -> + Invite -> Sem r (UpdateResult Event) -addMembersUnqualified lusr zcon cnv (Public.Invite users role) = do +addMembersUnqualified lusr zcon cnv (Invite users role) = do let qusers = fmap (qUntagged . qualifyAs lusr) (toNonEmpty users) - addMembers lusr zcon cnv (Public.InviteQualified qusers role) + addMembers lusr zcon cnv (InviteQualified qusers role) addMembers :: Members @@ -884,9 +799,9 @@ addMembers :: Local UserId -> ConnId -> ConvId -> - Public.InviteQualified -> + InviteQualified -> Sem r (UpdateResult Event) -addMembers lusr zcon cnv (Public.InviteQualified users role) = do +addMembers lusr zcon cnv (InviteQualified users role) = do let lcnv = qualifyAs lusr cnv getUpdateResult $ updateLocalConversation lcnv (qUntagged lusr) (Just zcon) $ @@ -905,7 +820,7 @@ updateSelfMember :: Local UserId -> ConnId -> Qualified ConvId -> - Public.MemberUpdate -> + MemberUpdate -> Sem r () updateSelfMember lusr zcon qcnv update = do exists <- foldQualified lusr checkLocalMembership checkRemoteMembership qcnv @@ -954,7 +869,7 @@ updateUnqualifiedSelfMember :: Local UserId -> ConnId -> ConvId -> - Public.MemberUpdate -> + MemberUpdate -> Sem r () updateUnqualifiedSelfMember lusr zcon cnv update = do let lcnv = qualifyAs lusr cnv @@ -977,7 +892,7 @@ updateOtherMemberUnqualified :: ConnId -> ConvId -> UserId -> - Public.OtherMemberUpdate -> + OtherMemberUpdate -> Sem r () updateOtherMemberUnqualified lusr zcon cnv victim update = do let lcnv = qualifyAs lusr cnv @@ -1002,7 +917,7 @@ updateOtherMember :: ConnId -> Qualified ConvId -> Qualified UserId -> - Public.OtherMemberUpdate -> + OtherMemberUpdate -> Sem r () updateOtherMember lusr zcon qcnv qvictim update = do let doUpdate = foldQualified lusr updateOtherMemberLocalConv updateOtherMemberRemoteConv @@ -1025,7 +940,7 @@ updateOtherMemberLocalConv :: Local UserId -> ConnId -> Qualified UserId -> - Public.OtherMemberUpdate -> + OtherMemberUpdate -> Sem r () updateOtherMemberLocalConv lcnv lusr con qvictim update = void . getUpdateResult $ do when (qUntagged lusr == qvictim) $ @@ -1039,7 +954,7 @@ updateOtherMemberRemoteConv :: Local UserId -> ConnId -> Qualified UserId -> - Public.OtherMemberUpdate -> + OtherMemberUpdate -> Sem r () updateOtherMemberRemoteConv _ _ _ _ _ = throw FederationNotImplemented @@ -1154,77 +1069,6 @@ removeMemberFromLocalConv lcnv lusr con = -- OTR -data OtrResult - = OtrSent !Public.ClientMismatch - | OtrMissingRecipients !Public.ClientMismatch - | OtrUnknownClient !UnknownClient - | OtrConversationNotFound !ConvNotFound - -handleOtrResult :: - Members - '[ Error ClientError, - Error ConversationError - ] - r => - OtrResult -> - Sem r Response -handleOtrResult = - \case - OtrSent m -> pure $ json m & setStatus status201 - OtrMissingRecipients m -> pure $ json m & setStatus status412 - OtrUnknownClient _ -> throw UnknownClient - OtrConversationNotFound _ -> throw ConvNotFound - -postBotMessageH :: - Members - '[ BrigAccess, - ClientStore, - ConversationStore, - Error ClientError, - Error ConversationError, - Error LegalHoldError, - GundeckAccess, - ExternalAccess, - Input (Local ()), - Input Opts, - Input UTCTime, - MemberStore, - TeamStore, - TinyLog, - WaiRoutes - ] - r => - BotId ::: ConvId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage ::: JSON -> - Sem r Response -postBotMessageH (zbot ::: cnv ::: val ::: req ::: _) = do - lbot <- qualifyLocal zbot - lcnv <- qualifyLocal cnv - message <- fromJsonBody req - let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postBotMessage lbot lcnv val' message - -postBotMessage :: - Members - '[ BrigAccess, - ClientStore, - ConversationStore, - Error LegalHoldError, - ExternalAccess, - GundeckAccess, - Input Opts, - Input UTCTime, - MemberStore, - TeamStore, - TinyLog - ] - r => - Local BotId -> - Local ConvId -> - Public.OtrFilterMissing -> - Public.NewOtrMessage -> - Sem r OtrResult -postBotMessage zbot = postNewOtrMessage Bot (fmap botUserId zbot) Nothing - postProteusMessage :: Members '[ BotAccess, @@ -1244,8 +1088,8 @@ postProteusMessage :: Local UserId -> ConnId -> Qualified ConvId -> - RawProto Public.QualifiedNewOtrMessage -> - Sem r (Public.PostOtrResponse Public.MessageSendingStatus) + RawProto QualifiedNewOtrMessage -> + Sem r (PostOtrResponse MessageSendingStatus) postProteusMessage sender zcon conv msg = runLocalInput sender $ do foldQualified sender @@ -1253,114 +1097,74 @@ postProteusMessage sender zcon conv msg = runLocalInput sender $ do (\c -> postRemoteOtrMessage (qUntagged sender) c (rpRaw msg)) conv -postOtrMessageUnqualified :: - Members - '[ BotAccess, - BrigAccess, - ClientStore, - ConversationStore, - FederatorAccess, - GundeckAccess, - ExternalAccess, - MemberStore, - Input Opts, - Input UTCTime, - TeamStore, - TinyLog - ] - r => - Local UserId -> - ConnId -> - ConvId -> - Maybe Public.IgnoreMissing -> - Maybe Public.ReportMissing -> - Public.NewOtrMessage -> - Sem r (Public.PostOtrResponse Public.ClientMismatch) -postOtrMessageUnqualified sender zcon cnv ignoreMissing reportMissing message = do - let lcnv = qualifyAs sender cnv - localDomain = tDomain sender +unqualifyEndpoint :: + Functor f => + Local x -> + (QualifiedNewOtrMessage -> f (PostOtrResponse MessageSendingStatus)) -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + f (PostOtrResponse ClientMismatch) +unqualifyEndpoint loc f ignoreMissing reportMissing message = do let qualifiedRecipients = - Public.QualifiedOtrRecipients + QualifiedOtrRecipients . QualifiedUserClientMap - . Map.singleton localDomain + . Map.singleton (tDomain loc) . userClientMap . fmap fromBase64TextLenient - . Public.otrRecipientsMap - . Public.newOtrRecipients + . otrRecipientsMap + . newOtrRecipients $ message - clientMismatchStrategy = legacyClientMismatchStrategy localDomain (newOtrReportMissing message) ignoreMissing reportMissing + clientMismatchStrategy = legacyClientMismatchStrategy (tDomain loc) (newOtrReportMissing message) ignoreMissing reportMissing qualifiedMessage = - Public.QualifiedNewOtrMessage - { Public.qualifiedNewOtrSender = newOtrSender message, - Public.qualifiedNewOtrRecipients = qualifiedRecipients, - Public.qualifiedNewOtrNativePush = newOtrNativePush message, - Public.qualifiedNewOtrTransient = newOtrTransient message, - Public.qualifiedNewOtrNativePriority = newOtrNativePriority message, - Public.qualifiedNewOtrData = maybe mempty fromBase64TextLenient (newOtrData message), - Public.qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy + QualifiedNewOtrMessage + { qualifiedNewOtrSender = newOtrSender message, + qualifiedNewOtrRecipients = qualifiedRecipients, + qualifiedNewOtrNativePush = newOtrNativePush message, + qualifiedNewOtrTransient = newOtrTransient message, + qualifiedNewOtrNativePriority = newOtrNativePriority message, + qualifiedNewOtrData = maybe mempty fromBase64TextLenient (newOtrData message), + qualifiedNewOtrClientMismatchStrategy = clientMismatchStrategy } - runLocalInput sender $ - unqualify localDomain - <$> postQualifiedOtrMessage User (qUntagged sender) (Just zcon) lcnv qualifiedMessage - -postProtoOtrBroadcastH :: - Members - '[ BrigAccess, - ClientStore, - Error ActionError, - Error ClientError, - Error ConversationError, - Error LegalHoldError, - Error TeamError, - GundeckAccess, - Input (Local ()), - Input Opts, - Input UTCTime, - TeamStore, - TinyLog, - WaiRoutes - ] - r => - UserId ::: ConnId ::: Public.OtrFilterMissing ::: Request ::: JSON -> - Sem r Response -postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do - lusr <- qualifyLocal zusr - message <- Public.protoToNewOtrMessage <$> fromProtoBody req - let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast lusr zcon val' message + unqualify (tDomain loc) <$> f qualifiedMessage -postOtrBroadcastH :: +postBotMessageUnqualified :: Members '[ BrigAccess, ClientStore, - Error ActionError, - Error ClientError, - Error ConversationError, - Error LegalHoldError, - Error TeamError, + ConversationStore, + ExternalAccess, + FederatorAccess, GundeckAccess, Input (Local ()), Input Opts, Input UTCTime, + MemberStore, TeamStore, - TinyLog, - WaiRoutes + TinyLog ] r => - UserId ::: ConnId ::: Public.OtrFilterMissing ::: JsonRequest Public.NewOtrMessage -> - Sem r Response -postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do - lusr <- qualifyLocal zusr - message <- fromJsonBody req - let val' = allowOtrFilterMissingInBody val message - handleOtrResult =<< postOtrBroadcast lusr zcon val' message + BotId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> + NewOtrMessage -> + Sem r (PostOtrResponse ClientMismatch) +postBotMessageUnqualified sender cnv ignoreMissing reportMissing message = do + lusr <- qualifyLocal (botUserId sender) + lcnv <- qualifyLocal cnv + unqualifyEndpoint + lusr + (runLocalInput lusr . postQualifiedOtrMessage Bot (qUntagged lusr) Nothing lcnv) + ignoreMissing + reportMissing + message -postOtrBroadcast :: +postOtrBroadcastUnqualified :: Members '[ BrigAccess, ClientStore, Error ActionError, - Error LegalHoldError, Error TeamError, GundeckAccess, Input Opts, @@ -1371,114 +1175,43 @@ postOtrBroadcast :: r => Local UserId -> ConnId -> - Public.OtrFilterMissing -> - Public.NewOtrMessage -> - Sem r OtrResult -postOtrBroadcast lusr zcon = postNewOtrBroadcast lusr (Just zcon) - --- internal OTR helpers - --- This is a work-around for the fact that we sometimes want to send larger lists of user ids --- in the filter query than fits the url length limit. for details, see --- https://github.com/zinfra/backend-issues/issues/1248 -allowOtrFilterMissingInBody :: OtrFilterMissing -> NewOtrMessage -> OtrFilterMissing -allowOtrFilterMissingInBody val (NewOtrMessage _ _ _ _ _ _ mrepmiss) = case mrepmiss of - Nothing -> val - Just uids -> OtrReportMissing $ Set.fromList uids - --- | bots are not supported on broadcast -postNewOtrBroadcast :: - Members - '[ BrigAccess, - ClientStore, - Error ActionError, - Error LegalHoldError, - Error TeamError, - Input Opts, - Input UTCTime, - GundeckAccess, - TeamStore, - TinyLog - ] - r => - Local UserId -> - Maybe ConnId -> - OtrFilterMissing -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> NewOtrMessage -> - Sem r OtrResult -postNewOtrBroadcast lusr con val msg = do - let sender = newOtrSender msg - recvrs = newOtrRecipients msg - now <- input - withValidOtrBroadcastRecipients (tUnqualified lusr) sender recvrs val now $ \rs -> do - let (_, toUsers) = foldr (newMessage (qUntagged lusr) con Nothing msg now) ([], []) rs - E.push (catMaybes toUsers) + Sem r (PostOtrResponse ClientMismatch) +postOtrBroadcastUnqualified sender zcon = + unqualifyEndpoint + sender + (postBroadcast sender (Just zcon)) -postNewOtrMessage :: +postOtrMessageUnqualified :: Members - '[ BrigAccess, + '[ BotAccess, + BrigAccess, ClientStore, ConversationStore, - Error LegalHoldError, - ExternalAccess, + FederatorAccess, GundeckAccess, + ExternalAccess, + MemberStore, Input Opts, Input UTCTime, - MemberStore, TeamStore, TinyLog ] r => - UserType -> Local UserId -> - Maybe ConnId -> - Local ConvId -> - OtrFilterMissing -> - NewOtrMessage -> - Sem r OtrResult -postNewOtrMessage utype lusr con lcnv val msg = do - let sender = newOtrSender msg - recvrs = newOtrRecipients msg - now <- input - withValidOtrRecipients utype (tUnqualified lusr) sender (tUnqualified lcnv) recvrs val now $ \rs -> do - let (toBots, toUsers) = foldr (newMessage (qUntagged lusr) con (Just (qUntagged lcnv)) msg now) ([], []) rs - E.push (catMaybes toUsers) - E.deliverAndDeleteAsync (tUnqualified lcnv) toBots - -newMessage :: - Qualified UserId -> - Maybe ConnId -> - -- | Conversation Id (if Nothing, recipient's self conversation is used) - Maybe (Qualified ConvId) -> + ConnId -> + ConvId -> + Maybe IgnoreMissing -> + Maybe ReportMissing -> NewOtrMessage -> - UTCTime -> - (LocalMember, ClientId, Text) -> - ([(BotMember, Event)], [Maybe Push]) -> - ([(BotMember, Event)], [Maybe Push]) -newMessage qusr con qcnv msg now (m, c, t) ~(toBots, toUsers) = - let o = - OtrMessage - { otrSender = newOtrSender msg, - otrRecipient = c, - otrCiphertext = t, - otrData = newOtrData msg - } - -- use recipient's client's self conversation on broadcast - -- (with federation, this might not work for remote members) - -- FUTUREWORK: for remote recipients, set the domain correctly here - qconv = fromMaybe ((`Qualified` qDomain qusr) . selfConv $ lmId m) qcnv - e = Event OtrMessageAdd qconv qusr now (EdOtrMessage o) - r = recipient m & recipientClients .~ RecipientClientsSome (singleton c) - in case newBotMember m of - Just b -> ((b, e) : toBots, toUsers) - Nothing -> - let p = - newPushLocal ListComplete (qUnqualified (evtFrom e)) (ConvEvent e) [r] - <&> set pushConn con - . set pushNativePriority (newOtrNativePriority msg) - . set pushRoute (bool RouteDirect RouteAny (newOtrNativePush msg)) - . set pushTransient (newOtrTransient msg) - in (toBots, p : toUsers) + Sem r (PostOtrResponse ClientMismatch) +postOtrMessageUnqualified sender zcon cnv = + let lcnv = qualifyAs sender cnv + in unqualifyEndpoint + sender + (runLocalInput sender . postQualifiedOtrMessage User (qUntagged sender) (Just zcon) lcnv) updateConversationName :: Members @@ -1496,8 +1229,8 @@ updateConversationName :: Local UserId -> ConnId -> Qualified ConvId -> - Public.ConversationRename -> - Sem r (Maybe Public.Event) + ConversationRename -> + Sem r (Maybe Event) updateConversationName lusr zcon qcnv convRename = do foldQualified lusr @@ -1521,8 +1254,8 @@ updateUnqualifiedConversationName :: Local UserId -> ConnId -> ConvId -> - Public.ConversationRename -> - Sem r (Maybe Public.Event) + ConversationRename -> + Sem r (Maybe Event) updateUnqualifiedConversationName lusr zcon cnv rename = do let lcnv = qualifyAs lusr cnv updateLocalConversationName lusr zcon lcnv rename @@ -1542,8 +1275,8 @@ updateLocalConversationName :: Local UserId -> ConnId -> Local ConvId -> - Public.ConversationRename -> - Sem r (Maybe Public.Event) + ConversationRename -> + Sem r (Maybe Event) updateLocalConversationName lusr zcon lcnv convRename = do alive <- E.isConversationAlive (tUnqualified lcnv) if alive @@ -1565,13 +1298,13 @@ updateLiveLocalConversationName :: Local UserId -> ConnId -> Local ConvId -> - Public.ConversationRename -> - Sem r (Maybe Public.Event) + ConversationRename -> + Sem r (Maybe Event) updateLiveLocalConversationName lusr con lcnv rename = fmap hush . runError @NoChanges $ updateLocalConversation lcnv (qUntagged lusr) (Just con) rename -isTypingH :: +isTypingUnqualified :: Members '[ Error ConversationError, GundeckAccess, @@ -1581,21 +1314,21 @@ isTypingH :: WaiRoutes ] r => - UserId ::: ConnId ::: ConvId ::: JsonRequest Public.TypingData -> - Sem r Response -isTypingH (zusr ::: zcon ::: cnv ::: req) = do - lusr <- qualifyLocal zusr + Local UserId -> + ConnId -> + ConvId -> + TypingData -> + Sem r () +isTypingUnqualified lusr zcon cnv typingData = do lcnv <- qualifyLocal cnv - typingData <- fromJsonBody req isTyping lusr zcon lcnv typingData - pure empty isTyping :: Members '[Error ConversationError, GundeckAccess, Input UTCTime, MemberStore] r => Local UserId -> ConnId -> Local ConvId -> - Public.TypingData -> + TypingData -> Sem r () isTyping lusr zcon lcnv typingData = do mm <- E.getLocalMembers (tUnqualified lcnv) @@ -1779,240 +1512,3 @@ rmBot lusr zcon b = do ensureConvMember :: Member (Error ConversationError) r => [LocalMember] -> UserId -> Sem r () ensureConvMember users usr = unless (usr `isMember` users) $ throw ConvNotFound - -------------------------------------------------------------------------------- --- OtrRecipients Validation - -data CheckedOtrRecipients - = -- | Valid sender (user and client) and no missing recipients, - -- or missing recipients have been willfully ignored. - ValidOtrRecipients !ClientMismatch [(LocalMember, ClientId, Text)] - | -- | Missing recipients. - MissingOtrRecipients !ClientMismatch - | -- | Invalid sender (user). - InvalidOtrSenderUser - | -- | Invalid sender (client). - InvalidOtrSenderClient - --- | bots are not supported on broadcast -withValidOtrBroadcastRecipients :: - forall r. - Members - '[ BrigAccess, - ClientStore, - Error ActionError, - Error LegalHoldError, - Error TeamError, - Input Opts, - TeamStore, - TinyLog - ] - r => - UserId -> - ClientId -> - OtrRecipients -> - OtrFilterMissing -> - UTCTime -> - ([(LocalMember, ClientId, Text)] -> Sem r ()) -> - Sem r OtrResult -withValidOtrBroadcastRecipients usr clt rcps val now go = withBindingTeam usr $ \tid -> do - limit <- fromIntegral . fromRange <$> E.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) $ - 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. - tMembers <- - fmap (view userId) <$> case val of - OtrReportMissing us -> maybeFetchLimitedTeamMemberList limit tid us - _ -> maybeFetchAllMembersInTeam tid - contacts <- E.getContactList usr - let users = Set.toList $ Set.union (Set.fromList tMembers) (Set.fromList contacts) - isInternal <- E.useIntraClientListing - clts <- - 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 - -- Get the users in the filter (remote ids are not in a local team) - 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) $ - throw BroadcastLimitExceeded - E.selectTeamMembers tid localUserIdsToLookup - maybeFetchAllMembersInTeam :: TeamId -> Sem r [TeamMember] - maybeFetchAllMembersInTeam tid = do - mems <- getTeamMembersForFanout tid - when (mems ^. teamMemberListType == ListTruncated) $ - throw BroadcastLimitExceeded - pure (mems ^. teamMembers) - -withValidOtrRecipients :: - Members - '[ BrigAccess, - ClientStore, - ConversationStore, - Error LegalHoldError, - Input Opts, - MemberStore, - TeamStore, - TinyLog - ] - r => - UserType -> - UserId -> - ClientId -> - ConvId -> - OtrRecipients -> - OtrFilterMissing -> - UTCTime -> - ([(LocalMember, ClientId, Text)] -> Sem r ()) -> - Sem r OtrResult -withValidOtrRecipients utype usr clt cnv rcps val now go = do - alive <- E.isConversationAlive cnv - if not alive - then do - E.deleteConversation cnv - pure $ OtrConversationNotFound mkErrorDescription - else do - localMembers <- E.getLocalMembers cnv - let localMemberIds = lmId <$> localMembers - isInternal <- E.useIntraClientListing - clts <- - if isInternal - then Clients.fromUserClients <$> E.lookupClients localMemberIds - else E.getClients localMemberIds - handleOtrResponse utype usr clt rcps localMembers clts val now go - -handleOtrResponse :: - Members '[BrigAccess, Error LegalHoldError, Input Opts, TeamStore, TinyLog] r => - -- | Type of proposed sender (user / bot) - UserType -> - -- | Proposed sender (user) - UserId -> - -- | Proposed sender (client) - ClientId -> - -- | Proposed recipients (users & clients). - OtrRecipients -> - -- | Members to consider as valid recipients. - [LocalMember] -> - -- | Clients to consider as valid recipients. - Clients -> - -- | How to filter missing clients. - OtrFilterMissing -> - -- | The current timestamp. - UTCTime -> - -- | Callback if OtrRecipients are valid - ([(LocalMember, ClientId, Text)] -> Sem r ()) -> - Sem r OtrResult -handleOtrResponse utype usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of - ValidOtrRecipients m r -> go r >> pure (OtrSent m) - MissingOtrRecipients m -> mapError @LegalholdConflicts (const MissingLegalholdConsent) $ do - guardLegalholdPolicyConflicts (userToProtectee utype usr) (missingClients m) - pure (OtrMissingRecipients m) - InvalidOtrSenderUser -> pure $ OtrConversationNotFound mkErrorDescription - InvalidOtrSenderClient -> pure $ OtrUnknownClient mkErrorDescription - --- | Check OTR sender and recipients for validity and completeness --- against a given list of valid members and clients, optionally --- ignoring missing clients. Returns 'ValidOtrRecipients' on success --- for further processing. -checkOtrRecipients :: - -- | Proposed sender (user) - UserId -> - -- | Proposed sender (client) - ClientId -> - -- | Proposed recipients (users & clients). - OtrRecipients -> - -- | Members to consider as valid recipients. - [LocalMember] -> - -- | Clients to consider as valid recipients. - Clients -> - -- | How to filter missing clients. - OtrFilterMissing -> - -- | The current timestamp. - UTCTime -> - CheckedOtrRecipients -checkOtrRecipients usr sid prs vms vcs val now - | not (Map.member usr vmembers) = InvalidOtrSenderUser - | not (Clients.contains usr sid vcs) = InvalidOtrSenderClient - | not (Clients.null missing) = MissingOtrRecipients mismatch - | otherwise = ValidOtrRecipients mismatch yield - where - yield :: [(LocalMember, ClientId, Text)] - yield = foldrOtrRecipients next [] prs - - next :: r ~ [(LocalMember, ClientId, c)] => UserId -> ClientId -> c -> r -> r - next u c t rs - | Just m <- member u c = (m, c, t) : rs - | otherwise = rs - - member :: UserId -> ClientId -> Maybe LocalMember - member u c - | Just m <- Map.lookup u vmembers, - Clients.contains u c vclients = - Just m - | otherwise = Nothing - - -- Valid recipient members & clients - vmembers :: Map UserId LocalMember - vmembers = Map.fromList $ map (\m -> (lmId m, m)) vms - - vclients :: Clients - vclients = Clients.rmClient usr sid vcs - - -- Proposed (given) recipients - recipients :: Map UserId (Map ClientId Text) - recipients = userClientMap (otrRecipientsMap prs) - - given :: Clients - given = Clients.fromMap (Map.map Map.keysSet recipients) - - -- Differences between valid and proposed recipients - missing, unknown, deleted, redundant :: Clients - missing = filterMissing (Clients.diff vclients given) - unknown = Clients.diff given vcs - deleted = Clients.filter (`Map.member` vmembers) unknown - redundant = - Clients.diff unknown deleted - & if Clients.contains usr sid given - then Clients.insert usr sid - else id - - mismatch :: ClientMismatch - mismatch = - ClientMismatch - { cmismatchTime = toUTCTimeMillis now, - missingClients = UserClients (Clients.toMap missing), - redundantClients = UserClients (Clients.toMap redundant), - deletedClients = UserClients (Clients.toMap deleted) - } - - filterMissing :: Clients -> Clients - filterMissing miss = case val of - OtrReportAllMissing -> miss - OtrIgnoreAllMissing -> Clients.nil - OtrReportMissing us -> Clients.filter (`Set.member` us) miss - OtrIgnoreMissing us -> Clients.filter (`Set.notMember` us) miss - --- Copied from 'Galley.API.Team' to break import cycles -withBindingTeam :: - Members - '[ Error TeamError, - TeamStore - ] - r => - UserId -> - (TeamId -> Sem r b) -> - Sem r b -withBindingTeam zusr callback = do - tid <- E.getOneUserTeam zusr >>= note TeamNotFound - binding <- E.getTeamBinding tid >>= note TeamNotFound - case binding of - Binding -> callback tid - NonBinding -> throw NotABindingTeamMember diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 7521bc0d7de..9fa4dd42d63 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -37,6 +37,7 @@ module Galley.Effects.TeamStore getUserTeams, getUsersTeams, getOneUserTeam, + lookupBindingTeam, -- ** Update teams deleteTeamConversation, @@ -75,12 +76,14 @@ where import Data.Id import Data.Range +import Galley.API.Error import Galley.Effects.ListItems import Galley.Effects.Paging import Galley.Types.Teams import Galley.Types.Teams.Intra import Imports import Polysemy +import Polysemy.Error import qualified Proto.TeamEvents as E data TeamStore m a where @@ -128,3 +131,18 @@ listTeams :: PagingBounds p TeamId -> Sem r (Page p TeamId) listTeams = listItems + +lookupBindingTeam :: + Members + '[ Error TeamError, + TeamStore + ] + r => + UserId -> + Sem r TeamId +lookupBindingTeam zusr = do + tid <- getOneUserTeam zusr >>= note TeamNotFound + binding <- getTeamBinding tid >>= note TeamNotFound + case binding of + Binding -> return tid + NonBinding -> throw NotABindingTeamMember diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 6ee4dc27b6a..8ddea637422 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -39,6 +39,7 @@ import Data.ByteString.Lazy (fromStrict) import Data.Csv (FromNamedRecord (..), decodeByName) import qualified Data.Currency as Currency import Data.Id +import Data.Json.Util hiding ((#)) import qualified Data.LegalHold as LH import Data.List1 import qualified Data.List1 as List1 @@ -1624,7 +1625,12 @@ postCryptoBroadcastMessageJson = do ac2 <- randomClient alice (someLastPrekeys !! 4) -- Complete: Alice broadcasts a message to Bob,Charlie,Dan and herself let t = 1 # Second -- WS receive timeout - let msg = [(alice, ac2, "ciphertext0"), (bob, bc, "ciphertext1"), (charlie, cc, "ciphertext2"), (dan, dc, "ciphertext3")] + let msg = + [ (alice, ac2, toBase64Text "ciphertext0"), + (bob, bc, toBase64Text "ciphertext1"), + (charlie, cc, toBase64Text "ciphertext2"), + (dan, dc, toBase64Text "ciphertext3") + ] WS.bracketRN c [bob, charlie, dan] $ \[wsB, wsC, wsD] -> -- Alice's clients 1 and 2 listen to their own messages only WS.bracketR (c . queryItem "client" (toByteString' ac2)) alice $ \wsA2 -> @@ -1633,15 +1639,19 @@ postCryptoBroadcastMessageJson = do const 201 === statusCode assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext1") + void . liftIO $ + WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext1")) -- Charlie should get the broadcast (contact of alice and user of teams feature) - void . liftIO $ WS.assertMatch t wsC (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext2") + void . liftIO $ + WS.assertMatch t wsC (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext2")) -- Dan should get the broadcast (contact of alice and not user of teams feature) - void . liftIO $ WS.assertMatch t wsD (wsAssertOtr (q (selfConv dan)) (q alice) ac dc "ciphertext3") + void . liftIO $ + WS.assertMatch t wsD (wsAssertOtr (q (selfConv dan)) (q alice) ac dc (toBase64Text "ciphertext3")) -- Alice's first client should not get the broadcast - assertNoMsg wsA1 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac "ciphertext0") + assertNoMsg wsA1 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac (toBase64Text "ciphertext0")) -- Alice's second client should get the broadcast - void . liftIO $ WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 "ciphertext0") + void . liftIO $ + WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 (toBase64Text "ciphertext0")) postCryptoBroadcastMessageJsonFilteredTooLargeTeam :: TestM () postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do @@ -1672,7 +1682,12 @@ postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do ac2 <- randomClient alice (someLastPrekeys !! 4) -- Complete: Alice broadcasts a message to Bob,Charlie,Dan and herself let t = 1 # Second -- WS receive timeout - let msg = [(alice, ac2, "ciphertext0"), (bob, bc, "ciphertext1"), (charlie, cc, "ciphertext2"), (dan, dc, "ciphertext3")] + let msg = + [ (alice, ac2, toBase64Text "ciphertext0"), + (bob, bc, toBase64Text "ciphertext1"), + (charlie, cc, toBase64Text "ciphertext2"), + (dan, dc, toBase64Text "ciphertext3") + ] WS.bracketRN c [bob, charlie, dan] $ \[wsB, wsC, wsD] -> -- Alice's clients 1 and 2 listen to their own messages only WS.bracketR (c . queryItem "client" (toByteString' ac2)) alice $ \wsA2 -> @@ -1692,15 +1707,19 @@ postCryptoBroadcastMessageJsonFilteredTooLargeTeam = do const 201 === statusCode assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext1") + void . liftIO $ + WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext1")) -- Charlie should get the broadcast (contact of alice and user of teams feature) - void . liftIO $ WS.assertMatch t wsC (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext2") + void . liftIO $ + WS.assertMatch t wsC (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext2")) -- Dan should get the broadcast (contact of alice and not user of teams feature) - void . liftIO $ WS.assertMatch t wsD (wsAssertOtr (q (selfConv dan)) (q alice) ac dc "ciphertext3") + void . liftIO $ + WS.assertMatch t wsD (wsAssertOtr (q (selfConv dan)) (q alice) ac dc (toBase64Text "ciphertext3")) -- Alice's first client should not get the broadcast - assertNoMsg wsA1 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac "ciphertext0") + assertNoMsg wsA1 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac (toBase64Text "ciphertext0")) -- Alice's second client should get the broadcast - void . liftIO $ WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 "ciphertext0") + void . liftIO $ + WS.assertMatch t wsA2 (wsAssertOtr (q (selfConv alice)) (q alice) ac ac2 (toBase64Text "ciphertext0")) postCryptoBroadcastMessageJsonReportMissingBody :: TestM () postCryptoBroadcastMessageJsonReportMissingBody = do @@ -1736,38 +1755,47 @@ postCryptoBroadcastMessageJson2 = do connectUsers alice (list1 charlie []) let t = 3 # Second -- WS receive timeout -- Missing charlie - let m1 = [(bob, bc, "ciphertext1")] + let m1 = [(bob, bc, toBase64Text "ciphertext1")] Util.postOtrBroadcastMessage id alice ac m1 !!! do const 412 === statusCode assertMismatchWithMessage (Just "1: Only Charlie and his device") [(charlie, Set.singleton cc)] [] [] -- Complete WS.bracketR2 c bob charlie $ \(wsB, wsE) -> do - let m2 = [(bob, bc, "ciphertext2"), (charlie, cc, "ciphertext2")] + let m2 = [(bob, bc, toBase64Text "ciphertext2"), (charlie, cc, toBase64Text "ciphertext2")] Util.postOtrBroadcastMessage id alice ac m2 !!! do const 201 === statusCode assertMismatchWithMessage (Just "No devices expected") [] [] [] - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext2") - void . liftIO $ WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext2") + void . liftIO $ + WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext2")) + void . liftIO $ + WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext2")) -- Redundant self WS.bracketR3 c alice bob charlie $ \(wsA, wsB, wsE) -> do - let m3 = [(alice, ac, "ciphertext3"), (bob, bc, "ciphertext3"), (charlie, cc, "ciphertext3")] + let m3 = + [ (alice, ac, toBase64Text "ciphertext3"), + (bob, bc, toBase64Text "ciphertext3"), + (charlie, cc, toBase64Text "ciphertext3") + ] Util.postOtrBroadcastMessage id alice ac m3 !!! do const 201 === statusCode assertMismatchWithMessage (Just "2: Only Alice and her device") [] [(alice, Set.singleton ac)] [] - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext3") - void . liftIO $ WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext3") + void . liftIO $ + WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext3")) + void . liftIO $ + WS.assertMatch t wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext3")) -- Alice should not get it - assertNoMsg wsA (wsAssertOtr (q (selfConv alice)) (q alice) ac ac "ciphertext3") + assertNoMsg wsA (wsAssertOtr (q (selfConv alice)) (q alice) ac ac (toBase64Text "ciphertext3")) -- Deleted charlie WS.bracketR2 c bob charlie $ \(wsB, wsE) -> do deleteClient charlie cc (Just defPassword) !!! const 200 === statusCode - let m4 = [(bob, bc, "ciphertext4"), (charlie, cc, "ciphertext4")] + let m4 = [(bob, bc, toBase64Text "ciphertext4"), (charlie, cc, toBase64Text "ciphertext4")] Util.postOtrBroadcastMessage id alice ac m4 !!! do const 201 === statusCode assertMismatchWithMessage (Just "3: Only Charlie and his device") [] [] [(charlie, Set.singleton cc)] - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc "ciphertext4") + void . liftIO $ + WS.assertMatch t wsB (wsAssertOtr (q (selfConv bob)) (q alice) ac bc (toBase64Text "ciphertext4")) -- charlie should not get it - assertNoMsg wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc "ciphertext4") + assertNoMsg wsE (wsAssertOtr (q (selfConv charlie)) (q alice) ac cc (toBase64Text "ciphertext4")) postCryptoBroadcastMessageProto :: TestM () postCryptoBroadcastMessageProto = do @@ -1791,18 +1819,18 @@ postCryptoBroadcastMessageProto = do connectUsers alice (list1 charlie [dan]) -- Complete: Alice broadcasts a message to Bob,Charlie,Dan let t = 1 # Second -- WS receive timeout - let ciphertext = encodeCiphertext "hello bob" + let ciphertext = toBase64Text "hello bob" WS.bracketRN c [alice, bob, charlie, dan] $ \ws@[_, wsB, wsC, wsD] -> do let msg = otrRecipients [(bob, [(bc, ciphertext)]), (charlie, [(cc, ciphertext)]), (dan, [(dc, ciphertext)])] Util.postProtoOtrBroadcast alice ac msg !!! do const 201 === statusCode assertMismatch [] [] [] -- Bob should get the broadcast (team member of alice) - void . liftIO $ WS.assertMatch t wsB (wsAssertOtr' (encodeCiphertext "data") (q (selfConv bob)) (q alice) ac bc ciphertext) + void . liftIO $ WS.assertMatch t wsB (wsAssertOtr' (toBase64Text "data") (q (selfConv bob)) (q alice) ac bc ciphertext) -- Charlie should get the broadcast (contact of alice and user of teams feature) - void . liftIO $ WS.assertMatch t wsC (wsAssertOtr' (encodeCiphertext "data") (q (selfConv charlie)) (q alice) ac cc ciphertext) + void . liftIO $ WS.assertMatch t wsC (wsAssertOtr' (toBase64Text "data") (q (selfConv charlie)) (q alice) ac cc ciphertext) -- Dan should get the broadcast (contact of alice and not user of teams feature) - void . liftIO $ WS.assertMatch t wsD (wsAssertOtr' (encodeCiphertext "data") (q (selfConv dan)) (q alice) ac dc ciphertext) + void . liftIO $ WS.assertMatch t wsD (wsAssertOtr' (toBase64Text "data") (q (selfConv dan)) (q alice) ac dc ciphertext) -- Alice should not get her own broadcast WS.assertNoEvent timeout ws let inbody = Just [bob] -- body triggers report @@ -1816,7 +1844,7 @@ postCryptoBroadcastMessageNoTeam = do (alice, ac) <- randomUserWithClient (someLastPrekeys !! 0) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) connectUsers alice (list1 bob []) - let msg = [(bob, bc, "ciphertext1")] + let msg = [(bob, bc, toBase64Text "ciphertext1")] Util.postOtrBroadcastMessage id alice ac msg !!! const 404 === statusCode postCryptoBroadcastMessage100OrMaxConns :: TestM () @@ -1831,16 +1859,17 @@ postCryptoBroadcastMessage100OrMaxConns = do connectUsers alice (list1 bob (fst <$> others)) let t = 3 # Second -- WS receive timeout WS.bracketRN c (bob : (fst <$> others)) $ \ws -> do - let f (u, clt) = (u, clt, "ciphertext") - let msg = (bob, bc, "ciphertext") : (f <$> others) + let f (u, clt) = (u, clt, toBase64Text "ciphertext") + let msg = (bob, bc, toBase64Text "ciphertext") : (f <$> others) Util.postOtrBroadcastMessage id alice ac msg !!! do const 201 === statusCode assertMismatch [] [] [] let qbobself = Qualified (selfConv bob) localDomain - void . liftIO $ WS.assertMatch t (Imports.head ws) (wsAssertOtr qbobself qalice ac bc "ciphertext") + void . liftIO $ + WS.assertMatch t (Imports.head ws) (wsAssertOtr qbobself qalice ac bc (toBase64Text "ciphertext")) for_ (zip (tail ws) others) $ \(wsU, (u, clt)) -> do let qself = Qualified (selfConv u) localDomain - liftIO $ WS.assertMatch t wsU (wsAssertOtr qself qalice ac clt "ciphertext") + liftIO $ WS.assertMatch t wsU (wsAssertOtr qself qalice ac clt (toBase64Text "ciphertext")) where createAndConnectUserWhileLimitNotReached alice remaining acc pk = do (uid, cid) <- randomUserWithClient pk diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index bc920d97035..4cb1ebbd594 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -35,7 +35,6 @@ import Control.Retry (constantDelay, exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import Data.Aeson.Lens (key, _String) import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy @@ -61,7 +60,6 @@ import Data.Range import Data.Serialize (runPut) import qualified Data.Set as Set import Data.String.Conversions (ST, cs) -import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy.Encoding as T import Data.Time (getCurrentTime) @@ -1394,10 +1392,27 @@ assertConvQualifiedWithRole r t c s us n mt role = do _ -> return () return cId -wsAssertOtr :: Qualified ConvId -> Qualified UserId -> ClientId -> ClientId -> Text -> Notification -> IO () +wsAssertOtr :: + HasCallStack => + Qualified ConvId -> + Qualified UserId -> + ClientId -> + ClientId -> + Text -> + Notification -> + IO () wsAssertOtr = wsAssertOtr' "data" -wsAssertOtr' :: Text -> Qualified ConvId -> Qualified UserId -> ClientId -> ClientId -> Text -> Notification -> IO () +wsAssertOtr' :: + HasCallStack => + Text -> + Qualified ConvId -> + Qualified UserId -> + ClientId -> + ClientId -> + Text -> + Notification -> + IO () wsAssertOtr' evData conv usr from to txt n = do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False @@ -1956,9 +1971,6 @@ otrRecipients = OtrRecipients . UserClientMap . buildMap where buildMap = fmap Map.fromList . Map.fromList -encodeCiphertext :: ByteString -> Text -encodeCiphertext = decodeUtf8 . B64.encode - genRandom :: (Q.Arbitrary a, MonadIO m) => m a genRandom = liftIO . Q.generate $ Q.arbitrary diff --git a/services/galley/test/unit/Test/Galley/API/Message.hs b/services/galley/test/unit/Test/Galley/API/Message.hs index f5aec8a2304..6dae3d08b34 100644 --- a/services/galley/test/unit/Test/Galley/API/Message.hs +++ b/services/galley/test/unit/Test/Galley/API/Message.hs @@ -17,10 +17,12 @@ module Test.Galley.API.Message where +import Control.Lens import Data.Domain (Domain) import Data.Id (ClientId, UserId) import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Set.Lens import Galley.API.Message import Imports import Test.Tasty @@ -41,6 +43,13 @@ tests = ] ] +flatten :: Map Domain (Map UserId (Set ClientId)) -> Set (Domain, UserId, ClientId) +flatten = + setOf $ + (itraversed <.> itraversed <. folded) + . withIndex + . to (\((d, u), c) -> (d, u, c)) + type QualifiedUserClient = (Domain, UserId, ClientId) recipientSetToMap :: Set QualifiedUserClient -> Map (Domain, UserId) (Set ClientId) From 52c041a1dda4a706c5595157cdda89cbf6ee01b9 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Feb 2022 15:19:28 +0100 Subject: [PATCH 16/58] Build OCI images with cabal (#2060) --- Makefile | 7 ++++++- build/ubuntu/Dockerfile.builder | 2 ++ build/ubuntu/Dockerfile.prebuilder | 10 +++++++--- changelog.d/5-internal/cabal-oci-build | 1 + 4 files changed, 16 insertions(+), 4 deletions(-) create mode 100644 changelog.d/5-internal/cabal-oci-build diff --git a/Makefile b/Makefile index 7cdd010749a..4ea6e2e0e7f 100644 --- a/Makefile +++ b/Makefile @@ -130,7 +130,11 @@ add-license: # Clean .PHONY: clean clean: +ifeq ($(WIRE_BUILD_WITH_CABAL), 1) + cabal clean +else stack clean +endif $(MAKE) -C services/nginz clean -rm -rf dist -rm -f .metadata @@ -245,9 +249,9 @@ run-docker-builder: .PHONY: git-add-cassandra-schema git-add-cassandra-schema: db-reset git-add-cassandra-schema-impl -CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1') .PHONY: git-add-cassandra-schema-impl git-add-cassandra-schema-impl: + $(eval CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1')) ( echo '-- automatically generated with `make git-add-cassandra-schema`' ; docker exec -i $(CASSANDRA_CONTAINER) /usr/bin/cqlsh -e "DESCRIBE schema;" ) > ./docs/reference/cassandra-schema.cql git add ./docs/reference/cassandra-schema.cql @@ -256,6 +260,7 @@ git-add-cassandra-schema-cabal: db-reset-cabal git-add-cassandra-schema-impl .PHONY: cqlsh cqlsh: + $(eval CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1')) @echo "make sure you have ./deploy/dockerephemeral/run.sh running in another window!" docker exec -it $(CASSANDRA_CONTAINER) /usr/bin/cqlsh diff --git a/build/ubuntu/Dockerfile.builder b/build/ubuntu/Dockerfile.builder index f34e4fc91d5..f6f83ba48e5 100644 --- a/build/ubuntu/Dockerfile.builder +++ b/build/ubuntu/Dockerfile.builder @@ -11,6 +11,7 @@ WORKDIR / ARG wire_server_branch=develop ARG THREADS=4 +ARG CABAL_BUILD_ARGS= RUN set -x && \ echo ${wire_server_branch} && \ git clone -b ${wire_server_branch} https://github.com/wireapp/wire-server.git && \ @@ -21,6 +22,7 @@ RUN set -x && \ stack build haskell-src-exts && \ stack build --pedantic --test --no-run-tests --bench --no-run-benchmarks --dependencies-only -j${THREADS} && \ stack install ormolu && \ + cabal build all --dependencies-only ${CABAL_BUILD_ARGS} && \ cd / && \ # we run the build only to cache the built source in /root/.stack, we can remove the source code itself rm -rf /wire-server diff --git a/build/ubuntu/Dockerfile.prebuilder b/build/ubuntu/Dockerfile.prebuilder index 22f8dc04c67..4f407d4d253 100644 --- a/build/ubuntu/Dockerfile.prebuilder +++ b/build/ubuntu/Dockerfile.prebuilder @@ -57,15 +57,19 @@ RUN export DEBIAN_FRONTEND=noninteractive && \ libncurses-dev \ libncurses5 \ libtinfo5 \ - protobuf-compiler + protobuf-compiler \ + rsync ARG GHC_VERSION=8.10.7 RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org \ | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=${GHC_VERSION} sh -ENV PATH=/root/.ghcup/bin:${PATH} \ +ENV PATH=/root/.ghcup/bin:/root/.cabal/bin:${PATH} \ LANG=C.UTF-8 \ LC_ALL=C.UTF-8 ARG STACK_VERSION=2.7.3 -RUN ghcup install stack ${STACK_VERSION} +ARG CABAL_VERSION=3.6.2.0 +RUN ghcup install stack ${STACK_VERSION} && \ + ghcup install cabal ${CABAL_VERSION} && \ + cabal install cabal-plan diff --git a/changelog.d/5-internal/cabal-oci-build b/changelog.d/5-internal/cabal-oci-build new file mode 100644 index 00000000000..acaea8d576f --- /dev/null +++ b/changelog.d/5-internal/cabal-oci-build @@ -0,0 +1 @@ +Add cabal build caches to ubuntu20 prebuilder and builder images From 6231be2d2b09470958faee985fa133e53fa78ab4 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 7 Feb 2022 15:55:46 +0100 Subject: [PATCH 17/58] SQSERVICES-1234 Insufficient Validation of Icon Attribute in Team Profile (#2103) * typed asset key in update team payload * fix golden tests * changelog --- changelog.d/3-bug-fixes/PR-2103 | 1 + libs/wire-api/src/Wire/API/Team.hs | 3 +- .../Wire/API/Golden/Generated/Event_team.hs | 13 +-- .../Golden/Generated/TeamUpdateData_team.hs | 109 +++--------------- .../test/golden/testObject_Event_team_2.json | 2 +- .../test/golden/testObject_Event_team_4.json | 2 +- .../testObject_TeamUpdateData_team_1.json | 2 +- .../testObject_TeamUpdateData_team_10.json | 2 +- .../testObject_TeamUpdateData_team_11.json | 2 +- .../testObject_TeamUpdateData_team_12.json | 2 +- .../testObject_TeamUpdateData_team_13.json | 2 +- .../testObject_TeamUpdateData_team_14.json | 2 +- .../testObject_TeamUpdateData_team_15.json | 2 +- .../testObject_TeamUpdateData_team_16.json | 2 +- .../testObject_TeamUpdateData_team_17.json | 2 +- .../testObject_TeamUpdateData_team_18.json | 2 +- .../testObject_TeamUpdateData_team_19.json | 2 +- .../testObject_TeamUpdateData_team_2.json | 2 +- .../testObject_TeamUpdateData_team_20.json | 2 +- .../testObject_TeamUpdateData_team_3.json | 2 +- .../testObject_TeamUpdateData_team_4.json | 2 +- .../testObject_TeamUpdateData_team_5.json | 2 +- .../testObject_TeamUpdateData_team_7.json | 2 +- .../testObject_TeamUpdateData_team_9.json | 2 +- services/galley/src/Galley/Cassandra/Team.hs | 4 +- services/galley/test/integration/API/Teams.hs | 30 ++++- 26 files changed, 77 insertions(+), 123 deletions(-) create mode 100644 changelog.d/3-bug-fixes/PR-2103 diff --git a/changelog.d/3-bug-fixes/PR-2103 b/changelog.d/3-bug-fixes/PR-2103 new file mode 100644 index 00000000000..d534ec93f05 --- /dev/null +++ b/changelog.d/3-bug-fixes/PR-2103 @@ -0,0 +1 @@ +The field `icon` in the body of the `PUT /team/:tid` endpoint is now typed to prevent potential injection attacks. diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index 0a9b5744f61..6f31c1c7c7d 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -81,6 +81,7 @@ import qualified Data.Swagger.Build.Api as Doc import Imports import Test.QuickCheck.Gen (suchThat) import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.Asset (AssetKey) import Wire.API.Team.Member (TeamMember, modelTeamMember) -------------------------------------------------------------------------------- @@ -256,7 +257,7 @@ newTeamSchema name sch = data TeamUpdateData = TeamUpdateData { _nameUpdate :: Maybe (Range 1 256 Text), - _iconUpdate :: Maybe (Range 1 256 Text), + _iconUpdate :: Maybe AssetKey, _iconKeyUpdate :: Maybe (Range 1 256 Text) } deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs index 74a885e4d00..e9a1ca0ec3a 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Event_team.hs @@ -20,6 +20,7 @@ module Test.Wire.API.Golden.Generated.Event_team where import Control.Lens ((.~)) +import Data.ByteString.Conversion (fromByteString') import Data.Id (Id (Id)) import Data.Range (unsafeRange) import qualified Data.UUID as UUID (fromString) @@ -115,11 +116,7 @@ testObject_Event_team_2 = ( unsafeRange ("i5\EOT\1002575\1097973\1066101\&1u\1105430\&1\41840U*/*\999102\1001662\DC3\994167d\1096830\&4uG\173887\fUh09\\\1028574\vPy\t\171003\SI\GS0bV\CAN]\17049\96404\15202\RS\SYNX\ESC3[\CANf\NAK") ), - _iconUpdate = - Just - ( unsafeRange - ("G*~\1098568\62228\EOT\FS\36117%s\DC3\57890|\1092250ZS\989493jf\119998-w\1113299{]R\aNwI\a\1007357?Z\1019937x\65703*\t\SI33\1091562\&3-j\DC2\170440\STXp,n.)*\1073149e=\100962n\1063403\159370aK\ffeF\ETBx\149218\GSX_\1023100R\1102760K\70812gK\1050395\&2J\SYNM\99409-+\1055216uW^Xwjlt\fGy;&\984905\ESC\1033170\DC2^\ETB8\9010\62641wtq\1083210\12238\983428n1~k\bk61R!\1018162\1084522\1075186\1074814w\183828x\DC4\1097642\34650\1078763M05\ENQZY#\92897\RS(\1816\1070299{'W\DC4\SUB\1064958?n\EOTAhT-\CANa;\1013791CV\"") - ), + _iconUpdate = fromByteString' "3-1-f595b8ed-6dcf-41f2-8a2f-f662a9c0fce4", _iconKeyUpdate = Just (unsafeRange ("\131355Pp\1067299\987603\ENQS\22773S\ACK\NAKmM\19084\&0\19257\31361$rL,XvJ")) } @@ -152,11 +149,7 @@ testObject_Event_team_4 = ( unsafeRange ("d\SI\172132@o\988798s&na\136232\1090952\149487|\83503\1016948/\989099v\NAKu\DC2f\1093640\1011936KC\47338\1066997\1059386\&9_\v_^\1045398K\155463\SO Y*T\CAN\1086598<\1056774>\171907\4929\rt\1038163\1072126w2E\127366hS>\ACK_PQN,Vk\SYN\1083970=90\EM2e\984550\USVA!\EM\FS\EOTe;\189780\&1\EM\1004319=\DC3\1095917@o\1016975\NAKkR\1022510l^W)W=\1026382\40628\SYNrrN\144727\1026366S\SI^,\ETB5Q&z8D[\15759\ETBbas\SUBY\RSR2\140794\1012833G+'Q+\996998") - ), + _iconUpdate = fromByteString' "3-1-f595b8ed-6dcf-41f2-8a2f-f662a9c0fce4", _iconKeyUpdate = Just ( unsafeRange diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs index 223db088933..7366c6da603 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamUpdateData_team.hs @@ -19,6 +19,7 @@ module Test.Wire.API.Golden.Generated.TeamUpdateData_team where +import Data.ByteString.Conversion (fromByteString') import Data.Range (unsafeRange) import Imports (Maybe (Just, Nothing)) import Wire.API.Team (TeamUpdateData (..)) @@ -31,11 +32,7 @@ testObject_TeamUpdateData_team_1 = ( unsafeRange ("@t\1104947K\1103008\v\34277\ETXe^\984496x~U;^\1086372\b\SYNwn\\aS\1022526g\CAN\1015468\ENQ'+\DC2~yJ\190623%y\110657!#3\CANtZ\1095609[&{?\SYNX`\50850f\FS\62969=j\US\1046631+d\ESC0\111091\50408Ft`U\97666g\158703\1072122\987428F\avEBjP\153147\94534c\142165\1041426e\176319\SIL\189459\1080869GW\995547I(XBV8\ETX\EOT\DEL\1017745C\38693\1075418\NUL,\190006/P\1000635[y\NAKZ \US\51607c\DC4X`%\1066586\&8@\tP>em\917813E\SOH") ), - _iconUpdate = - Just - ( unsafeRange - ("\FSH\n0\1039325L\ESC\1113097\DC1\1080599MT\RSk\DEL\ESCC\74068\1085263S~X\995215\ACK\181632~Lm\44348\SYN\180250\&6\SI\DLE=\1080377\1057137U8h\ETX=\143784\1079703\STXb7Q\ENQt\v*|I{Ps\73695W,\ESC\DC3m5\5258\EOT\US\186343I\DC3\1044809X8\f\DC3a2(Ic\1083941t\GSS\RS\DC4M\ETB\DLE4;0)j\SO\SO2yN\SUB\190408L\DC2P$8\136887V\1033879U\71351\184267\r\b\1024342\FS\154123bx\14530\&3;[Qb!i\47397J|ca$0n-\SIAZ9\"9\ETB5=\148230\a\rZ\EMn\1036736\fZevj}$`\4356n\STX\SOH8\167784\&8\1053057)|\ESC\DC1\1005173\EMX8eLZ\DC2\10329U\ETX4aI\ETX972GQF\SOU*F\1047919\r3\1041496?d\995610u<\f\DC1t\141693\\g\4420)c4\44853eP\1024435^\r_\156907h\1035687Z\ACK\163949\1088232\ENQ\f{Y\SYNp\NUL\189656&'\NUL\GS*\n-\RS\ETX\RS[") - ), + _iconUpdate = fromByteString' "3-1-47de4580-ae51-4650-acbb-d10c028cb0ac", _iconKeyUpdate = Just ( unsafeRange @@ -51,11 +48,7 @@ testObject_TeamUpdateData_team_2 = ( unsafeRange ("\189807ZV\ESC\1108470:RV\ACK0%U\r\ENQ\5305\vg\SUB\DC3\67160\v\17005\v\164969\DC3\CAN`\t\153326\t_\1030121\19120\US\r\"\182508\95642\1011430\SO@\39970\DLE\ACKy8*\134852P;o`53L\ACK\999693\t\16157e\50198\SYN$\SOH\1101935\1093304\NAK\1031461\100218\b\FSeW,\1082547#\DELUU\DC1%\23739dF\69383Z^\993333u\182995\62551v\1026012gb\1087967\USR \49133\SOHm\ENQ+\RSdHcX\1043456\SYN1\41562\t.r^\n\DC3\25500^\EMp\23943h>\1008252%\1065685#:\20208\DC1EB.\996292\&0H6\174124\190683\19272\1012708o>L\6289_\ETX\988770\&7.9\1073238\DC1WQ\vr3\1014429g\US\178828dZ\DC4\987183\\\1033879\998865~\30943R\tl3Fz\GS\DC3\SUB\ACKD\1032087KjM\FS^\SI,\39922Rjve\NAK$\DC4!\\\SI/13xE\176873\41996X:B\DC1h\38384\&0\15928>\1084065\v5\GS'\1028874\ETX\SOHgj*\181871#P") ), - _iconUpdate = - Just - ( unsafeRange - ("\21590h\62749Ve1`kK\STX&]}%(p\22753\1083321\1003176r\1107488\DEL\27481x\r\"\1043757\ACK\14885\1025784m\1007376\1012010\US\8534j;f-\1034363=4@1O$\94870\ENQ\NAK") - ), + _iconUpdate = fromByteString' "3-1-2ed18927-755c-4197-996a-7076baa23923", _iconKeyUpdate = Just (unsafeRange ("`m\DEL$\1032324\44660`\152159b\1052163\"\FST\SYNiA%ZnO_\b\DEL\NULb")) } @@ -87,11 +76,7 @@ testObject_TeamUpdateData_team_4 = ( unsafeRange ("\128134e\DLE\SUBcs\2387\1075156|\US\SUBu\FS\52294\153736&@\EOT\998980,D,<\147898\1023755RVpe}[\148576\52157xN\tz,T-d*\159171\EM\GSa\1086147\188771\STX|>]\v\191414:7\190399\1002509b\1012517|c\131827,\44613\1016960O\120010l=\1026976QA\21240\48375E\1048133#J\SIocH&\SI\191295\DELh\SUB^\t\NUL\58166\986951\1040859n[\1099585o\118936\DC2\43837\41993,\SUB\a\ENQ\EM\20127*m\1060088&\171058\1057983\EOTE#W'\a;+I\SYN\FSg\n^i[\1044417\STX.\CAN]\21346b\\\1106355\1004766\DC4J\1010071\1109900s:D\FS\SOBwpPF\ESC\\\f\1043258\157327\32653H\1038564\1018956j\1068498\19386\119144\SOH\\\785NE\51900\72110\DC1\rU\t\149777j\SYNX\n\1042182}\1041865\1047029\1069576\vS\1022749{\1063362\72135\USi\1043163\DC2\1098488^8\78341\ACK\SObG\6333X\1107580\SUB!R\59730^\DEL\SYNqjf}|\STX$\ESC0Q\SI\ACK\1025203\a\46015F\173556~\DC4T\1110827\135066j+I\EM\RSWK\DC2f") ), - _iconUpdate = - Just - ( unsafeRange - ("\30772\&5\FS\13470\ETX\t5l\100970j\DC1iu\64772\1001606\1051131\DC3)$M82pC,Hwy\ETX>Vf\SOz\SUB\1548\ETB_4B\f\1097043\1043467\156243a\1102338\186298FZ") - ), + _iconUpdate = fromByteString' "3-1-2f002dda-74de-457b-aabe-831229662e4d", _iconKeyUpdate = Just ( unsafeRange @@ -107,11 +92,7 @@ testObject_TeamUpdateData_team_5 = ( unsafeRange ("c\DC4\21957\1083082Am\SOH,0\5634\1011802\DLE\DC1\1048597\ESC>\DC1rj5Hd\1061313\DELI'$.\98215\DC2}\ENQ\DC2\1009633\158711\100133|\FS\r\DLE^\8538t\190283\1060031vf\1047172`d' '={4\48912\b5][T\165195\&7A1\32515\NAKY\\frek5$f6b_4%\129513\DC2\1047616!\DC16\f\ETXK[SQH\n\35821\1017522\1088735\EMd\\@RQB\1113466\75066A^ l\1085060\1033719X^i\1014199\SOH\1042929\176179I\1107945\US3\1044762xIC\DEL#C-\1054562\SUB\136101r\35811\f,\SYN=\SOHJ\40558I=\987545") ), - _iconUpdate = - Just - ( unsafeRange - ("0yl+Ej0A)D\NAK\ETB}\1039598\1063472FB\50299\97823\146248\34652+\42767\&2&\SYN\1089179\ETX?\152085[Td*K!c\1018259\163237<\1043113\1053778\1035549\984028ecC\187860\5191\f\1101522{-\\\EOT\1022309\FS1qhH\STX\ACKNq\NAKf\b{&\4910\1033774\140126\SYN\DC33\DC3-.:K\175882F7I\ETX\1097348il\1109195\179701A\167906F~N\b\100458\53332\34700Z!\DC4?\157325\42325n\ESC\1087965") - ), + _iconUpdate = fromByteString' "3-1-1ab65a15-a0de-4e3a-b5cf-533b43df652e", _iconKeyUpdate = Nothing } @@ -135,11 +116,7 @@ testObject_TeamUpdateData_team_7 = ( unsafeRange ("n{\1057261oZn\DC1\ESCJt kj\ACK\r\1009375\"'{\SUBX\183635?@\1072481Ly\1034079\ENQ@$\126078W\182880\152533mW\1031829\DC1\DLE^c)\185735\987874\168851\44285\&9\1026256\1081073\1088339\ETB\DC4\DC2My\EM\998884\CAN\155753gmi\18003\SIy:r[\1028859i.\\\SOH\1013999\ETB5\184553H#\DC2\100088#l\SI@\149391@\NAK)\155671Jg\16061c\ACKV\EOT\1052115\166619\1106254\DC3\7348\1014585\1039214fQ\36540\1014874\1099704|Ik\DC1X\SYN\FS}ii\1044665M&.)\163680\SYNL\1006642\ESCk\a!\DEL \SUB\1083653\150892+\RSRW\\x\US\GSt\988142\1060379\33437\CAN\STX\51186+\DC2\1051428,\\F%,w\174606a\\\DEL]\RS\141663~X;f\134482 \1065664p\DC1d8mhY7w\RSe\ETX\DC1\1112177l\ETB{3&\49028\ACK\DC4V=D\NUL\ENQ\SI\93957\aK_di=,") ), - _iconUpdate = - Just - ( unsafeRange - ("\990737\CAN\33854\&3\1097824EE\RStQb\FS`:;\4613=\997632P2\DC3\\\NAKZ\1050942\DC1p'WrP3\ESC\152406\&9o\FS,H\DC2.&\110851\128155\SOHo\RS ^Jak&\DC2\1010395\13081W\CAN5\t?;/\983915\DLEA\139873A\v*Q\66752<\166347i80\v%c{U\59976\SO\ACKW\1077362&~{R>iP\SYN\49730\ENQI\1011701*K\996728a\21531\"gi\NAK\1094228.\1071509\1077599L\NAK\132856<\1017306\ETB\DC4\CAN\100503U\997758f\128348\162175~\EOTb\t\1002782\SO\43510\1033082\4725\b\NAK\7475\164004QaZ)\USt\ENQ\b.\1008499^\189520\DC4\994152{S\138099sRGr\1026084\1017366$\1084696\&2~b\137745") - ), + _iconUpdate = fromByteString' "3-1-b5aa5007-2939-4c53-874b-aecfbb6244fd", _iconKeyUpdate = Nothing } @@ -159,11 +136,7 @@ testObject_TeamUpdateData_team_9 = ( unsafeRange ("QJ\1097031G\"g\SI~jG%\DC3o\SI2Zb\30604\1005260\145682vb\US,N9@\1044946\ENQ\DC1\151830:\23929H\v\EOT\66778\ETB/1\3753:\ESC\188539\&3X\146473\&5g)3xq7\38571\140250o%PvWF\vF-vF|\a\1071563k }\1008775\120687!\NULZ$md\97106\119012'\1035663\131295*Tj\ACKh\\TK$~ *\1658\19623*P/=W\GS\29550\1019406~_$~\99885:\ESC=\153783\1005174r\65190\\/oRB\v\EOTK\1073165\18061$\17338\EM~-}S\996372ipLl\190933IJ\GS\SYN\bu\28200\CANkq@1m\126546\&5|\DC2O1<'\ENQ)\1004070;\1045448\SUBF\v\987260I\SYNg\fb\nXB37\DC2HHhO\DC3\aD\ETX\FSmm\65705W*\1045560d\v\SUB^\1037116ow\166819&9\185716B\1015997\nK!i\DC1\1103398\\\137045\1044022\95353\&4\1041203J8g\ACK\1076662\163809\1074446N\51814|^\1097868@\1071814\1095356,Wi\54749\&4\SI\NUL`\SI;\SI=}jY\993753:\182678f:M\991209\1103492\995417#5\172275\DLE\139206*\99381U\155843\ETX\DC2U\983347\50942PU\v\60676\STX1\b") ), - _iconUpdate = - Just - ( unsafeRange - ("\1105395fO\136152#s\1045772 e]+\40673P\RS\1069217I\SUB\7389k\b\15693\v\EOT'nY\1050737hc\SOHC\CAN=9I\DC3Z\1060298:DNj\73790~{\1014583\1103190C\1458u\\6\21036\149041gZ\1083605\a\a\1068405\175226\985156v$9\SIa\tAg)T}\1089275\988268'\GS\1102415ng}\27622<\a\134504\1061180s+\1030442\1067569`z[\CAN,\b:TX\NAK)U?\NUL |\137753xI\GS\154470S") - ), + _iconUpdate = fromByteString' "3-1-fb2b55d0-becc-449a-9755-ed72366c4e24", _iconKeyUpdate = Just (unsafeRange ("i\165439\1084715\70744\984960r\143191\FSiL\SOH)I\EM\n9l>\SOHPu]\NUL\34711Q##\ETX\185628\DC2")) @@ -249,11 +206,7 @@ testObject_TeamUpdateData_team_14 = ( unsafeRange ("W\v\128126\49287\DC4\STX\SOH\1071632\1089152\&0\177175\1020380\1097825N\1096909j\1551\&7]v\DLE\ETX\1064358\1088228do\59527]?\"\39129\&4\NUL^I5\8990{\153487{\f>\SOTx\n!dR8%\1008955N5\vI\139104R\DC4\DC4uo\993229\&2\172393[V\DLE\GS\SI\bn\121117J\177399\EOT^x<\131581W\1080876H#oF(t\tQ\38424\1075412V3\180074\155485\SI*T]r5G\1091385\158397>\30986\99439\1029421qwVi|\1018658\163652^b^/\\%\DC4\142529A\ETXgL\46741Zt^Y\NUL \ACKcv4\189064f\181439\DC35\135778u\31202\nOI\48512\1102654~\1093814\178360\&4\NUL)%X\992245Ar p\1078684\1014480y{DB|]lbI:3$\17570\&1bX+ \1032696N\1021333\SO\984213\r\51699\f~%\"{&\93818j\57610ME\USmg{\DLE\28913Q/\96067XW") ), - _iconUpdate = - Just - ( unsafeRange - ("i\ESC\DC4I\ESC>X\CAN\25839q+?\a4J\28955\1107236,\45638\1091677\SYNo,\1087282#O\CAN4\1060231\r\1111276\&5.\DC1\STXB*F\NAK\161291l\1013717\178596zJ\DC3'5.R\EM\STX\983262\STX8M\1106219\1032181\169235D\178077\"\EM\\!Z[ t\NAK02t=\US\1053232\1035064\1049822A>4\DC4\64018`\8383\DC2d\\oB\44662\1022783\ETX\ap!B\21389\1049746\na^\CANU!\1039339\98447QOjEm\65682`g\100320\r\f\US\35096\57781\DC2n1\tD:S\67369<8\r<\1003632bVi\GSoS'2o\ETB}\125053=q\1086133\EOT\STXw}\NUL\44477hK\1046502+gud:W!\1013730\f\74784}\r\EOT$L\n\136841`\a\126225M4y\1001381\1049907zYW\EM\1007372\1058563Ty\1048016\FS3\STXV7\50967j\GS\ay7i\DC3\r\1107257l\1082862\1050872\99516\32567H%,(1j\998348\v\986415H:\SYN\1007283W\ai)\181153C\161390rm{1\ESC\ESCrde\SYN$80%\133874\EM\16697O") - ), + _iconUpdate = fromByteString' "3-1-bc1b2714-64a1-4cd5-bf28-769f2726c204", _iconKeyUpdate = Just ( unsafeRange @@ -269,11 +222,7 @@ testObject_TeamUpdateData_team_15 = ( unsafeRange ("p\ETX\47602\GS\NUL_\127910n4\1075628\&6V\65148\STX\156622a\1080314\&97\55267X\36536)Y\65341\1035712t\1064872\DC1\990797\1072225\20887G`\tV\ESC0&\DC2t\4414&\984777oq\DLEM\182922)+>Dh7\1011725c\157347\21358R\175842a\991848H\992285\1098926\r_pU\r\ACKXP-\raR8P\EMT5RD\1075743j>\RS\EOT4J$e\FS\bWP&\b\1013201\1062988\1103722\&5[\3622lYC\1051016z8\DLE\1004950\US\18405\96631\DC1\1085685\DELg\131242\NAK\153801RS\1109644Q\1009155\186327t\5905\STXLAS3I~ 9\NUL\985675rj\150171C\1058830\&794&\1111226\SOvk`h?") - ), + _iconUpdate = fromByteString' "3-1-f7d6739b-9dd7-4dff-acbf-972b0864158f", _iconKeyUpdate = Just ( unsafeRange @@ -289,11 +238,7 @@ testObject_TeamUpdateData_team_16 = ( unsafeRange ("{,W\113725j\66867VW,|\DC1-\EM\92324\52301\1085991\ENQSdM\183964~\187744\166807\v\46661\1012290\1008523\11770m\1001938{R\\\21218\184105(\DLE@\1105928Eiw\181379\989957\&7\1088623\53157\vc[L[\NAK\9325_\CAN](H\aOj\993741\FSgdV\179455") ), - _iconUpdate = - Just - ( unsafeRange - ("\EOT>D0.\123153\GStW\1072092YER)M@jid\ETX\147741\SOS\57542Q-\DLEO@\bo\ENQ@iV\74411\1001808P}s\44110f3\DC3\RSAN=*^[\1025032\t\189496q\SI,s3?\175350D\1099533*\132583\&6\169444!*\ESCTk\1059479Fyc\"L\rlv!\136570NxB\ENQ\rs&>M[\DLE\SO\184134q\SO6n:\DEL\ESCb\SIV\ENQLNT\ETX?\170592[\US8\1098891jT1\139047y\CAN)") ), - _iconUpdate = - Just - ( unsafeRange - ("\187020\68302\68231\1094239(!WtCYc\DELX$\CANe-9Gr\999186=M){w\DC2\156678\\\1110651_\DC1*j\US.\1110789\1072197\1026885\DEL\1314;\1099158go\v:Dr0\928W\DELom\1099777P*\72311\NUL\181164\1053602 \1025622\169338Ad_i?r\34872\1017917\14693\169159~y~\186034\"ByOiY1\186908 \RS+qaG9\1027588b\f\SIW!\1067149srx~j\6197\SUB\1064674Z\160086\1084367\1096818\SOH~\72194\b\NULC=H\f9\180087+\113759\1026072\131157\DC4p\b") - ), + _iconUpdate = fromByteString' "3-1-8a5fd50d-9c32-494f-83ff-69db6d290fca", _iconKeyUpdate = Nothing } @@ -325,11 +266,7 @@ testObject_TeamUpdateData_team_18 = ( unsafeRange ("\1079724g^\SI4\SYN\1058518(\1009158dn\15153\5338\1106457\&8\3255\FS\NULd}W\1077482\1112219a\1045348\&8.DV\1112683\DC2Q!\SUB\1015114\NUL\165488|k\141351Y\b&]P\NAKM\23995{\SOH\US\1084668\8678fEL5\1099186^xy.\1081341\1097387ZD2EOw\1067991\1103136Z\990193v\SUB\17778:U,yu3)*\31312]\61413\&6t:Q\nQ\70111\DC3\ETXCd\983894&\165641p\1107770u|\1097560wh:%KJQB>I\20517W\169935\11540\135417\vIP+|9C\43303XBM\1070327$FR\68308J5d\GSK\DEL\167980\CAN\1107001\EMt'\RS[zmz\ESC-\1090175\1053386{o\153401/\DLE\NAK\1071487\DLE\DC2\DELz~>iz\1035567j`\156674G\rat{\b&\1091867\175116,W\1102256\1102670\1041725\180873G\1032893\1051388Q\SI\32211\RSg^&>\EOT&BB]\SUB\183680^^n\83211\1056047\DC3\33295\RS2\120638^I>^e\1088165\&2\1060054$+\1099972\&2\DC3>&4%4\1049880\DC1\985577M\95025\99763\&0\10709\ESCM\GSu") ), - _iconUpdate = - Just - ( unsafeRange - ("jc3h\1005747\&8\1104604j2\163578s\145282nw\1028815\43326\fkOO\SO\50268\&3Adqz0\a^AU\NUL/\63034?\RSz\t\1013555.[\FS\97617\ACKK\188176\DELg\147687Y\US\1051347OZ\a\164115(H\48697\143951\STX8(\1080538\64417\1059160?e\984507_M\148578Q~o\38053X6WAL\SUB\DEL!\998015\10180A2\SUB7\157157a\1000210\v[T\39548I\985078\1098938\FS$(\bq\1096594\a\128511\DC4\DC4f\1074329\&3Vc\GS\1083835u\127513V\t\48136\1014895\\\ESC\ETX\119947\145834f\1099291\1005132'\170635w\DC3\1100353M3\1103725&6\v\DLEM \RS") - ), + _iconUpdate = fromByteString' "3-1-a55ba42a-1fff-4720-ab1f-404ac449a8c4", _iconKeyUpdate = Nothing } @@ -341,11 +278,7 @@ testObject_TeamUpdateData_team_19 = ( unsafeRange ("{ag\147194<-\41002\"\1080393Ad%\30025\1023746U>\28518<>g\bt\29617:\1083297^=6\1076845\1001362\95768\DC1\1083749\r\ESCIu%b\DC2\b`/-+`\1071102\\\ETB^\ETBw\DC1L\USb?'\1004489\ETX\DLE\ESC\v\1089138\161384}\1078506\\\10356\DEL$\DC4OE\ETB\RS\GS)Vej\1072959\174859!\DC1W*s\DC2U%-\140833KC`B\\k\1048017\RS:\DC4\1095557\USN\DC3\ESC:ns\GSj\DC2&-\ETX.h\SUBJN\1030050x1c\NAK\ACK\646+\SIb\DC2mnp\1075229\ETX\996854)\EOT ;u\169592\&5\EM;\f \6592") ), - _iconUpdate = - Just - ( unsafeRange - ("'\176588\1108224\RSSD\1078734\SOH\1098229\v\NAKd\US\u0019󵌟=\u0013􋣭@o󸒏\u0015kR󹨮l^W)W=󺥎麴\u0016rrN𣕗󺤾S\u000f^,\u00175Q&z8D[㶏\u0017bas\u001aY\u001eR2𢗺󷑡G+'Q+󳚆", + "icon": "3-1-f595b8ed-6dcf-41f2-8a2f-f662a9c0fce4", "icon_key": "\u000fL\u0016~\u0011'](W\u0018뇂\u0004x􊧞Z\u0001봸\"\u001c=𨇚%捿x$󶵉􄂝Y@􃡊ཥ꒛7􂏉󸚑|rI󶳴𨙌[\u001e\tz\u0013r1g𗵊~嵙􄁝1\r𘕺p㥊𮪕i3$󽉏#󴝭f'\"㮐TK\u0017J\u0003o𩽴􇠐𐙨󷵸\u000epij𮐋󼉔?`𬢃oR􉔋~vi欕3Mc|\u0007^\"㠼kK𮖳c􉭜𡄕oiL􉌩~\u001b*𦏱\u000f{*,=𪖞𠄝g\u0013G=\u0019|\u0016A~􂇰qZ!𦸧\u0017M.kZBV󻷵\u0014𡽐\u000bI{𘘕q\u001e7𢲕B[e📹x<98{󵲨I?󼹊𠽴𣦓A\u0017,", "name": "d\u000f𪁤@o󱙾s&na𡐨􊖈𤟯|𔘯󸑴/󱞫v\u0015u\u0012f􋀈󷃠KC룪􄟵􂨺9_\u000b_^󿎖K𥽇\u000e Y*T\u0018􉒆<􂀆>𩾃ፁ\rt󽝓􅯾w2E🆆hS>\u0006_PQN,Vk\u0016􈩂=90\u00192e󰗦\u001fVA!\u0019\u001c\u0004e;𮕔1em󠄵E\u0001" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_10.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_10.json index f93a378ce46..ac1ff8e6567 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_10.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_10.json @@ -1,5 +1,5 @@ { - "icon": "𗍽m\u0010,6\u0000\"`􉴇𦎶*]4]\u0002𦶑󽡧\n𤇷;q$^V􀣭𬭄𐨝jG$𫋽S$fO[i=$􄿨\u0003\"􃵬􈑀𝣼;i\"@\u001d\u0012𝧟ඩIpA\u001a󲡈󿏺\\􉣊jnu𮪰:<\u0016\u0019\u0017'\u00189Q􅅵󶑌𩾴𗱐\u001fp%\u001f._b[􏂵75Z􁽬6􃐽g\u0003󶖠+\u0019\u000b\u0017𭯢Z:f\u0014\u0001I7#PK,\u0001􅌩<(3\u0006\u001fp􂠓e\u0015i^%c\u000eh􇤳%o\u0015𔐪􈱇\u001cE40u \u0007aR󻦥0<'~\"\u001b/􂯧𦷸[󿇳<\u0019H$LLV{\nfze\u0003j\u000c\u001b踰\u0006xoi\u0012~󺣯ϊy\rv\u000fM悍^X\u0008!锦\u0002*G\u0002m\u000bU\u0014\u0018", "name": "v􅰣!\u001fc\u0000F\u0003\u0014\u0010>\u0005)󵈦;󿏈\u001aF\u000b󱁼I\u0016g\u000cb\nXB37\u0012HHhO\u0013\u0007D\u0003\u001cmm𐂩W*󿐸d\u000b\u001a^󽌼ow𨮣&9𭕴B󸂽\nK!i\u0011􍘦\\𡝕󾸶𗑹4󾌳J8g\u0006􆶶𧿡􆔎N쩦|^􌂌@􅫆􋚼,Wi헝4\u000f\u0000`\u000f;\u000f=\u0001Pu]\u0000螗Q##\u0003𭔜\u0012", "name": "L\\\u000e7W󽚻\u001e\u0014S}\u000bj\u000c0,\u0007􀼞cz9󳭺𧪄tw𮙈x舋𫂯\u0011𬆛o+r;ntv\u0001t\u001d\r6􏤿G|󴈙S\u0008󾐓~eR9󺊘\u0004.9<􇾡\u0010\u0014掎󸘸HFꮀs텕𗡊i󿞹D$9M용駩'S􆿙5\u0005n\u001d󼶤:j(w(d\r􄶏\u001dO\u0008\u001e𩢬f\u001f󲈳Zj𩰨􎺯\u001aꋺ\u00198c􈄛\u0014`𤸓w*Cj-󸓄8{l\u00170#ꀀ)􆐵\u000b􅒀w!k𡉥󹢮ᬧ7󠇔𭸐x<銰0󴙳\u0006)󾍈( 󷪘K贂5ijLj\u000f𬲰zK𨭉c\u0007r􀝼󺓙{U+\u0010#𭱫2\rsH]\\'􈃳ㄐ#􂼦F>}jY󲧙:𬦖f:M󱿩􍚄󳁙#5𪃳\u0010𡿆*𘐵U𦃃\u0003\u0012U󰄳웾PU\u000b\u00021\u0008" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_14.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_14.json index f93c3fbc59d..86f3cc25965 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_14.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_14.json @@ -1,5 +1,5 @@ { - "icon": "i\u001b\u0014I\u001b>X\u0018擯q+?\u00074J焛􎔤,뉆􊡝\u0016o,􉜲#O\u00184􂶇\r􏓬5.\u0011\u0002B*F\u0015𧘋l󷟕𫦤zJ\u0013'5.R\u0019\u0002󰃞\u00028M􎄫󻿵𩔓D𫞝\"\u0019\\!Z[ t\u001502t=\u001f􁈰󼬸􀓞A>4\u0014晴`₿\u0012d\\oB깶󹬿\u0003\u0007p!B厍􀒒\na^\u0018U!󽯫𘂏QOjEm𐂒`g𘟠\r\u000c\u001f褘\u0012n1\tD:S𐜩<8\r<󵁰bVi\u001doS'2o\u0017}𞡽=q􉊵\u0004\u0002w}\u0000궽hK󿟦+gud:W!󷟢\u000c𒐠}\r\u0004$L\n𡚉`\u0007𞴑M4y󴞥􀔳zYW\u0019󵼌􂜃Ty󿷐\u001c3\u0002V7윗j\u001d\u0007y7i\u0013\r􎔹l􈗮􀣸𘒼缷H%,(1j󳯌\u000b󰴯H:\u0016󵺳W\u0007i)𬎡C𧙮rm{1\u001b\u001brde\u0016$80%𠫲\u0019䄹O", + "icon": "3-1-bc1b2714-64a1-4cd5-bf28-769f2726c204", "icon_key": "yG𨄺|􀞂c󸒺\"N\u0002j\u000fb\u001aH\u001dNt𦇷􄿘?p,l!䱵o뫧),k\u0007󲅁쵷-\u0001qT@󲏋S\u0019𣋎7頪\r^T:=𐎮𥴉,DV\u0014𤊼􉁸iῑ\u000f𩽁Kx\u0017𫑖\u000ftLw󹳹􇶰􃗲\u0002Af莁􀆎亄􀛦*}0󶶽\u000e󼳦􌰫en[𠠦\u000fG\u0018i𛈡U.\u000c@\u0000Cr㋣\u0006\u001c@󺳊PX\u0018\u0019\u0001㺌0ꑔ\u0000A𠠻\u00075ﷸM􅌦", "name": "W\u000b👾삇\u0014\u0002\u0001􅨐􉺀0𫐗󹇜􌁡N􋳍j؏7]v\u0010\u0003􃶦􉫤do]?\"飙4\u0000^I5⌞{𥞏{\u000c>\u000eTx\n!dR8%󶔻N5\u000bI𡽠R\u0014\u0014uo󲟍2𪅩[V\u0010\u001d\u000f\u0008n𝤝J𫓷\u0004^x<𠇽W􇸬H#oF(t\tQ阘􆣔V3𫽪𥽝\u000f*T]r5G􊜹𦪽>礊𘑯󻔭qwVi|󸬢𧽄^b^/\\%\u0014𢳁A\u0003gL뚕Zt^Y\u0000 \u0006cv4𮊈f𬒿\u00135𡉢u秢\nOI부􍌾~􋂶𫢸4\u0000)%X󲏵Ar p􇖜󷫐y{DB|]lbI:3$䒢1bX+ 󼇸N󹖕\u000e󰒕\r짳\u000c~%\"{&𖹺jME\u001fmg{\u0010烱Q/𗝃XW" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_15.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_15.json index acb9d2adff0..206ee72d9cf 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_15.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_15.json @@ -1,5 +1,5 @@ { - "icon": "𨑋Vn\u0002󶤆I𡷮靍􁢄w㝯@\u0015R7\u0000\r&3Lc\u0014?-𗄧\u0017hu􇒺$𬮍\u0016󿏘󿶭􃸉\u000c'ꜜ=\\鼝Bw\u0013\u0008󳖙=a\u001fF/Lx􏤆'\u0018\nkF􅇴􌸞\u001a*缮\u001fT&.􄹺*t\u0002\u001f􏇶rq4u3Frr𬦕$\u001fX&􏛮1U+8Tg𤅮뺻+􅷯~j\u0015F@\u0015%x\r|\u0013􊜗xC\u001b𑇮\u0003\u0011_*wA 􇊙𥞘X󽶣xx󿯶p\n?𗃷􈇩𬌚\u0002󹫆d䛺󽒀멊:wmx𧋔\u0001􆳫\u00138V;𞴧𣩓􉐀K侟𢱇v𒃳0a\u000f􊴇\u0011a8=@􆽇>\u00044J$e\u001c\u0008WP&\u0008󷗑􃡌􍝪5[ฦlYC􀦈z8\u0010󵖖\u001f䟥𗥷\u0011􉃵g𠂪\u0015𥣉RS􎺌Q󶘃𭟗tᜑ\u0002LAS3I~ 9\u0000󰩋rj𤪛C􂠎794&􏒺\u000evk`h?", + "icon": "3-1-f7d6739b-9dd7-4dff-acbf-972b0864158f", "icon_key": "`Ai(se􃳝q󷕚O\\wꈺz(.\u0006@g𐰮\r@􂻔\u000b\u001a8\u0001c䚏;\u001cq𝥽\u0013󶏲\u0002𫐧w#\\<\u0001𗂶v𨎳ĪK鐒AB\u000f㽬󽈪k(􂣎\u0010<􊽬\u001ae[\u0006dHU'^=rX織Gv\u00134𧀘o𢤌3*󳬁)", "name": "p\u0003맲\u001d\u0000_🎦n4􆦬6Vﹼ\u0002𦏎a􇯺97ퟣX躸)Y］󼷀t􃾨\u0011󱹍􅱡冗G`\tV\u001b0&\u0012tᄾ&󰛉oq\u0010M𬪊)+>Dh7󷀍c𦚣卮R𪻢a󲉨H󲐝􌒮\r_pU\r\u0006XP-\raR8P\u0019T5RD􆨟j>\u001eD0.𞄑\u001dtW􅯜YER)M@jid\u0003𤄝\u000eSQ-\u0010O@\u0008o\u0005@iV𒊫󴥐P}s걎f3\u0013\u001eAN=*^[󺐈\t𮐸q\u000f,s3?𪳶D􌜍*𠗧6𩗤!*\u001bTk􂪗Fyc\"L\rlv!𡕺NxB\u0005\rs&>M[\u0010\u000e𬽆q\u000e6n:\u001bb\u000fV\u0005LNT𫷠", "name": "{,W𛰽j𐔳VW,|\u0011-\u0019𖢤챍􉈧\u0005SdM𬺜~𭵠𨮗\u000b뙅󷉂󶎋ⷺm󴧒{R\\勢𬼩(\u0010@􎀈Eiw𬒃󱬅7􉱯쾥\u000bc[L[\u0015⑭_\u0018](H\u0007Oj󲧍\u001cgdV𫳿" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_17.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_17.json index 3b2bb052b73..958d0908e23 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_17.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_17.json @@ -1,4 +1,4 @@ { - "icon": "𭪌𐫎𐪇􋉟(!WtCYcX$\u0018e-9Gr󳼒=M){w\u0012𦐆\\􏉻_\u0011*j\u001f.􏌅􅱅󺭅Ԣ;􌖖go\u000b:Dr0ΠWom􌠁P*𑩷\u0000𬎬􁎢 󺙖𩕺Ad_i?r蠸󸠽㥥𩓇~y~𭚲\"ByOiY1𭨜 \u001e+qaG9󺸄b\u000c\u000fW!􄢍srx~jᠵ\u001a􃻢Z𧅖􈯏􋱲\u0001~𑨂\u0008\u0000C=H\u000c9𫽷+𛱟󺠘𠁕\u0014p\u0008", + "icon": "3-1-8a5fd50d-9c32-494f-83ff-69db6d290fca", "name": "\u0003\u001cS\u000ff𘩄6,/󴯪𠖆,𗲱𨜣D𨺎~𥓃🃕av-W\n􈥳s(y`D;䉻n\u0001G\"]\u000f𦜫\"''A𩥅G\u0017eu𣶝􌧛 pM!4r􆞒\u001aK󻶤R⪤\u0011\u001c\u0005\u000bNu\r|{\u0001\u0006𢑍v-𤃌砀} 6]\u0006p󲖘>\u0003?𩩠[\u001f8􌒋jT1𡼧y\u0018)" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_18.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_18.json index 9c88c852df5..c745fc878fb 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_18.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_18.json @@ -1,4 +1,4 @@ { - "icon": "jc3h󵢳8􍫜j2𧻺s𣞂nw󻋏ꤾ\u000ckOO\u000e쑜3Adqz0\u0007^AU\u0000/?\u001ez\t󷜳.[\u001c𗵑\u0006K𭼐g𤃧Y\u001f􀫓OZ\u0007𨄓(H븹𣉏\u00028(􇳚ﮡ􂥘?e󰖻_M𤑢Q~o钥X6WAL\u001a!󳩿⟄A2\u001a7𦗥a󴌒\u000b[T驼I󰟶􌒺\u001c$(\u0008q􋮒\u0007🗿\u0014\u0014f􆒙3Vc\u001d􈦻u🈙V\t밈󷱯\\\u001b\u0003𝒋𣦪f􌘛󵙌'𩪋w\u0013􌩁M3􍝭&6\u000b\u0010M \u001e", + "icon": "3-1-a55ba42a-1fff-4720-ab1f-404ac449a8c4", "name": "􇦬g^\u000f4\u0016􂛖(󶘆dn㬱ᓚ􎈙8ಷ\u001c\u0000d}W􇃪􏢛a󿍤8.DV􏩫\u0012Q!\u001a󷵊\u0000𨙰|k𢠧Y\u0008&]P\u0015M嶻{\u0001\u001f􈳼⇦fEL5􌖲^xy.􇿽􋺫ZD2EOw􄯗􍔠Z󱯱v\u001a䕲:U,yu3)*穐]6t:Q\nQ𑇟\u0013\u0003Cd󰍖&𨜉p􎜺u|􋽘wh:%KJQB>I倥W𩟏ⴔ𡃹\u000bIP+|9CꤧXBM􅓷$FR𐫔J5d\u001dK𩀬\u0018􎐹\u0019t'\u001e[zmz\u001b-􊉿􁋊{o𥜹/\u0010\u0015􅥿\u0010\u0012z~>iz󼴯j`𦐂G\rat{\u0008&􊤛𪰌,W􍆰􍍎󾔽𬊉G󼊽􀫼Q\u000f緓\u001eg^&>\u0004&BB]\u001a𬶀^^n𔔋􁴯\u0013舏\u001e2𝜾^I>^e􉪥2􂳖$+􌣄2\u0013>&4%4􀔘\u0011󰧩M𗌱𘖳0⧕\u001bM\u001du" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_19.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_19.json index 216f3824b26..90af802049f 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_19.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_19.json @@ -1,5 +1,5 @@ { - "icon": "'𫇌􎤀\u001eSD􇗎\u0001􌇵\u000b\u0015d\u001f潦<>g\u0008t玱:􈞡^=6􆹭󴞒𗘘\u0011􈥥\r\u001bIu%b\u0012\u0008`/-+`􅟾\\\u0017^\u0017w\u0011L\u001fb?'󵏉\u0003\u0010\u001b\u000b􉹲𧙨}􇓪\\⡴$\u0014OE\u0017\u001e\u001d)Vej􅼿𪬋!\u0011W*s\u0012U%-𢘡KC`B\\k󿷑\u001e:\u0014􋞅\u001fN\u0013\u001b:ns\u001dj\u0012&-\u0003.h\u001aJN󻞢x1c\u0015\u0006ʆ+\u000fb\u0012mnp􆠝\u0003󳗶)\u0004 ;u𩙸5\u0019;\u000c ᧀ" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_2.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_2.json index d5e42c5ed6c..7f2c91f6a9a 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_2.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_2.json @@ -1,5 +1,5 @@ { - "icon": "l𭧺t\u0018u~z􏕊x󳀁􉸳𣠩&\u0011󸵗\u0014󳶎𭏟SRv𔗉8\u0005\\L*􈴌:Y", + "icon": "3-1-43f5979a-b8b3-4a6d-86f8-532445d025dc", "icon_key": "8Q(󳁰\"慒􈚬]1'N𪊠?7&\n􈖕\u0007\u000c𭯵K\u00152󳧦𓐐e7󳵋)Gm􍋗ueG󷔏􀧟^\u0016\u0004i\u001fXKLxz􍱪\u0019󸫧I\u0018@p𣯲􋴽 4|D\rg𠜵K\u001e􁝙bHr􎀭󲊁\u0001R𥷇󺳟\u0002r)\u0017t\u0000y>􉊫lE\"􄯠\u0005𗳛v'T󹛫(VJn\u0014옋feOI󶞮D&saC\u000c)k73\u0001Cp9o\u0016𗺃鸫􎰫󸹅IO􈒱󽈂􋒎K*w`xc8%ᔴ\u0008Q􎪣󺡶\u0013\u0015\t𭣔\u0008d󻙒~󾺑\u0002pźF󱺸󿸞-\u0002\u000b𩔁!􉒊\u0017𨶑+\u0011&A\u000b\u001f$\u001c4􍡗𬻧C\u000f􋮺W6{BNO<\u0011\u0008@!a󴶙r.-󴣞𪴵󿛊⍾b", "name": "𮕯ZV\u001b􎧶:RV\u00060%U\r\u0005ᒹ\u000bg\u001a\u0013𐙘\u000b䉭\u000b𨑩\u0013\u0018`\t𥛮\t_󻟩䪰\u001f\r\"𬣬𗖚󶻦\u000e@鰢\u0010\u0006y8*𠻄P;o`53L\u0006󴄍\t㼝e쐖\u0016$\u0001􍁯􊺸\u0015󻴥𘝺\u0008\u001ceW,􈒳#UU\u0011%岻dF𐼇Z^󲠵u𬫓v󺟜gb􉧟\u001fR 뿭\u0001m\u0005+\u001edHcX󾰀\u00161ꉚ\t.r^\n\u0013掜^\u0019p嶇h>󶉼%􄋕#:仰\u0011EB.󳏄0H6𪠬𮣛䭈󷏤o>Lᢑ_\u0003󱙢7.9􆁖\u0011WQ\u000br3󷪝g\u001f𫪌dZ\u0014󱀯\\󼚗󳷑~磟R\tl3Fz\u001d\u0013\u001a\u0006D󻾗KjM\u001c^\u000f,鯲Rjve\u0015$\u0014!\\\u000f/13xE𫋩ꐌX:B\u0011h闰0㸸>􈪡\u000b5\u001d'󻌊\u0003\u0001gj*𬙯#P" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_4.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_4.json index 68f374519ee..7a0c102aa82 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_4.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_4.json @@ -1,5 +1,5 @@ { - "icon": "破5\u001c㒞\u0003\t5l𘩪j\u0011iuﴄ󴢆􀧻\u0013)$M82pC,Hwy\u0003>Vf\u000ez\u001a،\u0017_4B\u000c􋵓󾰋𦉓a􍈂𭞺FZ", + "icon": "3-1-2f002dda-74de-457b-aabe-831229662e4d", "icon_key": "ch=\u0013zyXV֮􌶐🚽[4N𗭾􏸳(sN􋏊=J\u0018\u0006uZ󺗾[L\u0016f-󾸁S+zKX\u0013 L\u0015\u0004𦿥,\u0014𩆴'􌓗#b]\u000b𮮶:7𮞿󴰍b󷌥|c𠋳,깅󸒀O𝓊l=󺮠QA勸볷E󿹅#J\u000focH&\u000f𮬿h\u001a^\t\u0000󰽇󾇛n[􌝁o𝂘\u0012ꬽꐉ,\u001a\u0007\u0005\u0019亟*m􂳸&𩰲􂒿\u0004E#W'\u0007;+I\u0016\u001cg\n^i[󾿁\u0002.\u0018]卢b\\􎆳󵓞\u0014J󶦗􎾌s:D\u001c\u000eBwpPF\u001b\\\u000c󾬺𦚏羍H󽣤󸱌j􄷒䮺𝅨\u0001\\̑NE쪼𑦮\u0011\rU\t𤤑j\u0016X\n󾜆}󾗉󿧵􅈈\u000bS󹬝{􃧂𑧇\u001fi󾫛\u0012􌋸^8𓈅\u0006\u000ebGᢽX􎙼\u001a!R^\u0016qjf}|\u0002$\u001b0Q\u000f\u0006󺒳\u0007뎿F𪗴~\u0014T􏌫𠾚j+I\u0019\u001eWK\u0012f" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_5.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_5.json index f9aefa1e1ba..63c4b71a029 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_5.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_5.json @@ -1,4 +1,4 @@ { - "icon": "0yl+Ej0A)D\u0015\u0017}󽳮􃨰FB쑻𗸟𣭈蝜+꜏2&\u0016􉺛\u0003?𥈕[Td*K!c󸦓𧶥<󾪩􁑒󼴝󰏜ecC𭷔ᑇ\u000c􌻒{-\\\u0004󹥥\u001c1qhH\u0002\u0006Nq\u0015f\u0008{&ጮ󼘮𢍞\u0016\u00133\u0013-.:K𪼊F7I\u0003􋺄il􎳋𫷵A𨿢F~N\u0008𘡪큔螌Z!\u0014?𦚍ꕕn\u001b􉧝", + "icon": "3-1-1ab65a15-a0de-4e3a-b5cf-533b43df652e", "name": "c\u0014嗅􈛊Am\u0001,0ᘂ󷁚\u0010\u0011􀀕\u001b>\u0011rj5Hd􃇁I'$.𗾧\u0012}\u0005\u0012󶟡𦯷𘜥|\u001c\r\u0010^⅚t𮝋􂲿vf󿪄`d' '={4뼐\u00085][T𨕋7A1缃\u0015Y\\frek5$f6b_4%🧩\u0012󿱀!\u00116\u000c\u0003K[SQH\n语󸚲􉳟\u0019d\\@RQB􏵺𒔺A^ l􈺄󼗷X^i󷦷\u0001󾧱𫀳I􎟩\u001f3󿄚xIC#C-􁝢\u001a𡎥r诣\u000c,\u0016=\u0001J鹮I=󱆙" } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_7.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_7.json index bcbb9f5e80f..9c435ffceeb 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_7.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_7.json @@ -1,4 +1,4 @@ { - "icon": "󱸑\u0018萾3􌁠EE\u001etQb\u001c`:;ህ=󳤀P2\u0013\\\u0015Z􀤾\u0011p'WrP3\u001b𥍖9o\u001c,H\u0012.&𛄃💛\u0001o\u001e ^Jak&\u0012󶫛㌙W\u00185\t?;/󰍫\u0010A𢉡A\u000b*Q𐓀<𨧋i80\u000b%c{U\u000e\u0006W􇁲&~{R>iP\u0016쉂\u0005I󶿵*K󳕸a君\"gi\u0015􋉔.􅦕􇅟L\u0015𠛸<󸗚\u0017\u0014\u0018𘢗U󳥾f🕜𧥿~\u0004b\t󴴞\u000e꧶󼍺ት\u0008\u0015ᴳ𨂤QaZ)\u001ft\u0005\u0008.󶍳^𮑐\u0014󲭨{S𡭳sRGr󺠤󸘖$􈴘2~b𡨑", + "icon": "3-1-b5aa5007-2939-4c53-874b-aecfbb6244fd", "name": "n{􂇭oZn\u0011\u001bJt kj\u0006\r󶛟\"'{\u001aX𬵓?@􅵡Ly󼝟\u0005@$𞱾W𬩠𥏕mW󻺕\u0011\u0010^c)𭖇󱋢𩎓곽9󺣐􇻱􉭓\u0017\u0014\u0012My\u0019󳷤\u0018𦁩gmi䙓\u000fy:r[󻋻i.\\\u0001󷣯\u00175𭃩H#\u0012𘛸#l\u000f@𤞏@\u0015)𦀗Jg㺽c\u0006V\u0004􀷓𨫛􎅎\u0013Ჴ󷬹󽭮fQ躼󷱚􌞸|Ik\u0011X\u0016\u001c}ii󿂹M&.)𧽠\u0016L󵰲\u001bk\u0007! \u001a􈤅𤵬+\u001eRW\\x\u001f\u001dt󱏮􂸛芝\u0018\u0002쟲+\u0012􀬤,\\F%,w𪨎a\\]\u001e𢥟~X;f𠵒 􄋀p\u0011d8mhY7w\u001ee\u0003\u0011􏡱l\u0017{3&뾄\u0006\u0014V=D\u0000\u0005\u000f𖼅\u0007K_di=," } diff --git a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_9.json b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_9.json index 26171e0268a..28253966b76 100644 --- a/libs/wire-api/test/golden/testObject_TeamUpdateData_team_9.json +++ b/libs/wire-api/test/golden/testObject_TeamUpdateData_team_9.json @@ -1,5 +1,5 @@ { - "icon": "A\u001f𪔆𪑂\u0016\u0006ZmN\u00009RY\t1;\u001dp#'带\u0010l\n󴻉󰻅T𤲸\u0017󸽵 r+𞤪P/P𦕦1󲥺-w𦅒𪟠y\u000fC86\taO_􌈄;\u001e@\n\u0000𣪑\u0011󼨚𧅼7QX󾾢ᵪ7󼌹𭗻􃚐JP\n", + "icon": "3-1-3f6de95d-a973-4652-93c4-0ffb3fa381fb", "icon_key": "F;\u0003O\rTm\u0011𨈙0󼴪\u0014􂤗􁆌뫲7\u0004𭼴![\u0002󼐫󿧺\u0012\u0001\u0008\n\u000emV󼍵􏤁\u0006B𭻻z&𣏄\u0014HP౨WS𬤕\u0001QT\u001e\u0003$b_𭞁臭\u0000􈅃􎻠@~\u0010.~𢝞sl\u0018\u0005\u0019􇤃䈌V(^|𮦱\u001d䛔\u000er􏷱\u0019eb2(#*!𭄔B\u0007^󰊳\u001a{\u0012t\\𛀟\u000cu\"\u0017\u000e\np􀉷[\u0001lB𧖽lꭦL녿\u000f𡰯/\n\u001d2Gw~y𢻄uᅳ1󳶀\t𝢊l8CE\u0011L𮄖󳸎CB\u001d{Xl𤒯󲂺,भ#{^􁧮S=.g\u0016\u0003%\u0002b􏳊𬖏4:숸󿺀􎑞u󶪸\u001d\u0003!𝣟q\u001d.J􍃐􆲁*2􅎧\u0002􄹰x,.\u0013\u000cR\u001b\u0008󵉰/=2n^f\u001fRB\u000b\u0004K􆀍䚍$䎺\u0019~-}S󳐔ipLl𮧕IJ\u001d\u0016\u0008u渨\u0018kq@1m𞹒5|\u0012O1<' addPrepQuery Cql.updateTeamName (fromRange n, tid) for_ (u ^. iconUpdate) $ \i -> - addPrepQuery Cql.updateTeamIcon (fromRange i, tid) + addPrepQuery Cql.updateTeamIcon (decodeUtf8 . toByteString' $ i, tid) for_ (u ^. iconKeyUpdate) $ \k -> addPrepQuery Cql.updateTeamIconKey (fromRange k, tid) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 8ddea637422..5ebb4d902f4 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -129,6 +129,7 @@ tests s = test s "delete binding team (owner has no passwd)" (testDeleteBindingTeam False), test s "delete team conversation" testDeleteTeamConv, test s "update team data" testUpdateTeam, + test s "update team data icon validation" testUpdateTeamIconValidation, test s "update team member" testUpdateTeamMember, test s "update team status" testUpdateTeamStatus, -- Queue is emptied here to ensure that lingering events do not affect other tests @@ -1196,6 +1197,33 @@ testDeleteTeamConv = do Util.assertNotConvMember u x postConvCodeCheck code !!! const 404 === statusCode +testUpdateTeamIconValidation :: TestM () +testUpdateTeamIconValidation = do + g <- view tsGalley + owner <- Util.randomUser + let p = Util.symmPermissions [DoNotUseDeprecatedDeleteConversation] + member <- newTeamMember' p <$> Util.randomUser + Util.connectUsers owner (list1 (member ^. userId) []) + tid <- Util.createNonBindingTeam "foo" owner [member] + let update payload expectedStatusCode = + put + ( g + . paths ["teams", toByteString' tid] + . zUser owner + . zConn "conn" + . json payload + ) + !!! const expectedStatusCode + === statusCode + let payloadWithInvalidIcon = object ["name" .= String "name", "icon" .= String "invalid"] + update payloadWithInvalidIcon 400 + let payloadWithValidIcon = + object + [ "name" .= String "name", + "icon" .= String "3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" + ] + update payloadWithValidIcon 200 + testUpdateTeam :: TestM () testUpdateTeam = do g <- view tsGalley @@ -1218,7 +1246,7 @@ testUpdateTeam = do let u = newTeamUpdateData & nameUpdate .~ (Just $ unsafeRange "bar") - & iconUpdate .~ (Just $ unsafeRange "xxx") + & iconUpdate .~ fromByteString "3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" & iconKeyUpdate .~ (Just $ unsafeRange "yyy") WS.bracketR2 c owner (member ^. userId) $ \(wsOwner, wsMember) -> do put From 8a57938d152748b384725b891a9c05951334519e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 7 Feb 2022 16:46:43 +0100 Subject: [PATCH 18/58] Make RespondEmpty responses show up without a schema in swagger (#2104) They appeared as empty arrays, which is the schema for the unit type. --- changelog.d/3-bug-fixes/fix-respond-empty-swagger | 1 + libs/wire-api/src/Wire/API/Routes/MultiVerb.hs | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 3 deletions(-) create mode 100644 changelog.d/3-bug-fixes/fix-respond-empty-swagger diff --git a/changelog.d/3-bug-fixes/fix-respond-empty-swagger b/changelog.d/3-bug-fixes/fix-respond-empty-swagger new file mode 100644 index 00000000000..dcfc45e28ac --- /dev/null +++ b/changelog.d/3-bug-fixes/fix-respond-empty-swagger @@ -0,0 +1 @@ +Ensure empty responses show up without a schema in swagger. They were shown as empty arrays before. \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index ff0498d6d5a..80d4a70b4d6 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -196,7 +196,7 @@ simpleResponseSwagger = do & S.schema ?~ ref instance - (KnownStatus s, KnownSymbol desc, S.ToSchema a) => + (KnownSymbol desc, S.ToSchema a) => IsSwaggerResponse (Respond s desc a) where responseSwagger = simpleResponseSwagger @a @desc @@ -244,11 +244,20 @@ instance KnownStatus s => IsResponse cs (RespondAs '() s desc ()) where guard (responseStatusCode output == statusVal (Proxy @s)) instance - (KnownStatus s, KnownSymbol desc, S.ToSchema a) => - IsSwaggerResponse (RespondAs ct s desc a) + (KnownSymbol desc, S.ToSchema a) => + IsSwaggerResponse (RespondAs (ct :: *) s desc a) where responseSwagger = simpleResponseSwagger @a @desc +instance + (KnownSymbol desc) => + IsSwaggerResponse (RespondEmpty s desc) + where + responseSwagger = + pure $ + mempty + & S.description .~ Text.pack (symbolVal (Proxy @desc)) + type instance ResponseType (RespondStreaming s desc framing ct) = SourceIO ByteString instance From 9b390692748cf50ea8ec558e9fc087200c4ce5d3 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Feb 2022 19:37:59 +0100 Subject: [PATCH 19/58] Prometheus: Exclude ResponseRaw responses from metrics (#2108) This PR makes the `servantPrometheusMiddleware` ignore all `ResponseRaw` responses. The implementation of wai and prometheus lead to `ResponseRaw` being tracked with `statusCode` `500` irrespective if the handler was successful or not (see documentation of `wai-middleware-prometheus`'s `ignoreRawResponses` or note `[Raw Response]` in the codebase). This would remove all metrics for these endpoints, however looking at `observeSeconds` of `wai-middleware-prometheus` suggests that the status is optional, so maybe reporting duration without status is possible. This PR is a followup to https://github.com/wireapp/wire-server/pull/2081 which lead to `cannon`'s `"await-notifications"` endpoint erroneously reporting 500s metrics. This will also affect future potential future endpoints in `spar` and `carghold` as they also use `servantPrometheusMiddleware`. --- changelog.d/5-internal/prometheus-ignore-raw-responses | 1 + libs/metrics-wai/src/Data/Metrics/Servant.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 changelog.d/5-internal/prometheus-ignore-raw-responses diff --git a/changelog.d/5-internal/prometheus-ignore-raw-responses b/changelog.d/5-internal/prometheus-ignore-raw-responses new file mode 100644 index 00000000000..760a55f92a9 --- /dev/null +++ b/changelog.d/5-internal/prometheus-ignore-raw-responses @@ -0,0 +1 @@ +Prometheus: Ignore RawResponses (e.g. cannon's await responses) from metrics diff --git a/libs/metrics-wai/src/Data/Metrics/Servant.hs b/libs/metrics-wai/src/Data/Metrics/Servant.hs index 6f12519e283..2208561b097 100644 --- a/libs/metrics-wai/src/Data/Metrics/Servant.hs +++ b/libs/metrics-wai/src/Data/Metrics/Servant.hs @@ -44,7 +44,7 @@ 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 -servantPrometheusMiddleware _ = Promth.prometheus conf . Promth.instrumentHandlerValue promthNormalize +servantPrometheusMiddleware _ = Promth.prometheus conf . instrument promthNormalize where promthNormalize :: Wai.Request -> Text promthNormalize req = pathInfo @@ -52,6 +52,9 @@ servantPrometheusMiddleware _ = Promth.prometheus conf . Promth.instrumentHandle mPathInfo = Metrics.treeLookup (routesToPaths @api) $ cs <$> Wai.pathInfo req pathInfo = cs $ fromMaybe "N/A" mPathInfo + -- See Note [Raw Response] + instrument = Promth.instrumentHandlerValueWithFilter Promth.ignoreRawResponses + servantPlusWAIPrometheusMiddleware :: forall proxy api a m b. (RoutesToPaths api, Monad m) => Routes a m b -> proxy api -> Wai.Middleware servantPlusWAIPrometheusMiddleware routes _ = do Promth.prometheus conf . instrument (normalizeWaiRequestRoute paths) From a54c21ae878b06b7dd5f4822a8036f993ed51e3b Mon Sep 17 00:00:00 2001 From: zebot Date: Mon, 7 Feb 2022 19:38:43 +0100 Subject: [PATCH 20/58] chore: [charts] Update webapp version (#2107) Co-authored-by: Zebot --- changelog.d/0-release-notes/webapp-upgrade | 1 + charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/webapp-upgrade diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade new file mode 100644 index 00000000000..40ea570f4a9 --- /dev/null +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -0,0 +1 @@ +Upgrade webapp version to 2022-02-07-production.0-v0.29.2-0-a940a2e diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index b956b323de3..b1297070bc2 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2022-01-27-production.0-v0.28.29-0-42c9a1e" + tag: "2022-02-07-production.0-v0.29.2-0-a940a2e" service: https: externalPort: 443 From d981a2afb66876aa679f55d7835d133c9dd5e105 Mon Sep 17 00:00:00 2001 From: zebot Date: Mon, 7 Feb 2022 19:40:44 +0100 Subject: [PATCH 21/58] chore: [charts] Update team-settings version (#2106) Co-authored-by: Zebot --- changelog.d/0-release-notes/team-settings-upgrade | 1 + charts/team-settings/values.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/0-release-notes/team-settings-upgrade diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade new file mode 100644 index 00000000000..dbb2b895a84 --- /dev/null +++ b/changelog.d/0-release-notes/team-settings-upgrade @@ -0,0 +1 @@ +Upgrade team-settings version to 4.6.0-v0.29.3-0-4d9c229 diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index cfd6ddd2656..092ff8f719b 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.3.0-v0.28.28-a2f11cf" + tag: "4.6.0-v0.29.3-0-4d9c229" service: https: externalPort: 443 From 283b3274e0c13170cd5dac51a6efdb71566ab571 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 8 Feb 2022 08:35:23 +0100 Subject: [PATCH 22/58] SQSERVICES-1232 Prevent CSV Injection (#2096) * quote disallowed chars * additional tests * changelog * add extra-deps to stack.yaml --- changelog.d/3-bug-fixes/pr-2096 | 1 + libs/wire-api/package.yaml | 1 + libs/wire-api/src/Wire/API/Team/Export.hs | 53 ++++++++++---- libs/wire-api/test/unit/Main.hs | 2 + .../test/unit/Test/Wire/API/Team/Export.hs | 69 +++++++++++++++++++ libs/wire-api/wire-api.cabal | 2 + stack.yaml | 1 + 7 files changed, 115 insertions(+), 14 deletions(-) create mode 100644 changelog.d/3-bug-fixes/pr-2096 create mode 100644 libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs diff --git a/changelog.d/3-bug-fixes/pr-2096 b/changelog.d/3-bug-fixes/pr-2096 new file mode 100644 index 00000000000..e9342d70fcc --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-2096 @@ -0,0 +1 @@ +Escape disallowed characters at the beginning of CSV cells to prevent CSV injection vulnerability. diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index ffb719e83aa..b8b8c30c3ad 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -106,6 +106,7 @@ tests: - base - bytestring - bytestring-conversion + - bytestring-arbitrary >=0.1.3 - cassava - currency-codes - directory diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index b0fee5a4bee..1391f86b277 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -15,11 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Team.Export (TeamExportUser (..)) where +module Wire.API.Team.Export (TeamExportUser (..), quoted, unquoted) where import qualified Data.Aeson as Aeson import Data.Attoparsec.ByteString.Lazy (parseOnly) -import Data.ByteString.Conversion (FromByteString (..), toByteString') +import qualified Data.ByteString.Char8 as C +import Data.ByteString.Conversion (FromByteString (..), ToByteString, toByteString') import Data.Csv (DefaultOrdered (..), FromNamedRecord (..), Parser, ToNamedRecord (..), namedRecord, (.:)) import Data.Handle (Handle) import Data.Id (UserId) @@ -56,20 +57,23 @@ data TeamExportUser = TeamExportUser instance ToNamedRecord TeamExportUser where toNamedRecord row = namedRecord - [ ("display_name", toByteString' (tExportDisplayName row)), - ("handle", maybe "" toByteString' (tExportHandle row)), - ("email", maybe "" toByteString' (tExportEmail row)), - ("role", maybe "" toByteString' (tExportRole row)), - ("created_on", maybe "" toByteString' (tExportCreatedOn row)), - ("invited_by", maybe "" toByteString' (tExportInvitedBy row)), - ("idp_issuer", maybe "" toByteString' (tExportIdpIssuer row)), - ("managed_by", toByteString' (tExportManagedBy row)), - ("saml_name_id", toByteString' (tExportSAMLNamedId row)), - ("scim_external_id", toByteString' (tExportSCIMExternalId row)), + [ ("display_name", secureCsvFieldToByteString (tExportDisplayName row)), + ("handle", maybe "" secureCsvFieldToByteString (tExportHandle row)), + ("email", maybe "" secureCsvFieldToByteString (tExportEmail row)), + ("role", maybe "" secureCsvFieldToByteString (tExportRole row)), + ("created_on", maybe "" secureCsvFieldToByteString (tExportCreatedOn row)), + ("invited_by", maybe "" secureCsvFieldToByteString (tExportInvitedBy row)), + ("idp_issuer", maybe "" secureCsvFieldToByteString (tExportIdpIssuer row)), + ("managed_by", secureCsvFieldToByteString (tExportManagedBy row)), + ("saml_name_id", secureCsvFieldToByteString (tExportSAMLNamedId row)), + ("scim_external_id", secureCsvFieldToByteString (tExportSCIMExternalId row)), ("scim_rich_info", maybe "" (cs . Aeson.encode) (tExportSCIMRichInfo row)), - ("user_id", toByteString' (tExportUserId row)) + ("user_id", secureCsvFieldToByteString (tExportUserId row)) ] +secureCsvFieldToByteString :: forall a. ToByteString a => a -> ByteString +secureCsvFieldToByteString = quoted . toByteString' + instance DefaultOrdered TeamExportUser where headerOrder = const $ @@ -94,7 +98,7 @@ allowEmpty p str = Just <$> p str parseByteString :: forall a. FromByteString a => ByteString -> Parser a parseByteString bstr = - case parseOnly (parser @a) bstr of + case parseOnly (parser @a) (unquoted bstr) of Left err -> fail err Right thing -> pure thing @@ -113,3 +117,24 @@ instance FromNamedRecord TeamExportUser where <*> (nrec .: "scim_external_id" >>= parseByteString) <*> (nrec .: "scim_rich_info" >>= allowEmpty (maybe (fail "failed to decode RichInfo") pure . Aeson.decode . cs)) <*> (nrec .: "user_id" >>= parseByteString) + +quoted :: ByteString -> ByteString +quoted bs = case C.uncons bs of + -- fields that begin with a disallowed character are prepended with a single quote + Just ('=', _) -> '\'' `C.cons` bs + Just ('+', _) -> '\'' `C.cons` bs + Just ('-', _) -> '\'' `C.cons` bs + Just ('@', _) -> '\'' `C.cons` bs + -- tab + Just ('\x0009', _) -> '\'' `C.cons` bs + -- carriage return + Just ('\x000D', _) -> '\'' `C.cons` bs + -- if a field begins with a single quote we have to prepend another single quote to be able to decode back correctly + Just ('\'', _) -> '\'' `C.cons` bs + -- everything else is fine + _ -> bs + +unquoted :: ByteString -> ByteString +unquoted bstr = case C.uncons bstr of + Just ('\'', t) -> t + _ -> bstr diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index a2ab670a85f..b03243b5e93 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/libs/wire-api/test/unit/Main.hs @@ -29,6 +29,7 @@ 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.Export as Team.Export import qualified Test.Wire.API.Team.Member as Team.Member import qualified Test.Wire.API.User as User import qualified Test.Wire.API.User.RichInfo as User.RichInfo @@ -41,6 +42,7 @@ main = "Tests" [ Call.Config.tests, Team.Member.tests, + Team.Export.tests, User.tests, User.Search.tests, User.RichInfo.tests, diff --git a/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs b/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs new file mode 100644 index 00000000000..ca3656f5a3f --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Team.Export where + +import Data.ByteString.Arbitrary +import qualified Data.ByteString.Char8 as C +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (conjoin, counterexample, testProperty, (.||.), (===)) +import Wire.API.Team.Export + +tests :: TestTree +tests = + testGroup + "Export" + [ testTrivialExamples, + testRoundTrip, + testUnquotedProp, + testQuotedProp + ] + +testTrivialExamples :: TestTree +testTrivialExamples = testCase "quoted/unquoted examples" $ do + unquoted "'foobar" @?= "foobar" + unquoted "foobar" @?= "foobar" + unquoted "" @?= "" + quoted "" @?= "" + quoted "foobar" @?= "foobar" + quoted "=1+2" @?= "'=1+2" + +testRoundTrip :: TestTree +testRoundTrip = testProperty "quoted roundtrip" prop + where + prop (ABS bs) = counterexample (show $ quoted bs) $ bs === (unquoted . quoted) bs + +testUnquotedProp :: TestTree +testUnquotedProp = testProperty "unquoted arbitrary" prop + where + prop (ABS bs) = counterexample (show $ unquoted bs) $ (bs === unquoted bs) .||. startsWithSingleQuote bs + startsWithSingleQuote bs = case C.uncons bs of + Just ('\'', _) -> True + _ -> False + +testQuotedProp :: TestTree +testQuotedProp = testProperty "quoted" prop + where + prop (ABS bs) = counterexample (show $ quoted bs) $ conjoin (checkQuoted bs <$> disallowedChars) + checkQuoted bs char = quoted (char `C.cons` bs) === '\'' `C.cons` char `C.cons` bs + disallowedChars = ['@', '+', '-', '=', '\'', '\x0009', '\x000D'] diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 4a03c4b246a..b983ea00ffb 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -563,6 +563,7 @@ test-suite wire-api-tests Test.Wire.API.Roundtrip.CSV Test.Wire.API.Routes Test.Wire.API.Swagger + Test.Wire.API.Team.Export Test.Wire.API.Team.Member Test.Wire.API.User Test.Wire.API.User.RichInfo @@ -618,6 +619,7 @@ test-suite wire-api-tests , aeson-qq , base , bytestring + , bytestring-arbitrary >=0.1.3 , bytestring-conversion , case-insensitive , cassava diff --git a/stack.yaml b/stack.yaml index ec593380e81..7432f78f6b3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -77,6 +77,7 @@ nix: allow-newer: true extra-deps: +- bytestring-arbitrary-0.1.3@sha256:14db64d4fe126fbad2eb8d3601bfd80a693f3131e2db0e76891feffe44f10df8,1773 - git: https://github.com/fimad/prometheus-haskell commit: 2e3282e5fb27ba8d989c271a0a989823fad7ec43 subdirs: From 7db90057e676a619026d83a403354964b2cb9997 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 8 Feb 2022 11:39:37 +0100 Subject: [PATCH 23/58] better test naming (#2110) --- libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs b/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs index ca3656f5a3f..e361a126b6f 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Team/Export.hs @@ -32,7 +32,7 @@ import Wire.API.Team.Export tests :: TestTree tests = testGroup - "Export" + "Export - quoted and unquoted" [ testTrivialExamples, testRoundTrip, testUnquotedProp, @@ -62,7 +62,7 @@ testUnquotedProp = testProperty "unquoted arbitrary" prop _ -> False testQuotedProp :: TestTree -testQuotedProp = testProperty "quoted" prop +testQuotedProp = testProperty "quoted arbitrary" prop where prop (ABS bs) = counterexample (show $ quoted bs) $ conjoin (checkQuoted bs <$> disallowedChars) checkQuoted bs char = quoted (char `C.cons` bs) === '\'' `C.cons` char `C.cons` bs From 7c6c6639e05a353a9dfea7e76e696aacf29c1e26 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 8 Feb 2022 12:15:45 +0100 Subject: [PATCH 24/58] Wrap stack with NIX_BUILD_SHELL set to LD_LIBRARY_PATH compatible shell (#2105) * Wrap stack with NIX_BUILD_SHELL * changelog --- changelog.d/5-internal/nix-fix-build-shell | 1 + dev-packages.nix | 10 +++++++++- 2 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 changelog.d/5-internal/nix-fix-build-shell diff --git a/changelog.d/5-internal/nix-fix-build-shell b/changelog.d/5-internal/nix-fix-build-shell new file mode 100644 index 00000000000..b76550e9643 --- /dev/null +++ b/changelog.d/5-internal/nix-fix-build-shell @@ -0,0 +1 @@ +Wrap stack with NIX_BUILD_SHELL set to LD_LIBRARY_PATH compatible shell diff --git a/dev-packages.nix b/dev-packages.nix index 96e37719841..3725513319b 100644 --- a/dev-packages.nix +++ b/dev-packages.nix @@ -162,6 +162,14 @@ let export CONFIG_SHELL="${compile-deps}/bin/sh" exec "${pkgs.cabal-install}/bin/cabal" "$@" ''; + + # stack-deps.nix sets LD_LIBRARY_PATH, which could be incompatible with the + # system bash. To ensure that nix-shell invoked by stack uses the correct + # shell to build we set NIX_BUILD_SHELL here. + stack-wrapper = pkgs.writeShellScriptBin "stack" '' + export NIX_BUILD_SHELL="${pkgs.bash}/bin/bash" + exec "${pinned.stack}/bin/stack" "$@" + ''; in [ pkgs.cfssl @@ -179,7 +187,7 @@ in # To actually run buildah on nixos, I had to follow this: https://gist.github.com/alexhrescale/474d55635154e6b2cd6362c3bb403faf pkgs.buildah - pinned.stack + stack-wrapper pinned.helm pinned.helmfile pinned.kubectl From 2999cf098fee86ed3a7b09679fb6d635f38a1c3d Mon Sep 17 00:00:00 2001 From: rohan-wire <91096103+rohan-wire@users.noreply.github.com> Date: Tue, 8 Feb 2022 09:13:49 -0800 Subject: [PATCH 25/58] Update SFTd to version 3.0.18 (#2113) * Correct version of SFTd is 3.0.18 * Update restund to 0.5.1 to support Federation. * add changelog for sftd and restund updates. --- changelog.d/6-federation/PR-2113 | 2 ++ charts/restund/Chart.yaml | 2 +- charts/sftd/Chart.yaml | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) create mode 100644 changelog.d/6-federation/PR-2113 diff --git a/changelog.d/6-federation/PR-2113 b/changelog.d/6-federation/PR-2113 new file mode 100644 index 00000000000..53d308f8d84 --- /dev/null +++ b/changelog.d/6-federation/PR-2113 @@ -0,0 +1,2 @@ +Updated sftd to 3.0.18. +Updated restund to 0.5.1. diff --git a/charts/restund/Chart.yaml b/charts/restund/Chart.yaml index 423fbbe799a..4abac27d6a7 100644 --- a/charts/restund/Chart.yaml +++ b/charts/restund/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.1 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 0.4.17 +appVersion: 0.5.1 diff --git a/charts/sftd/Chart.yaml b/charts/sftd/Chart.yaml index 5d3b865d616..ee5503cb30d 100644 --- a/charts/sftd/Chart.yaml +++ b/charts/sftd/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 2.1.19 +appVersion: 3.0.18 From 3c024863c8abefb422f302fd28bc3663ba304cd6 Mon Sep 17 00:00:00 2001 From: rohan-wire <91096103+rohan-wire@users.noreply.github.com> Date: Tue, 8 Feb 2022 10:01:20 -0800 Subject: [PATCH 26/58] Revert restund to 0.4.17 (#2114) --- changelog.d/6-federation/restund | 1 + charts/restund/Chart.yaml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 changelog.d/6-federation/restund diff --git a/changelog.d/6-federation/restund b/changelog.d/6-federation/restund new file mode 100644 index 00000000000..03249717b65 --- /dev/null +++ b/changelog.d/6-federation/restund @@ -0,0 +1 @@ +Revert restund to 0.4.17. diff --git a/charts/restund/Chart.yaml b/charts/restund/Chart.yaml index 4abac27d6a7..423fbbe799a 100644 --- a/charts/restund/Chart.yaml +++ b/charts/restund/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.1 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 0.5.1 +appVersion: 0.4.17 From ea85c1e322fe5e0ff5fd0bcdbe9229c8171ad2e4 Mon Sep 17 00:00:00 2001 From: rohan-wire <91096103+rohan-wire@users.noreply.github.com> Date: Tue, 8 Feb 2022 13:52:12 -0800 Subject: [PATCH 27/58] Revert update of SFTd to 3.0.18 (#2115) --- changelog.d/6-federation/PR-2113 | 2 -- charts/sftd/Chart.yaml | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) delete mode 100644 changelog.d/6-federation/PR-2113 diff --git a/changelog.d/6-federation/PR-2113 b/changelog.d/6-federation/PR-2113 deleted file mode 100644 index 53d308f8d84..00000000000 --- a/changelog.d/6-federation/PR-2113 +++ /dev/null @@ -1,2 +0,0 @@ -Updated sftd to 3.0.18. -Updated restund to 0.5.1. diff --git a/charts/sftd/Chart.yaml b/charts/sftd/Chart.yaml index ee5503cb30d..5d3b865d616 100644 --- a/charts/sftd/Chart.yaml +++ b/charts/sftd/Chart.yaml @@ -11,4 +11,4 @@ version: 0.0.42 # This is the version number of the application being deployed. This version number should be # incremented each time you make changes to the application. Versions are not expected to # follow Semantic Versioning. They should reflect the version the application is using. -appVersion: 3.0.18 +appVersion: 2.1.19 From d5ef205eede1708d2b6755ab08f29658147f1df6 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 9 Feb 2022 16:19:12 +0100 Subject: [PATCH 28/58] SQSERVICES-1057 Ensure guest links enabled when join by code (#2084) * test case for failing QA scenario * ensure guest links enabled on post /converstation/join * changelog * make assertions more consistent * check also non team members can't join via link if feature disabled * check for guest link status on code-check * integration tests and fixes * don't check link access for team feature status, enhanced API docs --- changelog.d/3-bug-fixes/pr-2084 | 1 + .../src/Wire/API/Routes/Public/Galley.hs | 12 ++++- services/galley/src/Galley/API/Query.hs | 32 ++++++++--- services/galley/src/Galley/API/Update.hs | 50 +++++++++++------ services/galley/src/Galley/API/Util.hs | 12 ++--- services/galley/test/integration/API.hs | 54 +++++++++++++------ 6 files changed, 113 insertions(+), 48 deletions(-) create mode 100644 changelog.d/3-bug-fixes/pr-2084 diff --git a/changelog.d/3-bug-fixes/pr-2084 b/changelog.d/3-bug-fixes/pr-2084 new file mode 100644 index 00000000000..315f6ce5156 --- /dev/null +++ b/changelog.d/3-bug-fixes/pr-2084 @@ -0,0 +1 @@ +Ensure the guest links feature is enabled when someone joins by code. 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 9a9658d9393..74b1f33d9c7 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -320,10 +320,14 @@ type ConversationAPI = -- - MemberJoin event to members :<|> Named "join-conversation-by-code-unqualified" - ( Summary "Join a conversation using a reusable code" + ( Summary + "Join a conversation using a reusable code.\ + \If the guest links team feature is disabled, this will fail with 409 GuestLinksDisabled.\ + \Note that this is currently inconsistent (for backwards compatibility reasons) with `POST /conversations/code-check` which responds with 404 CodeNotFound if guest links are disabled." :> CanThrow CodeNotFound :> CanThrow ConvNotFound :> CanThrow TooManyMembers + :> CanThrow GuestLinksDisabled :> ZLocalUser :> ZConn :> "conversations" @@ -333,8 +337,12 @@ type ConversationAPI = ) :<|> Named "code-check" - ( Summary "Check validity of a conversation code" + ( Summary + "Check validity of a conversation code.\ + \If the guest links team feature is disabled, this will fail with 404 CodeNotFound.\ + \Note that this is currently inconsistent (for backwards compatibility reasons) with `POST /conversations/join` which responds with 409 GuestLinksDisabled if guest links are disabled." :> CanThrow CodeNotFound + :> CanThrow ConvNotFound :> "conversations" :> "code-check" :> ReqBody '[Servant.JSON] ConversationCode diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index d93eb382c45..bc2c34e127b 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -48,6 +48,7 @@ module Galley.API.Query getConversationMetaH, getConversationByReusableCode, ensureGuestLinksEnabled, + ensureGuestLinksEnabledWithError, ) where @@ -67,6 +68,7 @@ import Galley.API.Error import qualified Galley.API.Mapping as Mapping import Galley.API.Util import Galley.Cassandra.Paging +import Galley.Data.Types (Code (codeConversation)) import qualified Galley.Data.Types as Data import Galley.Effects import qualified Galley.Effects.ConversationStore as E @@ -529,8 +531,9 @@ getConversationByReusableCode :: Sem r ConversationCoverView getConversationByReusableCode lusr key value = do c <- verifyReusableCode (ConversationCode key value Nothing) - conv <- ensureConversationAccess (tUnqualified lusr) (Data.codeConversation c) CodeAccess - ensureGuestLinksEnabled conv + conv <- E.getConversation (codeConversation c) >>= note ConvNotFound + ensureConversationAccess (tUnqualified lusr) conv CodeAccess + ensureGuestLinksEnabled (Data.convTeam conv) pure $ coverView conv where coverView :: Data.Conversation -> ConversationCoverView @@ -541,22 +544,37 @@ getConversationByReusableCode lusr key value = do } -- FUTUREWORK(leif): refactor and make it consistent for all team features -ensureGuestLinksEnabled :: +ensureGuestLinksEnabledWithError :: forall r. ( Member (Error ConversationError) r, + Member (Error CodeError) r, Member TeamFeatureStore r, Member (Input Opts) r ) => - Data.Conversation -> + Either ConversationError CodeError -> + Maybe TeamId -> Sem r () -ensureGuestLinksEnabled conv = do +ensureGuestLinksEnabledWithError ex mbTid = do defaultStatus <- getDefaultFeatureStatus - maybeFeatureStatus <- join <$> TeamFeatures.getFeatureStatusNoConfig @'TeamFeatureGuestLinks `traverse` Data.convTeam conv + maybeFeatureStatus <- join <$> TeamFeatures.getFeatureStatusNoConfig @'TeamFeatureGuestLinks `traverse` mbTid case maybe defaultStatus tfwoStatus maybeFeatureStatus of TeamFeatureEnabled -> pure () - TeamFeatureDisabled -> throw GuestLinksDisabled + TeamFeatureDisabled -> case ex of + Left e -> throw e + Right e -> throw e where getDefaultFeatureStatus :: Sem r TeamFeatureStatusValue getDefaultFeatureStatus = do status <- input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) pure $ tfwoapsStatus status + +ensureGuestLinksEnabled :: + forall r. + ( Member (Error ConversationError) r, + Member (Error CodeError) r, + Member TeamFeatureStore r, + Member (Input Opts) r + ) => + Maybe TeamId -> + Sem r () +ensureGuestLinksEnabled = ensureGuestLinksEnabledWithError (Left GuestLinksDisabled) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index b341cc9ebdd..66ffd60a5cc 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -518,6 +518,7 @@ addCodeUnqualified :: ( Member CodeStore r, Member ConversationStore r, Member (Error ConversationError) r, + Member (Error CodeError) r, Member ExternalAccess r, Member GundeckAccess r, Member (Input (Local ())) r, @@ -539,6 +540,7 @@ addCode :: ( Member CodeStore r, Member ConversationStore r, Member (Error ConversationError) r, + Member (Error CodeError) r, Member ExternalAccess r, Member GundeckAccess r, Member (Input UTCTime) r, @@ -551,7 +553,7 @@ addCode :: Sem r AddCodeResult addCode lusr zcon lcnv = do conv <- E.getConversation (tUnqualified lcnv) >>= note ConvNotFound - Query.ensureGuestLinksEnabled conv + Query.ensureGuestLinksEnabled (convTeam conv) ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) ensureAccess conv CodeAccess ensureGuestsOrNonTeamMembersAllowed conv @@ -639,7 +641,7 @@ getCode :: getCode lusr cnv = do conv <- E.getConversation cnv >>= note ConvNotFound - Query.ensureGuestLinksEnabled conv + Query.ensureGuestLinksEnabled (convTeam conv) ensureAccess conv CodeAccess ensureConvMember (Data.convLocalMembers conv) (tUnqualified lusr) key <- E.makeKey cnv @@ -651,11 +653,21 @@ returnCode c = do mkConversationCode (codeKey c) (codeValue c) <$> E.getConversationCodeURI checkReusableCode :: - Members '[CodeStore, Error CodeError] r => + Members + '[ CodeStore, + ConversationStore, + TeamFeatureStore, + Error ConversationError, + Error CodeError, + Input Opts + ] + r => ConversationCode -> Sem r () -checkReusableCode convCode = - void $ verifyReusableCode convCode +checkReusableCode convCode = do + code <- verifyReusableCode convCode + conv <- E.getConversation (codeConversation code) >>= note ConvNotFound + Query.ensureGuestLinksEnabledWithError (Right CodeNotFound) (convTeam conv) joinConversationByReusableCode :: Members @@ -672,7 +684,8 @@ joinConversationByReusableCode :: Input Opts, Input UTCTime, MemberStore, - TeamStore + TeamStore, + TeamFeatureStore ] r => Local UserId -> @@ -681,7 +694,9 @@ joinConversationByReusableCode :: Sem r (UpdateResult Event) joinConversationByReusableCode lusr zcon convCode = do c <- verifyReusableCode convCode - joinConversation lusr zcon (codeConversation c) CodeAccess + conv <- E.getConversation (codeConversation c) >>= note ConvNotFound + Query.ensureGuestLinksEnabled (convTeam conv) + joinConversation lusr zcon conv CodeAccess joinConversationById :: Members @@ -696,15 +711,17 @@ joinConversationById :: Input Opts, Input UTCTime, MemberStore, - TeamStore + TeamStore, + TeamFeatureStore ] r => Local UserId -> ConnId -> ConvId -> Sem r (UpdateResult Event) -joinConversationById lusr zcon cnv = - joinConversation lusr zcon cnv LinkAccess +joinConversationById lusr zcon cnv = do + conv <- E.getConversation cnv >>= note ConvNotFound + joinConversation lusr zcon conv LinkAccess joinConversation :: Members @@ -719,18 +736,19 @@ joinConversation :: Input Opts, Input UTCTime, MemberStore, - TeamStore + TeamStore, + TeamFeatureStore ] r => Local UserId -> ConnId -> - ConvId -> + Data.Conversation -> Access -> Sem r (UpdateResult Event) -joinConversation lusr zcon cnv access = do - let lcnv = qualifyAs lusr cnv - conv <- ensureConversationAccess (tUnqualified lusr) cnv access - ensureGroupConversation $ conv +joinConversation lusr zcon conv access = do + let lcnv = qualifyAs lusr (convId conv) + ensureConversationAccess (tUnqualified lusr) conv access + ensureGroupConversation conv -- FUTUREWORK: remote users? ensureMemberLimit (toList $ Data.convLocalMembers conv) [tUnqualified lusr] getUpdateResult $ do diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index bbd5611ac1f..b3e35326c5b 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -587,17 +587,13 @@ ensureConversationAccess :: ] r => UserId -> - ConvId -> + Data.Conversation -> Access -> - Sem r Data.Conversation -ensureConversationAccess zusr cnv access = do - conv <- - getConversation cnv >>= note ConvNotFound + Sem r () +ensureConversationAccess zusr conv access = do ensureAccess conv access - zusrMembership <- - maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) + zusrMembership <- maybe (pure Nothing) (`getTeamMember` zusr) (Data.convTeam conv) ensureAccessRole (Data.convAccessRoles conv) [(zusr, zusrMembership)] - pure conv ensureAccess :: Member (Error ConversationError) r => diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index a9c5e052574..2e03ad4dec4 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -36,6 +36,7 @@ import qualified API.Teams.LegalHold.DisabledByDefault import API.Util import qualified API.Util as Util import API.Util.TeamFeature as TeamFeatures +import qualified API.Util.TeamFeature as Util import Bilge hiding (timeout) import Bilge.Assert import Brig.Types @@ -1217,7 +1218,7 @@ testGetCodeRejectedIfGuestLinksDisabled = do void $ decodeConvCodeEvent <$> postConvCode owner convId pure convId convId <- createConvWithGuestLink - let checkGetCode expectedStatus = getConvCode owner convId !!! statusCode === const expectedStatus + let checkGetCode expectedStatus = getConvCode owner convId !!! const expectedStatus === statusCode let setStatus tfStatus = TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId (Public.TeamFeatureStatusNoConfig tfStatus) !!! do const 200 === statusCode @@ -1250,32 +1251,55 @@ testJoinTeamConvGuestLinksDisabled = do galley <- view tsGalley let convName = "testConversation" (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 - userNotInTeam <- randomUser - Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, NonTeamMemberAccessRole] [GuestAccessRole] - convId <- decodeConvId <$> postTeamConv teamId owner [] (Just convName) [CodeAccess] (Just accessRoles) Nothing + eve <- ephemeralUser + bob <- randomUser + Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, NonTeamMemberAccessRole, GuestAccessRole] [] + convId <- decodeConvId <$> postTeamConv teamId owner [] (Just convName) [CodeAccess, LinkAccess] (Just accessRoles) Nothing cCode <- decodeConvCodeEvent <$> postConvCode owner convId - -- works by default - getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + let checkFeatureStatus fstatus = + Util.getTeamFeatureFlagWithGalley Public.TeamFeatureGuestLinks galley owner teamId !!! do + const 200 === statusCode + const (Right (Public.TeamFeatureStatusNoConfigAndLockStatus fstatus Public.Unlocked)) === responseJsonEither + + -- guest can join if guest link feature is enabled + checkFeatureStatus Public.TeamFeatureEnabled + getJoinCodeConv eve (conversationKey cCode) (conversationCode cCode) !!! do const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither const 200 === statusCode - - -- fails if disabled - let tfStatus = Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled - TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId tfStatus !!! do + postConvCodeCheck cCode !!! const 200 === statusCode + postJoinCodeConv eve cCode !!! const 200 === statusCode + -- non-team-members can join as well + postJoinCodeConv bob cCode !!! const 200 === statusCode + + -- disabled guest links feature + let disabled = Public.TeamFeatureStatusNoConfig Public.TeamFeatureDisabled + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId disabled !!! do const 200 === statusCode - getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + -- guest can't join if guest link feature is disabled + eve' <- ephemeralUser + bob' <- randomUser + getJoinCodeConv eve' (conversationKey cCode) (conversationCode cCode) !!! do const 409 === statusCode + postConvCodeCheck cCode !!! const 404 === statusCode + postJoinCodeConv eve' cCode !!! const 409 === statusCode + -- non-team-members can't join either + postJoinCodeConv bob' cCode !!! const 409 === statusCode + -- check feature status is still disabled + checkFeatureStatus Public.TeamFeatureDisabled -- after re-enabling, the old link is still valid - let tfStatus' = Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled - TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId tfStatus' !!! do + let enabled = Public.TeamFeatureStatusNoConfig Public.TeamFeatureEnabled + TeamFeatures.putTeamFeatureFlagWithGalley @'Public.TeamFeatureGuestLinks galley owner teamId enabled !!! do const 200 === statusCode - - getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do + getJoinCodeConv eve' (conversationKey cCode) (conversationCode cCode) !!! do const (Right (ConversationCoverView convId (Just convName))) === responseJsonEither const 200 === statusCode + postConvCodeCheck cCode !!! const 200 === statusCode + postJoinCodeConv eve' cCode !!! const 200 === statusCode + postJoinCodeConv bob' cCode !!! const 200 === statusCode + checkFeatureStatus Public.TeamFeatureEnabled testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do From f5f9f4bdcbb2e8a21f3a5bc1cabd6ec4619b734b Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 9 Feb 2022 20:44:17 +0100 Subject: [PATCH 29/58] SQSERVICES-1029 added validate SAML emails feature status to galley config (#2117) --- changelog.d/0-release-notes/pr-2117 | 2 + docs/reference/config-options.md | 13 ++++++ libs/galley-types/src/Galley/Types/Teams.hs | 42 +++++++++++++------ .../test/unit/Test/Galley/Types.hs | 1 + libs/wire-api/src/Wire/API/Team/Feature.hs | 7 ++++ .../galley/src/Galley/API/Teams/Features.hs | 17 ++++---- .../test/integration/API/Teams/Feature.hs | 5 ++- .../Test/Spar/Scim/UserSpec.hs | 7 +++- services/spar/test-integration/Util/Email.hs | 6 +-- 9 files changed, 71 insertions(+), 29 deletions(-) create mode 100644 changelog.d/0-release-notes/pr-2117 diff --git a/changelog.d/0-release-notes/pr-2117 b/changelog.d/0-release-notes/pr-2117 new file mode 100644 index 00000000000..e585c88b8c8 --- /dev/null +++ b/changelog.d/0-release-notes/pr-2117 @@ -0,0 +1,2 @@ +Optional team feature config `validateSAMLEmails` added to galley.yaml. +The feature was disabled by default before this release and is now enabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#validate-saml-emails](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#validate-saml-emails) diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index 85592137db8..4dbe4865584 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -167,6 +167,19 @@ The lock status for individual teams can be changed via the internal API (`PUT / The feature status for individual teams can be changed via the public API (if the feature is unlocked). +### Validate SAML Emails + +If this is enabled, if a new user account is created with an email address as SAML NameID or SCIM externalId, users will receive a validation email. If they follow the validation procedure, they will be able to receive emails about their account, eg., if a new device is associated with the account. If the user does not validate their email address, they can still use it to login. + +Validate SAML emails is enabled by default; this is almost always what you want. If you want a different configuration, use the following syntax: + +```yaml +# galley.yaml +validateSAMLEmails: + defaults: + status: disabled +``` + ### Federation Domain Regardless of whether a backend wants to enable federation or not, the operator diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index d4f7b0b984b..1760508d966 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -33,6 +33,7 @@ module Galley.Types.Teams flagConferenceCalling, flagSelfDeletingMessages, flagConversationGuestLinks, + flagsTeamFeatureValidateSAMLEmailsStatus, Defaults (..), unDefaults, FeatureSSO (..), @@ -217,7 +218,8 @@ data FeatureFlags = FeatureFlags _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing)), _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)), - _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)) + _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)), + _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails)) } deriving (Eq, Show, Generic) @@ -265,20 +267,34 @@ instance FromJSON FeatureFlags where <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) <*> (fromMaybe (Defaults defaultGuestLinksStatus) <$> (obj .:? "conversationGuestLinks")) + <*> (fromMaybe (Defaults defaultTeamFeatureValidateSAMLEmailsStatus) <$> (obj .:? "validateSAMLEmails")) instance ToJSON FeatureFlags where - toJSON (FeatureFlags sso legalhold searchVisibility appLock classifiedDomains fileSharing conferenceCalling selfDeletingMessages guestLinks) = - object $ - [ "sso" .= sso, - "legalhold" .= legalhold, - "teamSearchVisibility" .= searchVisibility, - "appLock" .= appLock, - "classifiedDomains" .= classifiedDomains, - "fileSharing" .= fileSharing, - "conferenceCalling" .= conferenceCalling, - "selfDeletingMessages" .= selfDeletingMessages, - "conversationGuestLinks" .= guestLinks - ] + toJSON + ( FeatureFlags + sso + legalhold + searchVisibility + appLock + classifiedDomains + fileSharing + conferenceCalling + selfDeletingMessages + guestLinks + validateSAMLEmails + ) = + object + [ "sso" .= sso, + "legalhold" .= legalhold, + "teamSearchVisibility" .= searchVisibility, + "appLock" .= appLock, + "classifiedDomains" .= classifiedDomains, + "fileSharing" .= fileSharing, + "conferenceCalling" .= conferenceCalling, + "selfDeletingMessages" .= selfDeletingMessages, + "conversationGuestLinks" .= guestLinks, + "validateSAMLEmails" .= validateSAMLEmails + ] instance FromJSON FeatureSSO where parseJSON (String "enabled-by-default") = pure FeatureSSOEnabledByDefault diff --git a/libs/galley-types/test/unit/Test/Galley/Types.hs b/libs/galley-types/test/unit/Test/Galley/Types.hs index 91d766c02dc..6720b746947 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -98,3 +98,4 @@ instance Arbitrary FeatureFlags where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index e3127733d82..bdd44107006 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -42,6 +42,7 @@ module Wire.API.Team.Feature defaultSelfDeletingMessagesStatus, defaultGuestLinksStatus, defaultTeamFeatureFileSharing, + defaultTeamFeatureValidateSAMLEmailsStatus, -- * Swagger typeTeamFeatureName, @@ -615,6 +616,12 @@ instance Cass.Cql LockStatusValue where defaultGuestLinksStatus :: TeamFeatureStatusNoConfigAndLockStatus defaultGuestLinksStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked +---------------------------------------------------------------------- +-- TeamFeatureValidateSAMLEmails + +defaultTeamFeatureValidateSAMLEmailsStatus :: TeamFeatureStatusNoConfig +defaultTeamFeatureValidateSAMLEmailsStatus = TeamFeatureStatusNoConfig TeamFeatureEnabled + ---------------------------------------------------------------------- -- internal diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 20582c84846..085b62b48c0 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -52,6 +52,7 @@ where import Control.Lens import qualified Data.Aeson as Aeson import Data.ByteString.Conversion hiding (fromList) +import Data.Either.Extra (eitherToMaybe) import qualified Data.HashMap.Strict as HashMap import Data.Id import Data.Qualified @@ -382,18 +383,16 @@ setTeamSearchVisibilityAvailableInternal = setFeatureStatusNoConfig @'Public.Tea Public.TeamFeatureEnabled -> const (pure ()) getValidateSAMLEmailsInternal :: - Member TeamFeatureStore r => + forall r. + ( Member TeamFeatureStore r, + Member (Input Opts) r + ) => GetFeatureInternalParam -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureValidateSAMLEmails) getValidateSAMLEmailsInternal = - either - (const $ Public.TeamFeatureStatusNoConfig <$> getDef) - (getFeatureStatusNoConfig @'Public.TeamFeatureValidateSAMLEmails getDef) - where - -- FUTUREWORK: we may also want to get a default from the server config file here, like for - -- sso, and team search visibility. - -- Use getFeatureStatusWithDefault - getDef = pure Public.TeamFeatureDisabled + getFeatureStatusWithDefaultConfig @'Public.TeamFeatureValidateSAMLEmails + flagsTeamFeatureValidateSAMLEmailsStatus + . eitherToMaybe setValidateSAMLEmailsInternal :: Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 7bd706536b6..2340a461014 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -62,7 +62,7 @@ tests s = test s "LegalHold" testLegalHold, test s "SearchVisibility" testSearchVisibility, test s "DigitalSignatures" $ testSimpleFlag @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, - test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, + test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureEnabled, test s "FileSharing with lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled Public.Unlocked, test s "Classified Domains (enabled)" testClassifiedDomainsEnabled, test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, @@ -677,7 +677,8 @@ testAllFeatures = do toS TeamFeatureGuestLinks .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled - Public.Unlocked + Public.Unlocked, + toS TeamFeatureValidateSAMLEmails .= Public.TeamFeatureStatusNoConfig TeamFeatureEnabled ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 3296cea35a5..df08dab7be7 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -76,6 +76,7 @@ import qualified Web.Scim.Schema.Meta as Scim import qualified Web.Scim.Schema.PatchOp as PatchOp import qualified Web.Scim.Schema.User as Scim.User import qualified Wire.API.Team.Export as CsvExport +import qualified Wire.API.Team.Feature as Feature import Wire.API.Team.Invitation (Invitation (..)) import Wire.API.User.IdentityProvider (IdP) import qualified Wire.API.User.IdentityProvider as User @@ -1691,7 +1692,9 @@ specEmailValidation = do setup :: HasCallStack => Bool -> TestSpar (UserId, Email) setup enabled = do (tok, (_ownerid, teamid, idp)) <- registerIdPAndScimToken - when enabled $ enableSamlEmailValidation teamid + if enabled + then setSamlEmailValidation teamid Feature.TeamFeatureEnabled + else setSamlEmailValidation teamid Feature.TeamFeatureDisabled (user, email) <- randomScimUserWithEmail scimStoredUser <- createUser tok user uref :: SAML.UserRef <- @@ -1754,7 +1757,7 @@ specSCIMManaged = do let brig = env ^. teBrig (tok, (_ownerid, teamid, idp, (_, privCreds))) <- registerIdPAndScimTokenWithMeta - enableSamlEmailValidation teamid + setSamlEmailValidation teamid Feature.TeamFeatureEnabled (user, oldEmail) <- randomScimUserWithEmail storedUser <- createUser tok user let uid :: UserId = Scim.id . Scim.thing $ storedUser diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index 30bab91ed80..f476aaeaec2 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -155,9 +155,9 @@ getActivationCode brig ep = do let acode = ActivationCode . Ascii.unsafeFromText <$> (lbs ^? key "code" . _String) return $ (,) <$> akey <*> acode -enableSamlEmailValidation :: HasCallStack => TeamId -> TestSpar () -enableSamlEmailValidation tid = do +setSamlEmailValidation :: HasCallStack => TeamId -> Feature.TeamFeatureStatusValue -> TestSpar () +setSamlEmailValidation tid status = do galley <- view teGalley - let req = put $ galley . paths p . json (Feature.TeamFeatureStatusNoConfig Feature.TeamFeatureEnabled) + let req = put $ galley . paths p . json (Feature.TeamFeatureStatusNoConfig status) p = ["/i/teams", toByteString' tid, "features", "validate-saml-emails"] call req !!! const 200 === statusCode From 0cad7beabb0037f013f87652ef8e99b3e1d586c8 Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 9 Feb 2022 22:27:41 +0100 Subject: [PATCH 30/58] Update stack.yaml.lock. (#2118) --- stack.yaml.lock | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/stack.yaml.lock b/stack.yaml.lock index 93c1f9bb6e5..b8831b6c919 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,6 +4,13 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: +- completed: + hackage: bytestring-arbitrary-0.1.3@sha256:14db64d4fe126fbad2eb8d3601bfd80a693f3131e2db0e76891feffe44f10df8,1773 + pantry-tree: + size: 347 + sha256: ea68c43da070afaddd1758f3180140f4cb844f559d4663246757b27a72200092 + original: + hackage: bytestring-arbitrary-0.1.3@sha256:14db64d4fe126fbad2eb8d3601bfd80a693f3131e2db0e76891feffe44f10df8,1773 - completed: subdir: wai-middleware-prometheus name: wai-middleware-prometheus From e21ffa5bdd3f977c011661fbb6627d54934e6e55 Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 10 Feb 2022 13:20:05 +0100 Subject: [PATCH 31/58] Fix json schema error in docs. (#2120) --- docs/reference/user/registration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/reference/user/registration.md b/docs/reference/user/registration.md index 59c464c05fb..fee8c310227 100644 --- a/docs/reference/user/registration.md +++ b/docs/reference/user/registration.md @@ -34,7 +34,7 @@ POST /register "password": "secret", // 6-digit 'email_code' or 'phone_code' - "email_code": 123456 + "email_code": "123456" } ``` From 9761a10e2eac36f79e3c46eac12fe0db96c59139 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 10 Feb 2022 13:29:11 +0100 Subject: [PATCH 32/58] added errors to swagger docs (#2122) --- libs/wire-api/src/Wire/API/ErrorDescription.hs | 2 ++ libs/wire-api/src/Wire/API/Routes/Public/Galley.hs | 9 +++++++++ 2 files changed, 11 insertions(+) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 888b5289a39..ba54332ca98 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -370,3 +370,5 @@ type BroadcastLimitExceeded = 400 "too-many-users-to-broadcast" "Too many users to fan out the broadcast event to." + +type InvalidAction = ErrorDescription 403 "invalid-actions" "The specified actions are invalid." 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 74b1f33d9c7..8ee2ed41f03 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -294,6 +294,15 @@ type ConversationAPI = :<|> Named "add-members-to-conversation" ( Summary "Add qualified members to an existing conversation." + :> CanThrow ConvNotFound + :> CanThrow ActionDenied + :> CanThrow (InvalidOp "Invalid operation") + :> CanThrow InvalidAction + :> CanThrow TooManyMembers + :> CanThrow ConvAccessDenied + :> CanThrow NotATeamMember + :> CanThrow NotConnected + :> CanThrow MissingLegalholdConsent :> ZLocalUser :> ZConn :> "conversations" From efda17f9c8a74e6ad92ab90de300a60454f614a6 Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 11 Feb 2022 14:06:40 +0100 Subject: [PATCH 33/58] Extend test suite slightly (#2123) --- changelog.d/5-internal/i-tests | 1 + .../test-integration/Test/Spar/APISpec.hs | 11 ++++--- .../Test/Spar/Scim/UserSpec.hs | 8 +++-- services/spar/test-integration/Util/Core.hs | 32 +++++++++++++++++-- 4 files changed, 43 insertions(+), 9 deletions(-) create mode 100644 changelog.d/5-internal/i-tests diff --git a/changelog.d/5-internal/i-tests b/changelog.d/5-internal/i-tests new file mode 100644 index 00000000000..0744635755c --- /dev/null +++ b/changelog.d/5-internal/i-tests @@ -0,0 +1 @@ +Add integration tests for scim/saml user creation \ No newline at end of file diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 1ddf267512f..7d129a03ceb 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -336,10 +336,14 @@ specFinalizeLogin = do let newUserRef@(UserRef _ subj) = either (error . show) (^. userRefL) $ parseFromDocument (fromSignedAuthnResponse newUserAuthnResp) + newUserId <- getUserIdViaRef newUserRef + + do + checkChangeRoleOfTeamMember teamid ownerid newUserId + -- remove user from team settings do env <- ask - newUserId <- getUserIdViaRef newUserRef _ <- call . get $ ( (env ^. teGalley) @@ -359,9 +363,8 @@ specFinalizeLogin = do liftIO $ threadDelay 100000 -- make sure deletion is done. if we don't want to take -- the time, we should find another way to robustly -- confirm that deletion has completed in the background. - - -- second login do + -- second login authnreq <- negotiateAuthnRequest idp authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp spmeta authnreq True loginSuccess =<< submitAuthnResponse teamid authnresp @@ -768,7 +771,7 @@ mkSsoOwner firstOwner tid idp privcreds = do authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq True loginresp <- submitAuthnResponse tid authnresp liftIO $ responseStatus loginresp `shouldBe` status200 - [ssoOwner] <- filter (/= firstOwner) <$> getTeamMembers firstOwner tid + [ssoOwner] <- filter (/= firstOwner) <$> getTeamMemberIds firstOwner tid promoteTeamMember firstOwner tid ssoOwner pure ssoOwner diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index df08dab7be7..a2efd0acfdd 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -364,8 +364,10 @@ testCreateUserNoIdP = do -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) - members <- getTeamMembers userid tid + members <- getTeamMemberIds userid tid liftIO $ members `shouldContain` [userid] + + checkChangeRoleOfTeamMember tid owner userid where -- cloned from brig's integration tests @@ -440,9 +442,11 @@ testCreateUserWithSamlIdP = do -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) - members <- getTeamMembers userid tid + members <- getTeamMemberIds userid tid liftIO $ members `shouldContain` [userid] + checkChangeRoleOfTeamMember tid owner userid + -- | Test that Wire-specific schemas are added to the SCIM user record, even if the schemas -- were not present in the original record during creation. testSchemaIsAdded :: TestSpar () diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index ad1f2de7df9..1ef07088d7e 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -63,6 +63,7 @@ module Util.Core createTeamMember, deleteUserOnBrig, getTeams, + getTeamMemberIds, getTeamMembers, promoteTeamMember, getSelfProfile, @@ -127,6 +128,8 @@ module Util.Core callDeleteDefaultSsoCode, checkErr, checkErrHspec, + updateTeamMemberRole, + checkChangeRoleOfTeamMember, ) where @@ -163,13 +166,14 @@ import Data.UUID.V4 as UUID (nextRandom) import qualified Data.Yaml as Yaml import GHC.TypeLits import qualified Galley.Types.Teams as Galley +import qualified Galley.Types.Teams as Teams import Imports hiding (head) import Network.HTTP.Client.MultipartFormData import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Options.Applicative as OPA import Polysemy (Sem) -import SAML2.WebSSO as SAML +import SAML2.WebSSO as SAML hiding ((<$$>)) import qualified SAML2.WebSSO.API.Example as SAML import SAML2.WebSSO.Test.Lenses (userRefL) import SAML2.WebSSO.Test.MockResponse @@ -200,6 +204,7 @@ import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) import qualified Wire.API.Team.Feature as Public import qualified Wire.API.Team.Invitation as TeamInvitation import qualified Wire.API.Team.Member as Member +import qualified Wire.API.Team.Role as Role import Wire.API.User (HandleUpdate (HandleUpdate), UserUpdate) import qualified Wire.API.User as User import Wire.API.User.Identity (mkSampleUref) @@ -585,7 +590,10 @@ getTeams u gly = do ) return $ responseJsonUnsafe r -getTeamMembers :: HasCallStack => UserId -> TeamId -> TestSpar [UserId] +getTeamMemberIds :: HasCallStack => UserId -> TeamId -> TestSpar [UserId] +getTeamMemberIds usr tid = (^. Galley.userId) <$$> getTeamMembers usr tid + +getTeamMembers :: HasCallStack => UserId -> TeamId -> TestSpar [Member.TeamMember] getTeamMembers usr tid = do gly <- view teGalley resp <- @@ -594,7 +602,7 @@ getTeamMembers usr tid = do (mems ^. Galley.teamMembers) + pure $ mems ^. Galley.teamMembers promoteTeamMember :: HasCallStack => UserId -> TeamId -> UserId -> TestSpar () promoteTeamMember usr tid memid = do @@ -1302,3 +1310,21 @@ updateProfileBrig brig uid uupd = . contentJson . json uupd ) + +updateTeamMemberRole :: (MonadReader TestEnv m, MonadIO m) => TeamId -> UserId -> UserId -> Role.Role -> m () +updateTeamMemberRole tid adminUid targetUid role = do + spar <- asks (^. teGalley) + void . call . put $ + spar + . zUser adminUid + . zConn "user" + . paths ["teams", toByteString' tid, "members"] + . json (Member.mkNewTeamMember targetUid (Galley.rolePermissions role) Nothing) + . expect2xx + +-- https://wearezeta.atlassian.net/browse/SQSERVICES-1279: change role after successful creation/activation. +checkChangeRoleOfTeamMember :: TeamId -> UserId -> UserId -> TestSpar () +checkChangeRoleOfTeamMember tid adminId targetId = forM_ [minBound ..] $ \role -> do + updateTeamMemberRole tid adminId targetId role + [member'] <- filter ((== targetId) . (^. Member.userId)) <$> getTeamMembers adminId tid + liftIO $ (member' ^. Member.permissions . to Teams.permissionsRole) `shouldBe` Just role From c83b1b15e493999aa53474af2cf9db61809153c3 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 14 Feb 2022 11:03:57 +0100 Subject: [PATCH 34/58] Add freetext search results to "search-users" federation endpoint (#2085) Co-authored-by: Stefan Matting --- .../2-features/federated-freetext-search | 1 + services/brig/src/Brig/API/Federation.hs | 27 +++++++++-- services/brig/src/Brig/Federation/Client.hs | 2 +- services/brig/src/Brig/User/API/Search.hs | 2 +- .../brig/src/Brig/User/Search/SearchIndex.hs | 48 +++++++++---------- .../brig/test/integration/API/Federation.hs | 45 +++++++++++++---- 6 files changed, 86 insertions(+), 39 deletions(-) create mode 100644 changelog.d/2-features/federated-freetext-search diff --git a/changelog.d/2-features/federated-freetext-search b/changelog.d/2-features/federated-freetext-search new file mode 100644 index 00000000000..15f2de58796 --- /dev/null +++ b/changelog.d/2-features/federated-freetext-search @@ -0,0 +1 @@ +Add freetext search results to "search-users" federation endpoint diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 5375a174217..f56cd0645b9 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -31,6 +31,7 @@ import Brig.IO.Intra (notify) import Brig.Types (PrekeyBundle, Relation (Accepted)) import Brig.Types.User.Event import Brig.User.API.Handle +import qualified Brig.User.Search.SearchIndex as Q import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) @@ -111,11 +112,27 @@ claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFede -- (This decision may change in the future) searchUsers :: Domain -> SearchRequest -> Handler [Contact] searchUsers _ (SearchRequest searchTerm) = do - let maybeHandle = parseHandle searchTerm - maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle - case maybeOwnerId of - Nothing -> pure [] - Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] + let maxResults = 15 + + maybeExactHandleMatch <- exactHandleSearch + + let exactHandleMatchCount = length maybeExactHandleMatch + esMaxResults = maxResults - exactHandleMatchCount + + esResult <- + if esMaxResults > 0 + then Q.searchIndex Nothing Nothing searchTerm esMaxResults + else pure $ SearchResult 0 0 0 [] + + pure $ maybeToList maybeExactHandleMatch <> searchResults esResult + where + exactHandleSearch :: Handler (Maybe Contact) + exactHandleSearch = do + let maybeHandle = parseHandle searchTerm + maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle + case maybeOwnerId of + Nothing -> pure Nothing + Just foundUser -> lift $ fmap listToMaybe $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] getUserClients :: Domain -> GetUserClients -> Handler (UserMap (Set PubClient)) getUserClients _ (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 0e0a8cf91bd..73cec62b241 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -82,7 +82,7 @@ claimMultiPrekeyBundle domain uc = do searchUsers :: Domain -> SearchRequest -> FederationAppIO [Public.Contact] searchUsers domain searchTerm = do - Log.warn $ Log.msg $ T.pack "Brig-federation: search call on remote backend" + Log.info $ Log.msg $ T.pack "Brig-federation: search call on remote backend" executeFederated @"search-users" domain searchTerm getUserClients :: Domain -> GetUserClients -> FederationAppIO (UserMap (Set PubClient)) diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 0b4b39add53..ee4170bd29e 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -157,7 +157,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do esResult <- if esMaxResults > 0 - then Q.searchIndex searcherId teamSearchInfo searchTerm esMaxResults + then Q.searchIndex (Just searcherId) (Just teamSearchInfo) searchTerm esMaxResults else pure $ SearchResult 0 0 0 [] -- Prepend results matching exact handle and results from ES. diff --git a/services/brig/src/Brig/User/Search/SearchIndex.hs b/services/brig/src/Brig/User/Search/SearchIndex.hs index eab8d457486..9a323b02231 100644 --- a/services/brig/src/Brig/User/Search/SearchIndex.hs +++ b/services/brig/src/Brig/User/Search/SearchIndex.hs @@ -42,8 +42,8 @@ import Wire.API.User (ColourId (..), Name (fromName)) searchIndex :: (MonadIndexIO m, MonadReader Env m) => -- | The user performing the search. - UserId -> - TeamSearchInfo -> + (Maybe UserId) -> + Maybe TeamSearchInfo -> -- | The search query Text -> -- | The maximum number of results. @@ -90,7 +90,7 @@ userDocToContact localDomain UserDoc {..} = do -- it allows to experiment with different queries (perhaps in an A/B context). -- -- FUTUREWORK: Drop legacyPrefixMatch -defaultUserQuery :: UserId -> TeamSearchInfo -> Text -> IndexQuery Contact +defaultUserQuery :: Maybe UserId -> Maybe TeamSearchInfo -> Text -> IndexQuery Contact defaultUserQuery u teamSearchInfo (normalized -> term') = let matchPhraseOrPrefix = ES.QueryMultiMatchQuery $ @@ -143,32 +143,32 @@ defaultUserQuery u teamSearchInfo (normalized -> term') = } in mkUserQuery u teamSearchInfo queryWithBoost -mkUserQuery :: UserId -> TeamSearchInfo -> ES.Query -> IndexQuery Contact -mkUserQuery (review _TextId -> self) teamSearchInfo q = +mkUserQuery :: Maybe UserId -> Maybe TeamSearchInfo -> ES.Query -> IndexQuery Contact +mkUserQuery (fmap (review _TextId) -> self) teamSearchInfo q = IndexQuery q ( ES.Filter . ES.QueryBoolQuery $ boolQuery - { ES.boolQueryMustNotMatch = [termQ "_id" self], + { ES.boolQueryMustNotMatch = [termQ "_id" uid | uid <- maybeToList self], ES.boolQueryMustMatch = - [ optionallySearchWithinTeam teamSearchInfo, - ES.QueryBoolQuery - boolQuery - { ES.boolQueryShouldMatch = - [ termQ "account_status" "active", - -- Also match entries where the account_status field is not present. - -- These must have been inserted before we added the account_status - -- and at that time we only inserted active users in the first place. - -- This should be unnecessary after re-indexing, but let's be lenient - -- here for a while. - ES.QueryBoolQuery - boolQuery - { ES.boolQueryMustNotMatch = - [ES.QueryExistsQuery (ES.FieldName "account_status")] - } - ] - } - ] + maybe [] (pure . optionallySearchWithinTeam) teamSearchInfo + ++ [ ES.QueryBoolQuery + boolQuery + { ES.boolQueryShouldMatch = + [ termQ "account_status" "active", + -- Also match entries where the account_status field is not present. + -- These must have been inserted before we added the account_status + -- and at that time we only inserted active users in the first place. + -- This should be unnecessary after re-indexing, but let's be lenient + -- here for a while. + ES.QueryBoolQuery + boolQuery + { ES.boolQueryMustNotMatch = + [ES.QueryExistsQuery (ES.FieldName "account_status")] + } + ] + } + ] } ) [] diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index da58718cc40..d1559afc4c5 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -42,7 +42,7 @@ import Bilge.Assert import qualified Brig.Options as Opt import Brig.Types import Control.Arrow (Arrow (first), (&&&)) -import Data.Aeson (encode) +import Data.Aeson import Data.Domain (Domain (Domain)) import Data.Handle (Handle (..)) import Data.Id @@ -54,8 +54,7 @@ import Data.Timeout import qualified Data.UUID.V4 as UUIDv4 import Federation.Util (generateClientPrekeys) import Imports -import Test.QuickCheck (arbitrary) -import Test.QuickCheck.Gen (generate) +import Test.QuickCheck hiding ((===)) import Test.Tasty import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit (assertEqual, assertFailure) @@ -74,6 +73,8 @@ tests m opts brig cannon fedBrigClient = testGroup "federation" [ test m "POST /federation/search-users : Found" (testSearchSuccess brig fedBrigClient), + test m "POST /federation/search-users : Found (fulltext)" (testFulltextSearchSuccess brig fedBrigClient), + test m "POST /federation/search-users : Found (multiple users)" (testFulltextSearchMultipleUsers brig fedBrigClient), test m "POST /federation/search-users : NotFound" (testSearchNotFound fedBrigClient), test m "POST /federation/search-users : Empty Input - NotFound" (testSearchNotFoundEmpty fedBrigClient), test m "POST /federation/get-user-by-handle : Found" (testGetUserByHandleSuccess brig fedBrigClient), @@ -92,17 +93,45 @@ tests m opts brig cannon fedBrigClient = testSearchSuccess :: Brig -> FedClient 'Brig -> Http () testSearchSuccess brig fedBrigClient = do (handle, user) <- createUserWithHandle brig + refreshIndex brig + + let quid = userQualifiedId user + + searchResult <- + runFedClient @"search-users" fedBrigClient (Domain "example.com") $ + SearchRequest (fromHandle handle) + liftIO $ do + let contacts = contactQualifiedId <$> searchResult + assertEqual "should return the user id" [quid] contacts + +testFulltextSearchSuccess :: Brig -> FedClient 'Brig -> Http () +testFulltextSearchSuccess brig fedBrigClient = do + (_, user) <- createUserWithHandle brig + refreshIndex brig + let quid = userQualifiedId user - -- create another user with a similar handle and the same display name - -- That user should not be returned in search results. - -- (as federated search should only search for exact handle matches) + searchResult <- + runFedClient @"search-users" fedBrigClient (Domain "example.com") $ + SearchRequest ((fromName . userDisplayName) user) + liftIO $ do + let contacts = contactQualifiedId <$> searchResult + assertEqual "should return the user id" [quid] contacts + +testFulltextSearchMultipleUsers :: Brig -> FedClient 'Brig -> Http () +testFulltextSearchMultipleUsers brig fedBrigClient = do + (handle, user) <- createUserWithHandle brig + + let quid = userQualifiedId user + + -- Create another user with a display name matching the first user's handle. + -- Both users should be returned in search results when freetext search is enabled. identityThief <- randomUser brig - void $ putHandle brig (userId identityThief) (fromHandle handle <> "a") update'' :: UserUpdate <- liftIO $ generate arbitrary let update' = update'' {uupName = Just (Name (fromHandle handle))} update = RequestBodyLBS . encode $ update' put (brig . path "/self" . contentJson . zUser (userId identityThief) . zConn "c" . body update) !!! const 200 === statusCode + refreshIndex brig searchResult <- @@ -110,7 +139,7 @@ testSearchSuccess brig fedBrigClient = do SearchRequest (fromHandle handle) liftIO $ do let contacts = contactQualifiedId <$> searchResult - assertEqual "should return only the first user id but not the identityThief" [quid] contacts + assertEqual "should find both users" (sort [quid, userQualifiedId identityThief]) (sort contacts) testSearchNotFound :: FedClient 'Brig -> Http () testSearchNotFound fedBrigClient = do From 793c527e1c1f5ea57f5309327a4d7f5620391f94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 14 Feb 2022 11:18:30 +0100 Subject: [PATCH 35/58] Refactor Proteus Conversation Creation Handlers and Drop Managed Conversations (#2125) * Unify conversation creation helpers - Both a team and a non-team conversation share a lot of code, hence this change puts them into a single function * Drop managed conversations - This also removes a test for an unsuccessful creation of a managed team conversation * Remove uses of `managed` from `team_conv` table * Simplify createConnectConversation * Remove extra copyright header * Improve some conversation assertions * Remove the NoAddToManaged error Co-authored-by: Paolo Capriotti --- changelog.d/5-internal/drop-managed-convs | 1 + .../5-internal/refactor-proteus-conv-create | 1 + .../Network/Wire/Client/API/Conversation.hs | 2 +- libs/galley-types/src/Galley/Types.hs | 2 - libs/galley-types/src/Galley/Types/Teams.hs | 1 - libs/wire-api/src/Wire/API/Conversation.hs | 210 ++---- .../src/Wire/API/Routes/Public/Galley.hs | 4 +- .../src/Wire/API/Team/Conversation.hs | 22 +- .../golden/Test/Wire/API/Golden/FromJSON.hs | 22 +- .../golden/Test/Wire/API/Golden/Generated.hs | 13 +- .../API/Golden/Generated/ConvTeamInfo_user.hs | 5 +- .../Golden/Generated/NewConvManaged_user.hs | 71 -- .../Golden/Generated/NewConvUnmanaged_user.hs | 122 ---- .../Wire/API/Golden/Generated/NewConv_user.hs | 72 ++ .../Generated/TeamConversationList_team.hs | 680 +++++++++--------- .../Golden/Generated/TeamConversation_team.hs | 42 +- .../golden/Test/Wire/API/Golden/Generator.hs | 2 - .../testObject_NewConvManaged_user_1.json | 17 - ..._1.json => testObject_NewConv_user_1.json} | 0 ..._3.json => testObject_NewConv_user_3.json} | 0 ...estObject_TeamConversationList_team_1.json | 16 +- ...stObject_TeamConversationList_team_10.json | 8 +- ...stObject_TeamConversationList_team_11.json | 6 +- ...stObject_TeamConversationList_team_12.json | 14 +- ...stObject_TeamConversationList_team_13.json | 18 +- ...stObject_TeamConversationList_team_14.json | 18 +- ...stObject_TeamConversationList_team_15.json | 4 +- ...stObject_TeamConversationList_team_16.json | 16 +- ...stObject_TeamConversationList_team_17.json | 36 +- ...stObject_TeamConversationList_team_18.json | 18 +- ...stObject_TeamConversationList_team_19.json | 28 +- ...estObject_TeamConversationList_team_2.json | 26 +- ...stObject_TeamConversationList_team_20.json | 2 +- ...estObject_TeamConversationList_team_3.json | 8 +- ...estObject_TeamConversationList_team_4.json | 32 +- ...estObject_TeamConversationList_team_5.json | 4 +- ...estObject_TeamConversationList_team_6.json | 12 +- ...estObject_TeamConversationList_team_7.json | 8 +- ...estObject_TeamConversationList_team_8.json | 36 +- ...estObject_TeamConversationList_team_9.json | 42 +- .../testObject_TeamConversation_team_11.json | 2 +- .../testObject_TeamConversation_team_14.json | 2 +- .../testObject_TeamConversation_team_15.json | 2 +- .../testObject_TeamConversation_team_17.json | 2 +- .../testObject_TeamConversation_team_19.json | 2 +- .../testObject_TeamConversation_team_4.json | 2 +- .../testObject_TeamConversation_team_8.json | 2 +- .../testObject_TeamConversation_team_9.json | 2 +- .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 2 - libs/wire-api/wire-api.cabal | 3 +- services/brig/src/Brig/Provider/API.hs | 6 +- .../brig/test/integration/API/Provider.hs | 2 +- .../brig/test/integration/API/Team/Util.hs | 29 +- .../test/integration/Federation/End2end.hs | 2 +- services/brig/test/integration/Util.hs | 2 +- services/galley/src/Galley/API/Create.hs | 248 ++----- services/galley/src/Galley/API/Error.hs | 10 - services/galley/src/Galley/API/Internal.hs | 7 - services/galley/src/Galley/API/One2One.hs | 16 - services/galley/src/Galley/API/Teams.hs | 10 +- services/galley/src/Galley/API/Update.hs | 7 - .../src/Galley/Cassandra/Conversation.hs | 4 +- .../galley/src/Galley/Cassandra/Instances.hs | 5 +- .../galley/src/Galley/Cassandra/Queries.hs | 16 +- services/galley/src/Galley/Cassandra/Team.hs | 6 +- services/galley/test/integration/API.hs | 16 +- services/galley/test/integration/API/Teams.hs | 20 - services/galley/test/integration/API/Util.hs | 18 +- 68 files changed, 791 insertions(+), 1295 deletions(-) create mode 100644 changelog.d/5-internal/drop-managed-convs create mode 100644 changelog.d/5-internal/refactor-proteus-conv-create delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConv_user.hs delete mode 100644 libs/wire-api/test/golden/testObject_NewConvManaged_user_1.json rename libs/wire-api/test/golden/{testObject_NewConvUnmanaged_user_1.json => testObject_NewConv_user_1.json} (100%) rename libs/wire-api/test/golden/{testObject_NewConvUnmanaged_user_3.json => testObject_NewConv_user_3.json} (100%) diff --git a/changelog.d/5-internal/drop-managed-convs b/changelog.d/5-internal/drop-managed-convs new file mode 100644 index 00000000000..b854d6bd4d2 --- /dev/null +++ b/changelog.d/5-internal/drop-managed-convs @@ -0,0 +1 @@ +Drop managed conversations diff --git a/changelog.d/5-internal/refactor-proteus-conv-create b/changelog.d/5-internal/refactor-proteus-conv-create new file mode 100644 index 00000000000..6e85b41cd57 --- /dev/null +++ b/changelog.d/5-internal/refactor-proteus-conv-create @@ -0,0 +1 @@ +Refactor internal handlers for Proteus conversation creation diff --git a/libs/api-client/src/Network/Wire/Client/API/Conversation.hs b/libs/api-client/src/Network/Wire/Client/API/Conversation.hs index 2fffb2f5528..e034aa95069 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Conversation.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Conversation.hs @@ -140,6 +140,6 @@ createConv users name = sessionRequest req rsc readBody method POST . path "conversations" . acceptJson - . json (NewConvUnmanaged (NewConv users [] name mempty Nothing Nothing Nothing Nothing roleNameWireAdmin)) + . json (NewConv users [] name mempty Nothing Nothing Nothing Nothing roleNameWireAdmin) $ empty rsc = status201 :| [] diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 018af4ff9ab..b6e94f6bbd0 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -66,8 +66,6 @@ module Galley.Types CustomBackend (..), Invite (..), NewConv (..), - NewConvManaged (..), - NewConvUnmanaged (..), MemberUpdate (..), OtherMemberUpdate (..), MutedStatus (..), diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 1760508d966..4313979db00 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -80,7 +80,6 @@ module Galley.Types.Teams TeamConversation, newTeamConversation, conversationId, - managedConversation, TeamConversationList, newTeamConversationList, teamConversations, diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index 29cf0dab1dc..f89fa2f1261 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -57,8 +57,6 @@ module Wire.API.Conversation -- * create NewConv (..), - NewConvManaged (..), - NewConvUnmanaged (..), ConvTeamInfo (..), -- * invite @@ -110,8 +108,7 @@ import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Imports import System.Random (randomRIO) -import qualified Test.QuickCheck as QC -import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.Arbitrary import Wire.API.Conversation.Member import Wire.API.Conversation.Role (RoleName, roleNameWireAdmin) import Wire.API.Routes.MultiTablePaging @@ -589,60 +586,7 @@ instance ToSchema ReceiptMode where -------------------------------------------------------------------------------- -- create -{- Note [managed conversations] -~~~~~~~~~~~~~~~~~~~~~~ - -Managed conversations are conversations where every team member is present -automatically. They have been implemented on the backend but never used in -production, and as of July 2, 2018 no managed conversations exist "in the -wild". They also prevent us from decoupling team size and conversation size --- by essentially demanding that they be equal, while in reality allowing -huge teams is much easier than allowing huge conversations and we want to -use that fact. - -For the reason above, it's been decided to remove support for creating -managed conversations from the backend. However, we are not 100% sure that -we won't introduce them again in the future, and so we'd like to retain all -the logic and tests that we have now. - -To that end we have the following types: - - * data NewConv -- allows both managed and unmanaged conversations; - * newtype NewConvUnmanaged -- only unmanaged; - * newtype NewConvManaged -- only managed. - -Those are invariants enforced on the 'FromJSON' level. For convenience, the -newtype constructors have not been hidden. - -The public POST /conversations endpoint only allows unmanaged conversations. -For creating managed conversations we provide an internal endpoint called -POST /i/conversations/managed. When an endpoint receives payload -corresponding to a forbidden conversation type, it throws a JSON parsing -error, which is not optimal but it doesn't matter since nobody is trying to -create managed conversations anyway. --} - -newtype NewConvManaged = NewConvManaged NewConv - deriving stock (Eq, Show) - deriving (FromJSON, ToJSON) via Schema NewConvManaged - -instance ToSchema NewConvManaged where - schema = NewConvManaged <$> unwrap .= newConvSchema `withParser` check - where - unwrap (NewConvManaged c) = c - check c - | newConvIsManaged c = pure c - | otherwise = fail "only managed conversations are allowed here" - -instance Arbitrary NewConvManaged where - arbitrary = - NewConvManaged <$> (arbitrary `QC.suchThat` newConvIsManaged) - -newtype NewConvUnmanaged = NewConvUnmanaged NewConv - deriving stock (Eq, Show) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema NewConvUnmanaged - --- | Used to describe a 'NewConvUnmanaged'. +-- | Used to describe a 'NewConv'. modelNewConversation :: Doc.Model modelNewConversation = Doc.defineModel "NewConversation" $ do Doc.description "JSON object to create a new conversation" @@ -665,19 +609,6 @@ modelNewConversation = Doc.defineModel "NewConversation" $ do Doc.description "Conversation receipt mode" Doc.optional -instance ToSchema NewConvUnmanaged where - schema = NewConvUnmanaged <$> unwrap .= newConvSchema `withParser` check - where - unwrap (NewConvUnmanaged c) = c - check c - | newConvIsManaged c = - fail "managed conversations have been deprecated" - | otherwise = pure c - -instance Arbitrary NewConvUnmanaged where - arbitrary = - NewConvUnmanaged <$> (arbitrary `QC.suchThat` (not . newConvIsManaged)) - data NewConv = NewConv { newConvUsers :: [UserId], -- | A list of qualified users, which can include some local qualified users @@ -694,72 +625,69 @@ data NewConv = NewConv } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform NewConv) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NewConv) -newConvSchema :: ValueSchema NamedSwaggerDoc NewConv -newConvSchema = - objectWithDocModifier - "NewConv" - (description ?~ "JSON object to create a new conversation. When using 'qualified_users' (preferred), you can omit 'users'") - $ NewConv - <$> newConvUsers - .= ( fieldWithDocModifier - "users" - (description ?~ usersDesc) - (array schema) - <|> pure [] - ) - <*> newConvQualifiedUsers - .= ( fieldWithDocModifier - "qualified_users" - (description ?~ qualifiedUsersDesc) - (array schema) - <|> pure [] - ) - <*> newConvName .= maybe_ (optField "name" schema) - <*> (Set.toList . newConvAccess) - .= (fromMaybe mempty <$> optField "access" (Set.fromList <$> array schema)) - <*> newConvAccessRoles .= accessRolesSchemaOpt - <*> newConvTeam - .= maybe_ - ( optFieldWithDocModifier - "team" - (description ?~ "Team information of this conversation") - schema - ) - <*> newConvMessageTimer - .= maybe_ - ( optFieldWithDocModifier - "message_timer" - (description ?~ "Per-conversation message timer") - schema - ) - <*> newConvReceiptMode .= maybe_ (optField "receipt_mode" schema) - <*> newConvUsersRole - .= ( fieldWithDocModifier "conversation_role" (description ?~ usersRoleDesc) schema - <|> pure roleNameWireAdmin - ) - where - usersDesc = - "List of user IDs (excluding the requestor) to be \ - \part of this conversation (deprecated)" - qualifiedUsersDesc = - "List of qualified user IDs (excluding the requestor) \ - \to be part of this conversation" - usersRoleDesc :: Text - usersRoleDesc = - cs $ - "The conversation permissions the users \ - \added in this request should have. \ - \Optional, defaults to '" - <> show roleNameWireAdmin - <> "' if unset." - -newConvIsManaged :: NewConv -> Bool -newConvIsManaged = maybe False cnvManaged . newConvTeam - -data ConvTeamInfo = ConvTeamInfo - { cnvTeamId :: TeamId, - cnvManaged :: Bool +instance ToSchema NewConv where + schema = + objectWithDocModifier + "NewConv" + (description ?~ "JSON object to create a new conversation. When using 'qualified_users' (preferred), you can omit 'users'") + $ NewConv + <$> newConvUsers + .= ( fieldWithDocModifier + "users" + (description ?~ usersDesc) + (array schema) + <|> pure [] + ) + <*> newConvQualifiedUsers + .= ( fieldWithDocModifier + "qualified_users" + (description ?~ qualifiedUsersDesc) + (array schema) + <|> pure [] + ) + <*> newConvName .= maybe_ (optField "name" schema) + <*> (Set.toList . newConvAccess) + .= (fromMaybe mempty <$> optField "access" (Set.fromList <$> array schema)) + <*> newConvAccessRoles .= accessRolesSchemaOpt + <*> newConvTeam + .= maybe_ + ( optFieldWithDocModifier + "team" + (description ?~ "Team information of this conversation") + schema + ) + <*> newConvMessageTimer + .= maybe_ + ( optFieldWithDocModifier + "message_timer" + (description ?~ "Per-conversation message timer") + schema + ) + <*> newConvReceiptMode .= maybe_ (optField "receipt_mode" schema) + <*> newConvUsersRole + .= ( fieldWithDocModifier "conversation_role" (description ?~ usersRoleDesc) schema + <|> pure roleNameWireAdmin + ) + where + usersDesc = + "List of user IDs (excluding the requestor) to be \ + \part of this conversation (deprecated)" + qualifiedUsersDesc = + "List of qualified user IDs (excluding the requestor) \ + \to be part of this conversation" + usersRoleDesc :: Text + usersRoleDesc = + cs $ + "The conversation permissions the users \ + \added in this request should have. \ + \Optional, defaults to '" + <> show roleNameWireAdmin + <> "' if unset." + +newtype ConvTeamInfo = ConvTeamInfo + { cnvTeamId :: TeamId } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ConvTeamInfo) @@ -772,13 +700,15 @@ instance ToSchema ConvTeamInfo where (description ?~ "Team information") $ ConvTeamInfo <$> cnvTeamId .= field "teamid" schema - <*> cnvManaged + <* const () .= ( fieldWithDocModifier "managed" - (description ?~ "Whether this is a managed team conversation") - schema - <|> pure False + (description ?~ "(Not parsed any more) Whether this is a managed team conversation") + (c (False :: Bool)) ) + where + c :: ToJSON a => a -> ValueSchema SwaggerDoc () + c val = mkSchema mempty (const (pure ())) (const (pure (toJSON val))) modelTeamInfo :: Doc.Model modelTeamInfo = Doc.defineModel "TeamInfo" $ do 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 8ee2ed41f03..6e7b1f4be18 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -250,7 +250,7 @@ type ConversationAPI = :> ZLocalUser :> ZConn :> "conversations" - :> ReqBody '[Servant.JSON] NewConvUnmanaged + :> ReqBody '[Servant.JSON] NewConv :> ConversationVerb ) :<|> Named @@ -271,7 +271,7 @@ type ConversationAPI = :> ZConn :> "conversations" :> "one2one" - :> ReqBody '[Servant.JSON] NewConvUnmanaged + :> ReqBody '[Servant.JSON] NewConv :> ConversationVerb ) -- This endpoint can lead to the following events being sent: diff --git a/libs/wire-api/src/Wire/API/Team/Conversation.hs b/libs/wire-api/src/Wire/API/Team/Conversation.hs index c3e9c3e49ec..f6fb56f92a7 100644 --- a/libs/wire-api/src/Wire/API/Team/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Team/Conversation.hs @@ -24,7 +24,6 @@ module Wire.API.Team.Conversation TeamConversation, newTeamConversation, conversationId, - managedConversation, -- * TeamConversationList TeamConversationList, @@ -49,9 +48,8 @@ import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) -------------------------------------------------------------------------------- -- TeamConversation -data TeamConversation = TeamConversation - { _conversationId :: ConvId, - _managedConversation :: Bool +newtype TeamConversation = TeamConversation + { _conversationId :: ConvId } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform TeamConversation) @@ -59,20 +57,15 @@ data TeamConversation = TeamConversation instance ToSchema TeamConversation where declareNamedSchema _ = do idSchema <- declareSchemaRef (Proxy @ConvId) - let managed = - toSchema (Proxy @Bool) - & description ?~ "Indicates if this is a managed team conversation." pure $ NamedSchema (Just "TeamConversation") $ mempty & description ?~ "team conversation data" & over properties - ( (at "managed" ?~ Inline managed) - . (at "conversation" ?~ idSchema) - ) + (at "conversation" ?~ idSchema) -newTeamConversation :: ConvId -> Bool -> TeamConversation +newTeamConversation :: ConvId -> TeamConversation newTeamConversation = TeamConversation modelTeamConversation :: Doc.Model @@ -80,19 +73,18 @@ modelTeamConversation = Doc.defineModel "TeamConversation" $ do Doc.description "team conversation data" Doc.property "conversation" Doc.bytes' $ Doc.description "conversation ID" - Doc.property "managed" Doc.bool' $ - Doc.description "Indicates if this is a managed team conversation." instance ToJSON TeamConversation where toJSON t = object [ "conversation" .= _conversationId t, - "managed" .= _managedConversation t + -- FUTUREWORK: get rid of the "managed" field in the next version of the API + "managed" .= False ] instance FromJSON TeamConversation where parseJSON = withObject "team conversation" $ \o -> - TeamConversation <$> o .: "conversation" <*> o .: "managed" + TeamConversation <$> o .: "conversation" -------------------------------------------------------------------------------- -- TeamConversationList diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs index f30027e4044..1294ca9bd06 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs @@ -22,12 +22,11 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Wire.API.Golden.Generated.Invite_user (testObject_Invite_user_2) import Test.Wire.API.Golden.Generated.MemberUpdateData_user -import Test.Wire.API.Golden.Generated.NewConvUnmanaged_user import Test.Wire.API.Golden.Generated.NewOtrMessage_user import Test.Wire.API.Golden.Generated.RmClient_user import Test.Wire.API.Golden.Generated.SimpleMember_user import Test.Wire.API.Golden.Runner -import Wire.API.Conversation (Conversation, MemberUpdate, NewConvManaged, NewConvUnmanaged, OtherMemberUpdate) +import Wire.API.Conversation (Conversation, MemberUpdate, OtherMemberUpdate) import Wire.API.User (NewUser, NewUserPublic) import Wire.API.User.Client (RmClient) @@ -43,25 +42,6 @@ tests = [ (testObject_SimpleMember_user_2, "testObject_SimpleMember_user_2.json"), (testObject_SimpleMember_user_2, "testObject_SimpleMember_user_2-2.json") ], - testGroup - "NewConvUnmanaged" - [ testCase "success" $ - testFromJSONObject - testObject_NewConvUnmanaged_user_1 - "testObject_NewConvUnmanaged_user_1.json", - testCase - "failure" - $ testFromJSONFailureWithMsg - @NewConvUnmanaged - (Just "managed conversations have been deprecated") - "testObject_NewConvUnmanaged_user_2.json" - ], - testCase - "NewConvManaged failure" - $ testFromJSONFailureWithMsg - @NewConvManaged - (Just "only managed conversations are allowed here") - "testObject_NewConvManaged_user_2.json", testCase "RmClient" $ testFromJSONObjects diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index 2b0f1dc2e8b..9d9d1b0c614 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -113,8 +113,7 @@ import qualified Test.Wire.API.Golden.Generated.NewAssetToken_user import qualified Test.Wire.API.Golden.Generated.NewBotRequest_provider import qualified Test.Wire.API.Golden.Generated.NewBotResponse_provider import qualified Test.Wire.API.Golden.Generated.NewClient_user -import qualified Test.Wire.API.Golden.Generated.NewConvManaged_user -import qualified Test.Wire.API.Golden.Generated.NewConvUnmanaged_user +import qualified Test.Wire.API.Golden.Generated.NewConv_user import qualified Test.Wire.API.Golden.Generated.NewLegalHoldClient_team import qualified Test.Wire.API.Golden.Generated.NewLegalHoldService_team import qualified Test.Wire.API.Golden.Generated.NewOtrMessage_user @@ -389,14 +388,10 @@ tests = [ (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_1, "testObject_Conversation_user_1.json"), (Test.Wire.API.Golden.Generated.Conversation_user.testObject_Conversation_user_2, "testObject_Conversation_user_2.json") ], - testGroup "Golden: NewConvUnmanaged_user" $ + testGroup "Golden: NewConv_user" $ testObjects - [ (Test.Wire.API.Golden.Generated.NewConvUnmanaged_user.testObject_NewConvUnmanaged_user_1, "testObject_NewConvUnmanaged_user_1.json"), - (Test.Wire.API.Golden.Generated.NewConvUnmanaged_user.testObject_NewConvUnmanaged_user_3, "testObject_NewConvUnmanaged_user_3.json") - ], - testGroup "Golden: NewConvManaged_user" $ - testObjects - [ (Test.Wire.API.Golden.Generated.NewConvManaged_user.testObject_NewConvManaged_user_1, "testObject_NewConvManaged_user_1.json") + [ (Test.Wire.API.Golden.Generated.NewConv_user.testObject_NewConv_user_1, "testObject_NewConv_user_1.json"), + (Test.Wire.API.Golden.Generated.NewConv_user.testObject_NewConv_user_3, "testObject_NewConv_user_3.json") ], testGroup "Golden: ConversationList_20_28Id_20_2a_20C_29_user" $ testObjects diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs index a73ec7f8435..bbd2b16e299 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ConvTeamInfo_user.hs @@ -19,12 +19,11 @@ module Test.Wire.API.Golden.Generated.ConvTeamInfo_user where import Data.Id (Id (Id)) import qualified Data.UUID as UUID (fromString) -import Imports (Bool (False), fromJust) +import Imports (fromJust) import Wire.API.Conversation (ConvTeamInfo (..)) testObject_ConvTeamInfo_user_1 :: ConvTeamInfo testObject_ConvTeamInfo_user_1 = ConvTeamInfo - { cnvTeamId = Id (fromJust (UUID.fromString "0000003f-0000-0059-0000-002200000028")), - cnvManaged = False + { cnvTeamId = Id (fromJust (UUID.fromString "0000003f-0000-0059-0000-002200000028")) } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs deleted file mode 100644 index 2d760ecb05c..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvManaged_user.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Wire.API.Golden.Generated.NewConvManaged_user where - -import Data.Domain -import Data.Id (Id (Id)) -import Data.Misc (Milliseconds (Ms, ms)) -import qualified Data.Set as Set (fromList) -import qualified Data.UUID as UUID (fromString) -import Imports (Bool (True), Maybe (Just, Nothing), fromJust) -import Wire.API.Conversation - ( AccessRoleV2 (..), - ConvTeamInfo (ConvTeamInfo, cnvManaged, cnvTeamId), - NewConv - ( NewConv, - newConvAccess, - newConvAccessRoles, - newConvMessageTimer, - newConvName, - newConvQualifiedUsers, - newConvReceiptMode, - newConvTeam, - newConvUsers, - newConvUsersRole - ), - NewConvManaged (..), - ReceiptMode (ReceiptMode, unReceiptMode), - ) -import Wire.API.Conversation.Role (parseRoleName) - -testDomain :: Domain -testDomain = Domain "test.example.com" - -testObject_NewConvManaged_user_1 :: NewConvManaged -testObject_NewConvManaged_user_1 = - NewConvManaged - ( NewConv - { newConvUsers = [], - newConvQualifiedUsers = [], - newConvName = Nothing, - newConvAccess = Set.fromList [], - newConvAccessRoles = Just (Set.fromList [TeamMemberAccessRole, GuestAccessRole]), - newConvTeam = - Just - ( ConvTeamInfo - { cnvTeamId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000000")), - cnvManaged = True - } - ), - newConvMessageTimer = Just (Ms {ms = 193643728192048}), - newConvReceiptMode = Just (ReceiptMode {unReceiptMode = 4}), - newConvUsersRole = fromJust (parseRoleName "37q9eeybycp5972td4oo9_r7y16eh6n67z5spda8sffy8qv") - } - ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs deleted file mode 100644 index 69046ee0d45..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConvUnmanaged_user.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Wire.API.Golden.Generated.NewConvUnmanaged_user where - -import Data.Domain (Domain (Domain)) -import Data.Id (Id (Id)) -import Data.Misc (Milliseconds (Ms, ms)) -import Data.Qualified (Qualified (Qualified)) -import qualified Data.Set as Set (fromList) -import qualified Data.UUID as UUID (fromString) -import Imports -import Wire.API.Conversation - ( Access (CodeAccess, InviteAccess, LinkAccess, PrivateAccess), - AccessRoleV2 (..), - ConvTeamInfo (ConvTeamInfo, cnvManaged, cnvTeamId), - NewConv - ( NewConv, - newConvAccess, - newConvAccessRoles, - newConvMessageTimer, - newConvName, - newConvQualifiedUsers, - newConvReceiptMode, - newConvTeam, - newConvUsers, - newConvUsersRole - ), - NewConvUnmanaged (..), - ReceiptMode (ReceiptMode, unReceiptMode), - ) -import Wire.API.Conversation.Role (parseRoleName) - -testDomain :: Domain -testDomain = Domain "testdomain.example.com" - -testObject_NewConvUnmanaged_user_1 :: NewConvUnmanaged -testObject_NewConvUnmanaged_user_1 = - NewConvUnmanaged - ( NewConv - { newConvUsers = - [ Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), - Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")) - ], - newConvQualifiedUsers = [], - newConvName = Nothing, - newConvAccess = Set.fromList [PrivateAccess, InviteAccess], - newConvAccessRoles = Just $ Set.fromList [TeamMemberAccessRole, GuestAccessRole], - newConvTeam = - Just - ( ConvTeamInfo - { cnvTeamId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), - cnvManaged = False - } - ), - newConvMessageTimer = Just (Ms {ms = 3320987366258987}), - newConvReceiptMode = Just (ReceiptMode {unReceiptMode = 1}), - newConvUsersRole = fromJust (parseRoleName "8tp2gs7b6") - } - ) - -testObject_NewConvUnmanaged_user_2 :: NewConvUnmanaged -testObject_NewConvUnmanaged_user_2 = - NewConvUnmanaged - ( NewConv - { newConvUsers = [], - newConvQualifiedUsers = [Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))) testDomain], - newConvName = Just "\128527\1061495", - newConvAccess = Set.fromList [], - newConvAccessRoles = Nothing, - newConvTeam = - Just - ( ConvTeamInfo - { cnvTeamId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001")), - cnvManaged = True - } - ), - newConvMessageTimer = Just (Ms {ms = 2406292360203739}), - newConvReceiptMode = Just (ReceiptMode {unReceiptMode = -1}), - newConvUsersRole = - fromJust - ( parseRoleName - "vmao7psxph3fenvbpsu1u57fns5pfo53d67k98om378rnxr0crcpak_mpspn8q_3m1b02n2n133s1d7q5w3qgmt_5e_dgtvzon8an7dtauiecd32" - ) - } - ) - -testObject_NewConvUnmanaged_user_3 :: NewConvUnmanaged -testObject_NewConvUnmanaged_user_3 = - NewConvUnmanaged - ( NewConv - { newConvUsers = [], - newConvQualifiedUsers = [], - newConvName = Nothing, - newConvAccess = Set.fromList [InviteAccess, LinkAccess, CodeAccess], - newConvAccessRoles = Just (Set.fromList [TeamMemberAccessRole, GuestAccessRole]), - newConvTeam = Nothing, - newConvMessageTimer = Nothing, - newConvReceiptMode = Nothing, - newConvUsersRole = - fromJust - ( parseRoleName - "y3otpiwu615lvvccxsq0315jj75jquw01flhtuf49t6mzfurvwe3_sh51f4s257e2x47zo85rif_xyiyfldpan3g4r6zr35rbwnzm0k" - ) - } - ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConv_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConv_user.hs new file mode 100644 index 00000000000..e756106180a --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewConv_user.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedLists #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Generated.NewConv_user where + +import Data.Domain (Domain (Domain)) +import Data.Id (Id (Id)) +import Data.Misc (Milliseconds (Ms, ms)) +import qualified Data.Set as Set (fromList) +import qualified Data.UUID as UUID (fromString) +import Imports +import Wire.API.Conversation +import Wire.API.Conversation.Role + +testDomain :: Domain +testDomain = Domain "testdomain.example.com" + +testObject_NewConv_user_1 :: NewConv +testObject_NewConv_user_1 = + NewConv + { newConvUsers = + [ Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")) + ], + newConvQualifiedUsers = [], + newConvName = Nothing, + newConvAccess = Set.fromList [PrivateAccess, InviteAccess], + newConvAccessRoles = Just $ Set.fromList [TeamMemberAccessRole, GuestAccessRole], + newConvTeam = + Just + ( ConvTeamInfo + { cnvTeamId = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")) + } + ), + newConvMessageTimer = Just (Ms {ms = 3320987366258987}), + newConvReceiptMode = Just (ReceiptMode {unReceiptMode = 1}), + newConvUsersRole = fromJust (parseRoleName "8tp2gs7b6") + } + +testObject_NewConv_user_3 :: NewConv +testObject_NewConv_user_3 = + NewConv + { newConvUsers = [], + newConvQualifiedUsers = [], + newConvName = Nothing, + newConvAccess = Set.fromList [InviteAccess, LinkAccess, CodeAccess], + newConvAccessRoles = Just (Set.fromList [TeamMemberAccessRole, GuestAccessRole]), + newConvTeam = Nothing, + newConvMessageTimer = Nothing, + newConvReceiptMode = Nothing, + newConvUsersRole = + fromJust + ( parseRoleName + "y3otpiwu615lvvccxsq0315jj75jquw01flhtuf49t6mzfurvwe3_sh51f4s257e2x47zo85rif_xyiyfldpan3g4r6zr35rbwnzm0k" + ) + } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs index cd03d982624..3bdf75b2bea 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversationList_team.hs @@ -21,464 +21,464 @@ module Test.Wire.API.Golden.Generated.TeamConversationList_team where import Data.Id (Id (Id)) import qualified Data.UUID as UUID (fromString) -import Imports (Bool (False, True), fromJust) +import Imports import Wire.API.Team.Conversation (TeamConversationList, newTeamConversation, newTeamConversationList) testObject_TeamConversationList_team_1 :: TeamConversationList testObject_TeamConversationList_team_1 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0018-0000-00260000002b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0063-0000-006900000013")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-003c-0000-00440000000e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-003a-0000-006100000049")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-0003-0000-005a00000075")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0018-0000-00250000007c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0020-0000-001a00000073")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-006a-0000-005f00000003")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0021-0000-00330000005b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-0011-0000-002a00000004")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000031-0000-0018-0000-00060000001a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-000e-0000-004300000028")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-007f-0000-003600000031")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000066-0000-0053-0000-006a00000034")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0071-0000-001b00000057")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000032-0000-0035-0000-00210000003b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-000d-0000-002100000067")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0018-0000-00260000002b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0063-0000-006900000013"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-003c-0000-00440000000e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-003a-0000-006100000049"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-0003-0000-005a00000075"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0018-0000-00250000007c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0020-0000-001a00000073"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-006a-0000-005f00000003"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0021-0000-00330000005b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-0011-0000-002a00000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000031-0000-0018-0000-00060000001a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-000e-0000-004300000028"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-007f-0000-003600000031"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000066-0000-0053-0000-006a00000034"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0071-0000-001b00000057"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000032-0000-0035-0000-00210000003b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-000d-0000-002100000067"))))) ] ) testObject_TeamConversationList_team_2 :: TeamConversationList testObject_TeamConversationList_team_2 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0045-0000-007d00000023")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-0080-0000-00550000001b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0053-0000-004600000056")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-003c-0000-003200000071")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-002f-0000-007a0000007f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000a-0000-0027-0000-004e0000005f")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0026-0000-000000000054")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-007e-0000-001600000035")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002c-0000-0057-0000-007e00000070")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0053-0000-005f00000006")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-005c-0000-00050000006b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-0061-0000-004a00000024")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005a-0000-007b-0000-000800000033")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000027-0000-0043-0000-006800000068")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0018-0000-003f00000001")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000014-0000-0066-0000-00440000001b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0071-0000-007f0000001b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-004d-0000-005000000080")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-003e-0000-00140000006e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-005c-0000-001e0000000d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004d-0000-0021-0000-00360000000e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-003f-0000-003700000065")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-003e-0000-000300000051")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0025-0000-00030000003b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-0069-0000-005000000035")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-006b-0000-00260000004e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001c-0000-001c-0000-00530000000c")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0045-0000-007d00000023"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-0080-0000-00550000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0053-0000-004600000056"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-003c-0000-003200000071"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-002f-0000-007a0000007f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000a-0000-0027-0000-004e0000005f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0026-0000-000000000054"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-007e-0000-001600000035"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002c-0000-0057-0000-007e00000070"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0053-0000-005f00000006"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-005c-0000-00050000006b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-0061-0000-004a00000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005a-0000-007b-0000-000800000033"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000027-0000-0043-0000-006800000068"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0018-0000-003f00000001"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000014-0000-0066-0000-00440000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0071-0000-007f0000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-004d-0000-005000000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-003e-0000-00140000006e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-005c-0000-001e0000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004d-0000-0021-0000-00360000000e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-003f-0000-003700000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-003e-0000-000300000051"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0025-0000-00030000003b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-0069-0000-005000000035"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-006b-0000-00260000004e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001c-0000-001c-0000-00530000000c"))))) ] ) testObject_TeamConversationList_team_3 :: TeamConversationList testObject_TeamConversationList_team_3 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0026-0000-005600000014")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0042-0000-002c00000074")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-006d-0000-006100000027")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000079-0000-0024-0000-004600000011")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-0005-0000-003800000008")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-005e-0000-00200000001a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0038-0000-001b00000065")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0045-0000-004500000078")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001e-0000-0036-0000-006400000045")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-0066-0000-000500000075")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0026-0000-005600000014"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0042-0000-002c00000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-006d-0000-006100000027"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000079-0000-0024-0000-004600000011"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-0005-0000-003800000008"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-005e-0000-00200000001a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0038-0000-001b00000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0045-0000-004500000078"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001e-0000-0036-0000-006400000045"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-0066-0000-000500000075"))))) ] ) testObject_TeamConversationList_team_4 :: TeamConversationList testObject_TeamConversationList_team_4 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000076-0000-0038-0000-003c00000043")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-001f-0000-005800000080")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0070-0000-006f00000077")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0031-0000-004700000053")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0041-0000-001600000013")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007b-0000-003c-0000-004800000063")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-0009-0000-004c00000009")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-007b-0000-00460000007f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-002e-0000-001000000064")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003d-0000-002a-0000-00290000007b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0033-0000-00780000005e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-007f-0000-001d0000002c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000017-0000-0079-0000-001c00000066")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0024-0000-001000000074")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000010-0000-000c-0000-001700000046")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0049-0000-003100000022")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000011-0000-0051-0000-003300000061")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0077-0000-004c00000022")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007e-0000-0048-0000-007200000056")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-0007-0000-00190000004f")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0048-0000-001c0000007e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004c-0000-0071-0000-007a00000071")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0002-0000-002000000068")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-0037-0000-005e00000027")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-006d-0000-004d00000024")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004a-0000-0038-0000-001e0000003b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-001a-0000-004a0000001a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0070-0000-007000000019")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0013-0000-004a00000018")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000076-0000-0038-0000-003c00000043"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-001f-0000-005800000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0070-0000-006f00000077"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0031-0000-004700000053"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0041-0000-001600000013"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007b-0000-003c-0000-004800000063"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-0009-0000-004c00000009"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-007b-0000-00460000007f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-002e-0000-001000000064"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003d-0000-002a-0000-00290000007b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0033-0000-00780000005e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-007f-0000-001d0000002c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000017-0000-0079-0000-001c00000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0024-0000-001000000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000010-0000-000c-0000-001700000046"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0049-0000-003100000022"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000011-0000-0051-0000-003300000061"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0077-0000-004c00000022"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007e-0000-0048-0000-007200000056"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-0007-0000-00190000004f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0048-0000-001c0000007e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004c-0000-0071-0000-007a00000071"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0002-0000-002000000068"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-0037-0000-005e00000027"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-006d-0000-004d00000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004a-0000-0038-0000-001e0000003b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-001a-0000-004a0000001a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0070-0000-007000000019"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0013-0000-004a00000018"))))) ] ) testObject_TeamConversationList_team_5 :: TeamConversationList testObject_TeamConversationList_team_5 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-005a-0000-00250000000d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-005c-0000-006e00000014")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000017-0000-005d-0000-003b00000023")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-005a-0000-00250000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-005c-0000-006e00000014"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000017-0000-005d-0000-003b00000023"))))) ] ) testObject_TeamConversationList_team_6 :: TeamConversationList testObject_TeamConversationList_team_6 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000007c-0000-007f-0000-00730000000d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-0037-0000-000b00000016")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-0064-0000-003900000002")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-001f-0000-00350000001b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-007b-0000-00770000003e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0068-0000-007700000068")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000061-0000-000b-0000-00170000005c")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005c-0000-0001-0000-004e00000003")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-002b-0000-002d00000022")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000007c-0000-007f-0000-00730000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-0037-0000-000b00000016"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-0064-0000-003900000002"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-001f-0000-00350000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-007b-0000-00770000003e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0068-0000-007700000068"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000061-0000-000b-0000-00170000005c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005c-0000-0001-0000-004e00000003"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-002b-0000-002d00000022"))))) ] ) testObject_TeamConversationList_team_7 :: TeamConversationList testObject_TeamConversationList_team_7 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0010-0000-002700000004")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-0036-0000-000e00000080")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0068-0000-000000000006")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000024-0000-0018-0000-005d00000050")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000040-0000-0001-0000-00670000002e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-0016-0000-004300000052")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007b-0000-0073-0000-002700000048")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-0048-0000-002500000015")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000055-0000-007c-0000-001500000051")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0010-0000-002700000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-0036-0000-000e00000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0068-0000-000000000006"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000024-0000-0018-0000-005d00000050"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000040-0000-0001-0000-00670000002e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-0016-0000-004300000052"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007b-0000-0073-0000-002700000048"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-0048-0000-002500000015"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000055-0000-007c-0000-001500000051"))))) ] ) testObject_TeamConversationList_team_8 :: TeamConversationList testObject_TeamConversationList_team_8 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000026-0000-0066-0000-00170000007b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0015-0000-001f00000071")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000063-0000-0049-0000-004100000018")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-002b-0000-000300000001")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000035-0000-006e-0000-002f00000057")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-0064-0000-003b0000002d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0009-0000-00630000001d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-004d-0000-001b00000036")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0073-0000-007d00000010")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-0007-0000-00690000002d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000043-0000-001f-0000-007500000002")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-0012-0000-006200000028")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000019-0000-003a-0000-002300000023")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-006d-0000-00610000000c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0048-0000-003200000004")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0024-0000-002000000015")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000027-0000-0003-0000-007600000028")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-005d-0000-00100000005d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000071-0000-0075-0000-000a0000002c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0071-0000-004d00000010")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-003f-0000-005a00000026")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-0069-0000-00500000000a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-000b-0000-003000000046")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-005f-0000-007f0000001b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0050-0000-002100000074")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000077-0000-0063-0000-00360000000e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-0011-0000-001200000005")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004a-0000-0037-0000-003000000034")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0043-0000-006700000030")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-003e-0000-008000000051")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000026-0000-0066-0000-00170000007b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-0015-0000-001f00000071"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000063-0000-0049-0000-004100000018"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-002b-0000-000300000001"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000035-0000-006e-0000-002f00000057"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-0064-0000-003b0000002d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0009-0000-00630000001d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-004d-0000-001b00000036"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0073-0000-007d00000010"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-0007-0000-00690000002d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000043-0000-001f-0000-007500000002"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-0012-0000-006200000028"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000019-0000-003a-0000-002300000023"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000050-0000-006d-0000-00610000000c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0048-0000-003200000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0024-0000-002000000015"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000027-0000-0003-0000-007600000028"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-005d-0000-00100000005d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000071-0000-0075-0000-000a0000002c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0071-0000-004d00000010"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-003f-0000-005a00000026"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-0069-0000-00500000000a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-000b-0000-003000000046"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-005f-0000-007f0000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0050-0000-002100000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000077-0000-0063-0000-00360000000e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-0011-0000-001200000005"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004a-0000-0037-0000-003000000034"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0043-0000-006700000030"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-003e-0000-008000000051"))))) ] ) testObject_TeamConversationList_team_9 :: TeamConversationList testObject_TeamConversationList_team_9 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-007c-0000-002a0000005f")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0009-0000-006500000038")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-000a-0000-004e00000039")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000062-0000-001e-0000-004c00000058")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0021-0000-00670000000a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004f-0000-0063-0000-004a0000004b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-0017-0000-006300000067")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0070-0000-002e0000000a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0080-0000-006000000025")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-0040-0000-001700000066")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0045-0000-00610000006c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000001-0000-0042-0000-005b00000057")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-0032-0000-000000000069")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0022-0000-00370000005b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0068-0000-00150000001f")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003a-0000-0067-0000-00060000003e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001e-0000-0043-0000-002800000065")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-001f-0000-001700000006")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0024-0000-004900000037")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000005-0000-0019-0000-00670000005c")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0003-0000-00520000004c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-002f-0000-002b0000006f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-002e-0000-004f0000005e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0023-0000-00560000001b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000066-0000-007b-0000-00160000005c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0008-0000-006b00000049")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0020-0000-005000000006")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-0038-0000-003400000074")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-006f-0000-00370000002e")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-007c-0000-002a0000005f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0009-0000-006500000038"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-000a-0000-004e00000039"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000062-0000-001e-0000-004c00000058"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0021-0000-00670000000a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004f-0000-0063-0000-004a0000004b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-0017-0000-006300000067"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0070-0000-002e0000000a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0080-0000-006000000025"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-0040-0000-001700000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0045-0000-00610000006c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000001-0000-0042-0000-005b00000057"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-0032-0000-000000000069"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0022-0000-00370000005b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0068-0000-00150000001f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003a-0000-0067-0000-00060000003e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001e-0000-0043-0000-002800000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-001f-0000-001700000006"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0024-0000-004900000037"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000005-0000-0019-0000-00670000005c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000029-0000-0003-0000-00520000004c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-002f-0000-002b0000006f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-002e-0000-004f0000005e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0023-0000-00560000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000066-0000-007b-0000-00160000005c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0008-0000-006b00000049"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0020-0000-005000000006"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-0038-0000-003400000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-006f-0000-00370000002e"))))) ] ) testObject_TeamConversationList_team_10 :: TeamConversationList testObject_TeamConversationList_team_10 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-007d-0000-001400000009")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0057-0000-00190000004a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0030-0000-006b00000005")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007c-0000-0065-0000-001100000066")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0039-0000-000400000071")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0053-0000-007f0000003c")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-007d-0000-001400000009"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0057-0000-00190000004a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0030-0000-006b00000005"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007c-0000-0065-0000-001100000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0039-0000-000400000071"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003e-0000-0053-0000-007f0000003c"))))) ] ) testObject_TeamConversationList_team_11 :: TeamConversationList testObject_TeamConversationList_team_11 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0030-0000-006700000067")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-006a-0000-00220000007c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000055-0000-004f-0000-005500000047")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-003d-0000-006500000060")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0030-0000-006700000067"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-006a-0000-00220000007c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000055-0000-004f-0000-005500000047"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000064-0000-003d-0000-006500000060"))))) ] ) testObject_TeamConversationList_team_12 :: TeamConversationList testObject_TeamConversationList_team_12 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0042-0000-00120000004e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000010-0000-002b-0000-002600000066")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0054-0000-005300000004")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000e-0000-006f-0000-000c00000038")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0021-0000-005500000008")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-007a-0000-00230000002d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000078-0000-000e-0000-004300000065")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0003-0000-000500000011")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000043-0000-0032-0000-005200000069")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000c-0000-0003-0000-001400000018")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0020-0000-005200000053")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-007b-0000-00670000000b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-005b-0000-00250000000c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-005b-0000-004200000001")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0073-0000-003d00000006")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0038-0000-006600000048")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-0022-0000-00800000006f")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005e-0000-0023-0000-000700000012")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0071-0000-005f00000070")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0024-0000-003400000018")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000054-0000-0056-0000-007000000058")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0011-0000-001500000007")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0042-0000-00120000004e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000010-0000-002b-0000-002600000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0054-0000-005300000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000e-0000-006f-0000-000c00000038"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0021-0000-005500000008"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-007a-0000-00230000002d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000078-0000-000e-0000-004300000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0003-0000-000500000011"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000043-0000-0032-0000-005200000069"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000c-0000-0003-0000-001400000018"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0020-0000-005200000053"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-007b-0000-00670000000b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-005b-0000-00250000000c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-005b-0000-004200000001"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-0073-0000-003d00000006"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0038-0000-006600000048"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-0022-0000-00800000006f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005e-0000-0023-0000-000700000012"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0071-0000-005f00000070"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0024-0000-003400000018"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000054-0000-0056-0000-007000000058"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0011-0000-001500000007"))))) ] ) testObject_TeamConversationList_team_13 :: TeamConversationList testObject_TeamConversationList_team_13 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0043-0000-007f00000048")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-005f-0000-000a00000024")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0046-0000-003800000023")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-006b-0000-002000000068")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000041-0000-0000-0000-007000000005")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0075-0000-00200000007a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0023-0000-001a00000022")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000035-0000-004f-0000-000400000072")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-001a-0000-00680000004d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0037-0000-00020000000f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0040-0000-005b0000001c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0074-0000-007b00000019")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0025-0000-006900000014")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000063-0000-0000-0000-002100000043")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0018-0000-004d0000003a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-004e-0000-002700000075")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0014-0000-000100000040")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0004-0000-00280000000a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0012-0000-00150000006e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-003c-0000-006400000055")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-003d-0000-003c00000003")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-0043-0000-007f00000048"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-005f-0000-000a00000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0046-0000-003800000023"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-006b-0000-002000000068"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000041-0000-0000-0000-007000000005"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0075-0000-00200000007a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000038-0000-0023-0000-001a00000022"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000035-0000-004f-0000-000400000072"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-001a-0000-00680000004d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0037-0000-00020000000f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0040-0000-005b0000001c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0074-0000-007b00000019"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0025-0000-006900000014"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000063-0000-0000-0000-002100000043"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0018-0000-004d0000003a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-004e-0000-002700000075"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0014-0000-000100000040"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0004-0000-00280000000a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0012-0000-00150000006e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-003c-0000-006400000055"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-003d-0000-003c00000003"))))) ] ) testObject_TeamConversationList_team_14 :: TeamConversationList testObject_TeamConversationList_team_14 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-005c-0000-000e00000044")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0061-0000-005d00000066")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000011-0000-0009-0000-006c00000065")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0026-0000-001e00000007")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-005e-0000-007300000058")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-006a-0000-004100000045")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-0027-0000-00080000000d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000024-0000-0028-0000-007700000051")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-001c-0000-004c00000073")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-002f-0000-003400000023")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0057-0000-00580000006a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0016-0000-002500000036")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-006c-0000-00420000003d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-005d-0000-004600000002")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-002b-0000-005800000035")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-0007-0000-005800000075")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-002b-0000-000100000080")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000013-0000-001b-0000-003200000000")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0013-0000-004d0000006e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0041-0000-007200000079")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-005c-0000-000e00000044"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0061-0000-005d00000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000011-0000-0009-0000-006c00000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0026-0000-001e00000007"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-005e-0000-007300000058"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-006a-0000-004100000045"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006d-0000-0027-0000-00080000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000024-0000-0028-0000-007700000051"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-001c-0000-004c00000073"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006f-0000-002f-0000-003400000023"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0057-0000-00580000006a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0016-0000-002500000036"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-006c-0000-00420000003d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-005d-0000-004600000002"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006a-0000-002b-0000-005800000035"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006e-0000-0007-0000-005800000075"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-002b-0000-000100000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000013-0000-001b-0000-003200000000"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000006-0000-0013-0000-004d0000006e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0041-0000-007200000079"))))) ] ) testObject_TeamConversationList_team_15 :: TeamConversationList testObject_TeamConversationList_team_15 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0013-0000-006400000036")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-007e-0000-002f00000057")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-006e-0000-006800000040")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-005a-0000-000e00000024")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000069-0000-007c-0000-00550000002f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0041-0000-000e0000003e")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0013-0000-006400000036"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-007e-0000-002f00000057"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000002-0000-006e-0000-006800000040"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-005a-0000-000e00000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000069-0000-007c-0000-00550000002f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000068-0000-0041-0000-000e0000003e"))))) ] ) testObject_TeamConversationList_team_16 :: TeamConversationList testObject_TeamConversationList_team_16 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0066-0000-003800000061")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0007-0000-003f0000001d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000045-0000-0038-0000-005f00000072")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000032-0000-0069-0000-005b00000011")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0073-0000-00280000005d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0068-0000-004f00000042")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0056-0000-00780000000f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0064-0000-001b00000024")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0052-0000-004000000072")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-0080-0000-005100000029")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000079-0000-0018-0000-000600000047")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0029-0000-003100000043")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-002e-0000-00220000005b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-004d-0000-001700000055")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000006c-0000-0028-0000-002100000076")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-0052-0000-003300000080")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004c-0000-005f-0000-00390000004d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-004b-0000-00440000003e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-007a-0000-003d00000036")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-0058-0000-003700000019")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0011-0000-007c00000011")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0057-0000-00630000002b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000051-0000-0018-0000-00590000007a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-0011-0000-002100000014")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000060-0000-0003-0000-00490000001b")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000042-0000-006e-0000-001e0000001a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0065-0000-004b00000045")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0066-0000-003800000061"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-0007-0000-003f0000001d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000045-0000-0038-0000-005f00000072"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000032-0000-0069-0000-005b00000011"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0073-0000-00280000005d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000046-0000-0068-0000-004f00000042"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0056-0000-00780000000f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006b-0000-0064-0000-001b00000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-0052-0000-004000000072"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-0080-0000-005100000029"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000079-0000-0018-0000-000600000047"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0029-0000-003100000043"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000048-0000-002e-0000-00220000005b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-004d-0000-001700000055"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000006c-0000-0028-0000-002100000076"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000033-0000-0052-0000-003300000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004c-0000-005f-0000-00390000004d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-004b-0000-00440000003e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000052-0000-007a-0000-003d00000036"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000018-0000-0058-0000-003700000019"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000034-0000-0011-0000-007c00000011"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000056-0000-0057-0000-00630000002b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000051-0000-0018-0000-00590000007a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-0011-0000-002100000014"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000060-0000-0003-0000-00490000001b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000042-0000-006e-0000-001e0000001a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0065-0000-004b00000045"))))) ] ) testObject_TeamConversationList_team_17 :: TeamConversationList testObject_TeamConversationList_team_17 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0070-0000-007f0000001c")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0017-0000-002a00000076")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-004f-0000-00710000002d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-0037-0000-004d0000007b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0071-0000-000800000015")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0062-0000-002900000024")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000072-0000-0027-0000-001300000046")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0034-0000-00720000000f")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-005d-0000-003300000024")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-000b-0000-00160000000d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000022-0000-0042-0000-003400000043")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000020-0000-0033-0000-00780000006b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0067-0000-005f00000042")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0079-0000-00630000007e")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0045-0000-003900000053")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-003e-0000-003d00000000")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-0052-0000-000500000034")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-002d-0000-00030000005c")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0067-0000-007400000054")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0075-0000-001200000054")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-003d-0000-000700000080")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0006-0000-00010000001a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0073-0000-002000000058")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-0015-0000-005e0000006e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0019-0000-00510000005a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-0074-0000-007000000021")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0040-0000-006f00000075")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000053-0000-0070-0000-007f0000001c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0017-0000-002a00000076"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-004f-0000-00710000002d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000067-0000-0037-0000-004d0000007b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000004-0000-0071-0000-000800000015"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0062-0000-002900000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000072-0000-0027-0000-001300000046"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0034-0000-00720000000f"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-005d-0000-003300000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-000b-0000-00160000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000022-0000-0042-0000-003400000043"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000020-0000-0033-0000-00780000006b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000074-0000-0067-0000-005f00000042"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0079-0000-00630000007e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-0045-0000-003900000053"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-003e-0000-003d00000000"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000039-0000-0052-0000-000500000034"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004e-0000-002d-0000-00030000005c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000036-0000-0067-0000-007400000054"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0075-0000-001200000054"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-003d-0000-000700000080"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0006-0000-00010000001a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000012-0000-0073-0000-002000000058"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-0015-0000-005e0000006e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000047-0000-0019-0000-00510000005a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000004b-0000-0074-0000-007000000021"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007a-0000-0040-0000-006f00000075"))))) ] ) testObject_TeamConversationList_team_18 :: TeamConversationList testObject_TeamConversationList_team_18 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-000d-0000-007600000068")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0033-0000-006400000019")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0075-0000-00400000004e")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000062-0000-0073-0000-002a00000051")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-004b-0000-005c00000064")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-001a-0000-00430000003d")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0005-0000-004f00000031")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0043-0000-001a0000000c")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-001c-0000-003a0000002b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001c-0000-007b-0000-00170000000a")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-0073-0000-000000000074")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0069-0000-00490000002d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-0012-0000-000400000000")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-004e-0000-003800000057")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-0022-0000-002000000004")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-0011-0000-00260000004a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002c-0000-007a-0000-00340000006e")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000049-0000-000d-0000-007600000068"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0033-0000-006400000019"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000080-0000-0075-0000-00400000004e"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000062-0000-0073-0000-002a00000051"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-004b-0000-005c00000064"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-001a-0000-00430000003d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-0005-0000-004f00000031"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0043-0000-001a0000000c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-001c-0000-003a0000002b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001c-0000-007b-0000-00170000000a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000073-0000-0073-0000-000000000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0069-0000-00490000002d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-0012-0000-000400000000"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000016-0000-004e-0000-003800000057"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000008-0000-0022-0000-002000000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-0011-0000-00260000004a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002c-0000-007a-0000-00340000006e"))))) ] ) testObject_TeamConversationList_team_19 :: TeamConversationList testObject_TeamConversationList_team_19 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0041-0000-007b00000060")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003f-0000-0059-0000-000700000073")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0056-0000-007e00000066")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002b-0000-000b-0000-007a00000065")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000071-0000-003a-0000-001b00000027")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-004f-0000-008000000008")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-000d-0000-00510000005a")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000045-0000-006e-0000-004200000072")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001b-0000-003b-0000-007900000004")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0077-0000-006400000054")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-005e-0000-003e00000012")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-000c-0000-00370000003b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000031-0000-0010-0000-006500000077")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-004b-0000-00460000007b")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000005-0000-0040-0000-006400000024")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000042-0000-005b-0000-002d00000031")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0067-0000-00610000006d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0036-0000-00770000000d")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-0042-0000-003700000054")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0001-0000-000700000015")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-003c-0000-003b00000000")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0049-0000-00720000006c")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0021-0000-004c00000055")))) (True)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-002e-0000-00140000003d")))) (False)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000000-0000-0041-0000-007b00000060"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003f-0000-0059-0000-000700000073"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0056-0000-007e00000066"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002b-0000-000b-0000-007a00000065"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000071-0000-003a-0000-001b00000027"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000070-0000-004f-0000-008000000008"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003c-0000-000d-0000-00510000005a"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000045-0000-006e-0000-004200000072"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001b-0000-003b-0000-007900000004"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0077-0000-006400000054"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001a-0000-005e-0000-003e00000012"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000057-0000-000c-0000-00370000003b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000031-0000-0010-0000-006500000077"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000028-0000-004b-0000-00460000007b"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000005-0000-0040-0000-006400000024"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000042-0000-005b-0000-002d00000031"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0067-0000-00610000006d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007f-0000-0036-0000-00770000000d"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000058-0000-0042-0000-003700000054"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002a-0000-0001-0000-000700000015"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002f-0000-003c-0000-003b00000000"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "00000065-0000-0049-0000-00720000006c"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000f-0000-0021-0000-004c00000055"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-002e-0000-00140000003d"))))) ] ) testObject_TeamConversationList_team_20 :: TeamConversationList testObject_TeamConversationList_team_20 = ( newTeamConversationList - [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0017-0000-007500000074")))) (False)), - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-0055-0000-003f00000059")))) (True)) + [ (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0017-0000-007500000074"))))), + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003b-0000-0055-0000-003f00000059"))))) ] ) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs index 2e56b99a4d6..8f519c4f5f1 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TeamConversation_team.hs @@ -21,85 +21,85 @@ module Test.Wire.API.Golden.Generated.TeamConversation_team where import Data.Id (Id (Id)) import qualified Data.UUID as UUID (fromString) -import Imports (Bool (False, True), fromJust) +import Imports import Wire.API.Team.Conversation (TeamConversation, newTeamConversation) testObject_TeamConversation_team_1 :: TeamConversation testObject_TeamConversation_team_1 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000054-0000-0032-0000-001d0000003e")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000054-0000-0032-0000-001d0000003e"))))) testObject_TeamConversation_team_2 :: TeamConversation testObject_TeamConversation_team_2 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-0059-0000-00390000004c")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000021-0000-0059-0000-00390000004c"))))) testObject_TeamConversation_team_3 :: TeamConversation testObject_TeamConversation_team_3 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000020-0000-0022-0000-00550000003b")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000020-0000-0022-0000-00550000003b"))))) testObject_TeamConversation_team_4 :: TeamConversation testObject_TeamConversation_team_4 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0034-0000-004600000023")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002d-0000-0034-0000-004600000023"))))) testObject_TeamConversation_team_5 :: TeamConversation testObject_TeamConversation_team_5 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-005d-0000-003d00000076")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-005d-0000-003d00000076"))))) testObject_TeamConversation_team_6 :: TeamConversation testObject_TeamConversation_team_6 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000a-0000-0013-0000-00420000002e")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000a-0000-0013-0000-00420000002e"))))) testObject_TeamConversation_team_7 :: TeamConversation testObject_TeamConversation_team_7 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0080-0000-002800000080")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005d-0000-0080-0000-002800000080"))))) testObject_TeamConversation_team_8 :: TeamConversation testObject_TeamConversation_team_8 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-006d-0000-003700000042")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000002e-0000-006d-0000-003700000042"))))) testObject_TeamConversation_team_9 :: TeamConversation testObject_TeamConversation_team_9 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-001b-0000-006800000047")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000000d-0000-001b-0000-006800000047"))))) testObject_TeamConversation_team_10 :: TeamConversation testObject_TeamConversation_team_10 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0024-0000-003200000067")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000023-0000-0024-0000-003200000067"))))) testObject_TeamConversation_team_11 :: TeamConversation testObject_TeamConversation_team_11 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0041-0000-002600000041")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000003-0000-0041-0000-002600000041"))))) testObject_TeamConversation_team_12 :: TeamConversation testObject_TeamConversation_team_12 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-0049-0000-001f00000034")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000007d-0000-0049-0000-001f00000034"))))) testObject_TeamConversation_team_13 :: TeamConversation testObject_TeamConversation_team_13 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000025-0000-003c-0000-003d00000032")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000025-0000-003c-0000-003d00000032"))))) testObject_TeamConversation_team_14 :: TeamConversation testObject_TeamConversation_team_14 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0065-0000-002a00000060")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005b-0000-0065-0000-002a00000060"))))) testObject_TeamConversation_team_15 :: TeamConversation testObject_TeamConversation_team_15 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000001f-0000-0037-0000-005a0000004d")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000001f-0000-0037-0000-005a0000004d"))))) testObject_TeamConversation_team_16 :: TeamConversation testObject_TeamConversation_team_16 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-000a-0000-007f0000001d")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000044-0000-000a-0000-007f0000001d"))))) testObject_TeamConversation_team_17 :: TeamConversation testObject_TeamConversation_team_17 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0060-0000-005c00000049")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000009-0000-0060-0000-005c00000049"))))) testObject_TeamConversation_team_18 :: TeamConversation testObject_TeamConversation_team_18 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-0051-0000-003d00000026")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000005f-0000-0051-0000-003d00000026"))))) testObject_TeamConversation_team_19 :: TeamConversation testObject_TeamConversation_team_19 = - (newTeamConversation ((Id (fromJust (UUID.fromString "0000003d-0000-0025-0000-00170000002e")))) (True)) + (newTeamConversation ((Id (fromJust (UUID.fromString "0000003d-0000-0025-0000-00170000002e"))))) testObject_TeamConversation_team_20 :: TeamConversation testObject_TeamConversation_team_20 = - (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0053-0000-001500000035")))) (False)) + (newTeamConversation ((Id (fromJust (UUID.fromString "00000007-0000-0053-0000-001500000035"))))) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs index 1ee865a4440..88ed0c1c336 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generator.hs @@ -149,8 +149,6 @@ generateTestModule = do generateBindingModule @Connection.UserConnectionList "user" ref generateBindingModule @Connection.ConnectionUpdate "user" ref generateBindingModule @Conversation.Conversation "user" ref - generateBindingModule @Conversation.NewConvUnmanaged "user" ref - generateBindingModule @Conversation.NewConvManaged "user" ref generateBindingModule @(Conversation.ConversationList ConvId) "user" ref generateBindingModule @(Conversation.ConversationList Conversation.Conversation) "user" ref generateBindingModule @Conversation.Access "user" ref diff --git a/libs/wire-api/test/golden/testObject_NewConvManaged_user_1.json b/libs/wire-api/test/golden/testObject_NewConvManaged_user_1.json deleted file mode 100644 index 7772dcde548..00000000000 --- a/libs/wire-api/test/golden/testObject_NewConvManaged_user_1.json +++ /dev/null @@ -1,17 +0,0 @@ -{ - "access": [], - "access_role": "non_activated", - "access_role_v2": [ - "team_member", - "guest" - ], - "conversation_role": "37q9eeybycp5972td4oo9_r7y16eh6n67z5spda8sffy8qv", - "message_timer": 193643728192048, - "qualified_users": [], - "receipt_mode": 4, - "team": { - "managed": true, - "teamid": "00000001-0000-0001-0000-000200000000" - }, - "users": [] -} diff --git a/libs/wire-api/test/golden/testObject_NewConvUnmanaged_user_1.json b/libs/wire-api/test/golden/testObject_NewConv_user_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_NewConvUnmanaged_user_1.json rename to libs/wire-api/test/golden/testObject_NewConv_user_1.json diff --git a/libs/wire-api/test/golden/testObject_NewConvUnmanaged_user_3.json b/libs/wire-api/test/golden/testObject_NewConv_user_3.json similarity index 100% rename from libs/wire-api/test/golden/testObject_NewConvUnmanaged_user_3.json rename to libs/wire-api/test/golden/testObject_NewConv_user_3.json diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_1.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_1.json index 41110defa64..3248c22295b 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_1.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_1.json @@ -2,7 +2,7 @@ "conversations": [ { "conversation": "00000012-0000-0018-0000-00260000002b", - "managed": true + "managed": false }, { "conversation": "0000002d-0000-0063-0000-006900000013", @@ -18,11 +18,11 @@ }, { "conversation": "0000005f-0000-0003-0000-005a00000075", - "managed": true + "managed": false }, { "conversation": "0000007f-0000-0018-0000-00250000007c", - "managed": true + "managed": false }, { "conversation": "0000006a-0000-0020-0000-001a00000073", @@ -30,11 +30,11 @@ }, { "conversation": "0000002e-0000-006a-0000-005f00000003", - "managed": true + "managed": false }, { "conversation": "00000034-0000-0021-0000-00330000005b", - "managed": true + "managed": false }, { "conversation": "00000048-0000-0011-0000-002a00000004", @@ -46,7 +46,7 @@ }, { "conversation": "00000056-0000-000e-0000-004300000028", - "managed": true + "managed": false }, { "conversation": "00000067-0000-007f-0000-003600000031", @@ -58,11 +58,11 @@ }, { "conversation": "0000000f-0000-0071-0000-001b00000057", - "managed": true + "managed": false }, { "conversation": "00000032-0000-0035-0000-00210000003b", - "managed": true + "managed": false }, { "conversation": "00000004-0000-000d-0000-002100000067", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_10.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_10.json index cad7fd3c3a0..5a7f04fd53d 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_10.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_10.json @@ -2,11 +2,11 @@ "conversations": [ { "conversation": "00000070-0000-007d-0000-001400000009", - "managed": true + "managed": false }, { "conversation": "00000065-0000-0057-0000-00190000004a", - "managed": true + "managed": false }, { "conversation": "00000049-0000-0030-0000-006b00000005", @@ -14,11 +14,11 @@ }, { "conversation": "0000007c-0000-0065-0000-001100000066", - "managed": true + "managed": false }, { "conversation": "00000057-0000-0039-0000-000400000071", - "managed": true + "managed": false }, { "conversation": "0000003e-0000-0053-0000-007f0000003c", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_11.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_11.json index ec81eabb4c9..cd3dde1b948 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_11.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_11.json @@ -2,15 +2,15 @@ "conversations": [ { "conversation": "00000038-0000-0030-0000-006700000067", - "managed": true + "managed": false }, { "conversation": "00000000-0000-006a-0000-00220000007c", - "managed": true + "managed": false }, { "conversation": "00000055-0000-004f-0000-005500000047", - "managed": true + "managed": false }, { "conversation": "00000064-0000-003d-0000-006500000060", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_12.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_12.json index 656f2f172bb..1ce03386ffd 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_12.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_12.json @@ -14,15 +14,15 @@ }, { "conversation": "0000000e-0000-006f-0000-000c00000038", - "managed": true + "managed": false }, { "conversation": "00000038-0000-0021-0000-005500000008", - "managed": true + "managed": false }, { "conversation": "0000005b-0000-007a-0000-00230000002d", - "managed": true + "managed": false }, { "conversation": "00000078-0000-000e-0000-004300000065", @@ -30,7 +30,7 @@ }, { "conversation": "00000036-0000-0003-0000-000500000011", - "managed": true + "managed": false }, { "conversation": "00000043-0000-0032-0000-005200000069", @@ -50,7 +50,7 @@ }, { "conversation": "0000001a-0000-005b-0000-00250000000c", - "managed": true + "managed": false }, { "conversation": "0000004b-0000-005b-0000-004200000001", @@ -58,7 +58,7 @@ }, { "conversation": "00000057-0000-0073-0000-003d00000006", - "managed": true + "managed": false }, { "conversation": "00000053-0000-0038-0000-006600000048", @@ -82,7 +82,7 @@ }, { "conversation": "00000054-0000-0056-0000-007000000058", - "managed": true + "managed": false }, { "conversation": "00000046-0000-0011-0000-001500000007", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_13.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_13.json index 08c6bfd87e8..76a0c7ecc99 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_13.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_13.json @@ -2,11 +2,11 @@ "conversations": [ { "conversation": "0000006a-0000-0043-0000-007f00000048", - "managed": true + "managed": false }, { "conversation": "0000007d-0000-005f-0000-000a00000024", - "managed": true + "managed": false }, { "conversation": "0000007a-0000-0046-0000-003800000023", @@ -34,15 +34,15 @@ }, { "conversation": "00000065-0000-001a-0000-00680000004d", - "managed": true + "managed": false }, { "conversation": "0000002f-0000-0037-0000-00020000000f", - "managed": true + "managed": false }, { "conversation": "00000023-0000-0040-0000-005b0000001c", - "managed": true + "managed": false }, { "conversation": "00000000-0000-0074-0000-007b00000019", @@ -50,7 +50,7 @@ }, { "conversation": "0000004e-0000-0025-0000-006900000014", - "managed": true + "managed": false }, { "conversation": "00000063-0000-0000-0000-002100000043", @@ -62,15 +62,15 @@ }, { "conversation": "00000052-0000-004e-0000-002700000075", - "managed": true + "managed": false }, { "conversation": "00000046-0000-0014-0000-000100000040", - "managed": true + "managed": false }, { "conversation": "00000049-0000-0004-0000-00280000000a", - "managed": true + "managed": false }, { "conversation": "00000004-0000-0012-0000-00150000006e", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_14.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_14.json index bb5f5dc09f2..3c118b9fcef 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_14.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_14.json @@ -18,7 +18,7 @@ }, { "conversation": "00000023-0000-005e-0000-007300000058", - "managed": true + "managed": false }, { "conversation": "00000056-0000-006a-0000-004100000045", @@ -26,7 +26,7 @@ }, { "conversation": "0000006d-0000-0027-0000-00080000000d", - "managed": true + "managed": false }, { "conversation": "00000024-0000-0028-0000-007700000051", @@ -34,7 +34,7 @@ }, { "conversation": "00000004-0000-001c-0000-004c00000073", - "managed": true + "managed": false }, { "conversation": "0000006f-0000-002f-0000-003400000023", @@ -42,7 +42,7 @@ }, { "conversation": "0000005d-0000-0057-0000-00580000006a", - "managed": true + "managed": false }, { "conversation": "00000034-0000-0016-0000-002500000036", @@ -50,11 +50,11 @@ }, { "conversation": "00000033-0000-006c-0000-00420000003d", - "managed": true + "managed": false }, { "conversation": "00000008-0000-005d-0000-004600000002", - "managed": true + "managed": false }, { "conversation": "0000006a-0000-002b-0000-005800000035", @@ -66,7 +66,7 @@ }, { "conversation": "00000047-0000-002b-0000-000100000080", - "managed": true + "managed": false }, { "conversation": "00000013-0000-001b-0000-003200000000", @@ -74,11 +74,11 @@ }, { "conversation": "00000006-0000-0013-0000-004d0000006e", - "managed": true + "managed": false }, { "conversation": "00000074-0000-0041-0000-007200000079", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_15.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_15.json index 8eaf78dade9..05b3262d3a0 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_15.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_15.json @@ -10,7 +10,7 @@ }, { "conversation": "00000002-0000-006e-0000-006800000040", - "managed": true + "managed": false }, { "conversation": "00000080-0000-005a-0000-000e00000024", @@ -18,7 +18,7 @@ }, { "conversation": "00000069-0000-007c-0000-00550000002f", - "managed": true + "managed": false }, { "conversation": "00000068-0000-0041-0000-000e0000003e", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_16.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_16.json index 0b984a33263..04835850c9f 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_16.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_16.json @@ -6,7 +6,7 @@ }, { "conversation": "00000049-0000-0007-0000-003f0000001d", - "managed": true + "managed": false }, { "conversation": "00000045-0000-0038-0000-005f00000072", @@ -26,7 +26,7 @@ }, { "conversation": "00000003-0000-0056-0000-00780000000f", - "managed": true + "managed": false }, { "conversation": "0000006b-0000-0064-0000-001b00000024", @@ -42,7 +42,7 @@ }, { "conversation": "00000079-0000-0018-0000-000600000047", - "managed": true + "managed": false }, { "conversation": "00000009-0000-0029-0000-003100000043", @@ -58,11 +58,11 @@ }, { "conversation": "0000006c-0000-0028-0000-002100000076", - "managed": true + "managed": false }, { "conversation": "00000033-0000-0052-0000-003300000080", - "managed": true + "managed": false }, { "conversation": "0000004c-0000-005f-0000-00390000004d", @@ -70,11 +70,11 @@ }, { "conversation": "0000007a-0000-004b-0000-00440000003e", - "managed": true + "managed": false }, { "conversation": "00000052-0000-007a-0000-003d00000036", - "managed": true + "managed": false }, { "conversation": "00000018-0000-0058-0000-003700000019", @@ -94,7 +94,7 @@ }, { "conversation": "0000004b-0000-0011-0000-002100000014", - "managed": true + "managed": false }, { "conversation": "00000060-0000-0003-0000-00490000001b", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_17.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_17.json index b94c027a5d7..7361261cb69 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_17.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_17.json @@ -2,7 +2,7 @@ "conversations": [ { "conversation": "00000053-0000-0070-0000-007f0000001c", - "managed": true + "managed": false }, { "conversation": "00000036-0000-0017-0000-002a00000076", @@ -10,11 +10,11 @@ }, { "conversation": "00000065-0000-004f-0000-00710000002d", - "managed": true + "managed": false }, { "conversation": "00000067-0000-0037-0000-004d0000007b", - "managed": true + "managed": false }, { "conversation": "00000004-0000-0071-0000-000800000015", @@ -22,39 +22,39 @@ }, { "conversation": "00000047-0000-0062-0000-002900000024", - "managed": true + "managed": false }, { "conversation": "00000072-0000-0027-0000-001300000046", - "managed": true + "managed": false }, { "conversation": "0000000f-0000-0034-0000-00720000000f", - "managed": true + "managed": false }, { "conversation": "00000021-0000-005d-0000-003300000024", - "managed": true + "managed": false }, { "conversation": "00000023-0000-000b-0000-00160000000d", - "managed": true + "managed": false }, { "conversation": "00000022-0000-0042-0000-003400000043", - "managed": true + "managed": false }, { "conversation": "00000020-0000-0033-0000-00780000006b", - "managed": true + "managed": false }, { "conversation": "00000074-0000-0067-0000-005f00000042", - "managed": true + "managed": false }, { "conversation": "0000000f-0000-0079-0000-00630000007e", - "managed": true + "managed": false }, { "conversation": "0000001a-0000-0045-0000-003900000053", @@ -62,7 +62,7 @@ }, { "conversation": "00000000-0000-003e-0000-003d00000000", - "managed": true + "managed": false }, { "conversation": "00000039-0000-0052-0000-000500000034", @@ -74,7 +74,7 @@ }, { "conversation": "00000036-0000-0067-0000-007400000054", - "managed": true + "managed": false }, { "conversation": "00000047-0000-0075-0000-001200000054", @@ -82,7 +82,7 @@ }, { "conversation": "0000002e-0000-003d-0000-000700000080", - "managed": true + "managed": false }, { "conversation": "0000005d-0000-0006-0000-00010000001a", @@ -90,7 +90,7 @@ }, { "conversation": "00000012-0000-0073-0000-002000000058", - "managed": true + "managed": false }, { "conversation": "00000073-0000-0015-0000-005e0000006e", @@ -102,11 +102,11 @@ }, { "conversation": "0000004b-0000-0074-0000-007000000021", - "managed": true + "managed": false }, { "conversation": "0000007a-0000-0040-0000-006f00000075", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_18.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_18.json index 821999129ba..2ddbcdbac5e 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_18.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_18.json @@ -2,7 +2,7 @@ "conversations": [ { "conversation": "00000049-0000-000d-0000-007600000068", - "managed": true + "managed": false }, { "conversation": "0000002a-0000-0033-0000-006400000019", @@ -22,11 +22,11 @@ }, { "conversation": "00000016-0000-001a-0000-00430000003d", - "managed": true + "managed": false }, { "conversation": "0000002f-0000-0005-0000-004f00000031", - "managed": true + "managed": false }, { "conversation": "00000000-0000-0043-0000-001a0000000c", @@ -34,15 +34,15 @@ }, { "conversation": "00000003-0000-001c-0000-003a0000002b", - "managed": true + "managed": false }, { "conversation": "0000001c-0000-007b-0000-00170000000a", - "managed": true + "managed": false }, { "conversation": "00000073-0000-0073-0000-000000000074", - "managed": true + "managed": false }, { "conversation": "0000005b-0000-0069-0000-00490000002d", @@ -50,7 +50,7 @@ }, { "conversation": "0000003c-0000-0012-0000-000400000000", - "managed": true + "managed": false }, { "conversation": "00000016-0000-004e-0000-003800000057", @@ -58,7 +58,7 @@ }, { "conversation": "00000008-0000-0022-0000-002000000004", - "managed": true + "managed": false }, { "conversation": "00000070-0000-0011-0000-00260000004a", @@ -66,7 +66,7 @@ }, { "conversation": "0000002c-0000-007a-0000-00340000006e", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_19.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_19.json index 9da6005c025..f8ff6ae2764 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_19.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_19.json @@ -2,7 +2,7 @@ "conversations": [ { "conversation": "00000000-0000-0041-0000-007b00000060", - "managed": true + "managed": false }, { "conversation": "0000003f-0000-0059-0000-000700000073", @@ -14,7 +14,7 @@ }, { "conversation": "0000002b-0000-000b-0000-007a00000065", - "managed": true + "managed": false }, { "conversation": "00000071-0000-003a-0000-001b00000027", @@ -30,11 +30,11 @@ }, { "conversation": "00000045-0000-006e-0000-004200000072", - "managed": true + "managed": false }, { "conversation": "0000001b-0000-003b-0000-007900000004", - "managed": true + "managed": false }, { "conversation": "0000002d-0000-0077-0000-006400000054", @@ -42,27 +42,27 @@ }, { "conversation": "0000001a-0000-005e-0000-003e00000012", - "managed": true + "managed": false }, { "conversation": "00000057-0000-000c-0000-00370000003b", - "managed": true + "managed": false }, { "conversation": "00000031-0000-0010-0000-006500000077", - "managed": true + "managed": false }, { "conversation": "00000028-0000-004b-0000-00460000007b", - "managed": true + "managed": false }, { "conversation": "00000005-0000-0040-0000-006400000024", - "managed": true + "managed": false }, { "conversation": "00000042-0000-005b-0000-002d00000031", - "managed": true + "managed": false }, { "conversation": "00000065-0000-0067-0000-00610000006d", @@ -74,15 +74,15 @@ }, { "conversation": "00000058-0000-0042-0000-003700000054", - "managed": true + "managed": false }, { "conversation": "0000002a-0000-0001-0000-000700000015", - "managed": true + "managed": false }, { "conversation": "0000002f-0000-003c-0000-003b00000000", - "managed": true + "managed": false }, { "conversation": "00000065-0000-0049-0000-00720000006c", @@ -90,7 +90,7 @@ }, { "conversation": "0000000f-0000-0021-0000-004c00000055", - "managed": true + "managed": false }, { "conversation": "0000005b-0000-002e-0000-00140000003d", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_2.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_2.json index 69323ad2c61..19a9f17bde5 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_2.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_2.json @@ -6,11 +6,11 @@ }, { "conversation": "0000000d-0000-0080-0000-00550000001b", - "managed": true + "managed": false }, { "conversation": "0000004e-0000-0053-0000-004600000056", - "managed": true + "managed": false }, { "conversation": "0000006e-0000-003c-0000-003200000071", @@ -18,7 +18,7 @@ }, { "conversation": "00000067-0000-002f-0000-007a0000007f", - "managed": true + "managed": false }, { "conversation": "0000000a-0000-0027-0000-004e0000005f", @@ -26,15 +26,15 @@ }, { "conversation": "00000006-0000-0026-0000-000000000054", - "managed": true + "managed": false }, { "conversation": "0000006e-0000-007e-0000-001600000035", - "managed": true + "managed": false }, { "conversation": "0000002c-0000-0057-0000-007e00000070", - "managed": true + "managed": false }, { "conversation": "00000074-0000-0053-0000-005f00000006", @@ -58,11 +58,11 @@ }, { "conversation": "00000056-0000-0018-0000-003f00000001", - "managed": true + "managed": false }, { "conversation": "00000014-0000-0066-0000-00440000001b", - "managed": true + "managed": false }, { "conversation": "0000007f-0000-0071-0000-007f0000001b", @@ -82,7 +82,7 @@ }, { "conversation": "0000004d-0000-0021-0000-00360000000e", - "managed": true + "managed": false }, { "conversation": "00000057-0000-003f-0000-003700000065", @@ -90,19 +90,19 @@ }, { "conversation": "0000006f-0000-003e-0000-000300000051", - "managed": true + "managed": false }, { "conversation": "00000038-0000-0025-0000-00030000003b", - "managed": true + "managed": false }, { "conversation": "0000003c-0000-0069-0000-005000000035", - "managed": true + "managed": false }, { "conversation": "0000005f-0000-006b-0000-00260000004e", - "managed": true + "managed": false }, { "conversation": "0000001c-0000-001c-0000-00530000000c", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_20.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_20.json index e89ec253558..ac130821ff7 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_20.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_20.json @@ -6,7 +6,7 @@ }, { "conversation": "0000003b-0000-0055-0000-003f00000059", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_3.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_3.json index ee0b5f72fad..c492ea34289 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_3.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_3.json @@ -2,15 +2,15 @@ "conversations": [ { "conversation": "00000046-0000-0026-0000-005600000014", - "managed": true + "managed": false }, { "conversation": "0000006b-0000-0042-0000-002c00000074", - "managed": true + "managed": false }, { "conversation": "0000006d-0000-006d-0000-006100000027", - "managed": true + "managed": false }, { "conversation": "00000079-0000-0024-0000-004600000011", @@ -34,7 +34,7 @@ }, { "conversation": "0000001e-0000-0036-0000-006400000045", - "managed": true + "managed": false }, { "conversation": "00000050-0000-0066-0000-000500000075", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_4.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_4.json index 32de2044cf4..56cca582891 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_4.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_4.json @@ -2,23 +2,23 @@ "conversations": [ { "conversation": "00000076-0000-0038-0000-003c00000043", - "managed": true + "managed": false }, { "conversation": "00000046-0000-001f-0000-005800000080", - "managed": true + "managed": false }, { "conversation": "00000023-0000-0070-0000-006f00000077", - "managed": true + "managed": false }, { "conversation": "00000006-0000-0031-0000-004700000053", - "managed": true + "managed": false }, { "conversation": "00000057-0000-0041-0000-001600000013", - "managed": true + "managed": false }, { "conversation": "0000007b-0000-003c-0000-004800000063", @@ -30,7 +30,7 @@ }, { "conversation": "0000001a-0000-007b-0000-00460000007f", - "managed": true + "managed": false }, { "conversation": "00000052-0000-002e-0000-001000000064", @@ -42,15 +42,15 @@ }, { "conversation": "00000004-0000-0033-0000-00780000005e", - "managed": true + "managed": false }, { "conversation": "0000006b-0000-007f-0000-001d0000002c", - "managed": true + "managed": false }, { "conversation": "00000017-0000-0079-0000-001c00000066", - "managed": true + "managed": false }, { "conversation": "0000002f-0000-0024-0000-001000000074", @@ -58,11 +58,11 @@ }, { "conversation": "00000010-0000-000c-0000-001700000046", - "managed": true + "managed": false }, { "conversation": "00000003-0000-0049-0000-003100000022", - "managed": true + "managed": false }, { "conversation": "00000011-0000-0051-0000-003300000061", @@ -70,7 +70,7 @@ }, { "conversation": "0000003e-0000-0077-0000-004c00000022", - "managed": true + "managed": false }, { "conversation": "0000007e-0000-0048-0000-007200000056", @@ -86,11 +86,11 @@ }, { "conversation": "0000004c-0000-0071-0000-007a00000071", - "managed": true + "managed": false }, { "conversation": "00000006-0000-0002-0000-002000000068", - "managed": true + "managed": false }, { "conversation": "0000002e-0000-0037-0000-005e00000027", @@ -98,7 +98,7 @@ }, { "conversation": "00000056-0000-006d-0000-004d00000024", - "managed": true + "managed": false }, { "conversation": "0000004a-0000-0038-0000-001e0000003b", @@ -114,7 +114,7 @@ }, { "conversation": "0000006b-0000-0013-0000-004a00000018", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_5.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_5.json index fcabdfcd1cc..9fc01c729f4 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_5.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_5.json @@ -2,11 +2,11 @@ "conversations": [ { "conversation": "00000073-0000-005a-0000-00250000000d", - "managed": true + "managed": false }, { "conversation": "00000033-0000-005c-0000-006e00000014", - "managed": true + "managed": false }, { "conversation": "00000017-0000-005d-0000-003b00000023", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_6.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_6.json index 9a5247fb31d..e3e2854092a 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_6.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_6.json @@ -6,23 +6,23 @@ }, { "conversation": "00000028-0000-0037-0000-000b00000016", - "managed": true + "managed": false }, { "conversation": "00000021-0000-0064-0000-003900000002", - "managed": true + "managed": false }, { "conversation": "00000064-0000-001f-0000-00350000001b", - "managed": true + "managed": false }, { "conversation": "0000002d-0000-007b-0000-00770000003e", - "managed": true + "managed": false }, { "conversation": "00000064-0000-0068-0000-007700000068", - "managed": true + "managed": false }, { "conversation": "00000061-0000-000b-0000-00170000005c", @@ -30,7 +30,7 @@ }, { "conversation": "0000005c-0000-0001-0000-004e00000003", - "managed": true + "managed": false }, { "conversation": "00000008-0000-002b-0000-002d00000022", diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_7.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_7.json index cfe09817a41..a3a49965496 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_7.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_7.json @@ -18,15 +18,15 @@ }, { "conversation": "00000040-0000-0001-0000-00670000002e", - "managed": true + "managed": false }, { "conversation": "00000002-0000-0016-0000-004300000052", - "managed": true + "managed": false }, { "conversation": "0000007b-0000-0073-0000-002700000048", - "managed": true + "managed": false }, { "conversation": "0000003b-0000-0048-0000-002500000015", @@ -34,7 +34,7 @@ }, { "conversation": "00000055-0000-007c-0000-001500000051", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_8.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_8.json index 492bf3e33c5..cf6455ca885 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_8.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_8.json @@ -2,11 +2,11 @@ "conversations": [ { "conversation": "00000026-0000-0066-0000-00170000007b", - "managed": true + "managed": false }, { "conversation": "00000064-0000-0015-0000-001f00000071", - "managed": true + "managed": false }, { "conversation": "00000063-0000-0049-0000-004100000018", @@ -14,19 +14,19 @@ }, { "conversation": "00000050-0000-002b-0000-000300000001", - "managed": true + "managed": false }, { "conversation": "00000035-0000-006e-0000-002f00000057", - "managed": true + "managed": false }, { "conversation": "0000006f-0000-0064-0000-003b0000002d", - "managed": true + "managed": false }, { "conversation": "0000003e-0000-0009-0000-00630000001d", - "managed": true + "managed": false }, { "conversation": "0000002a-0000-004d-0000-001b00000036", @@ -38,7 +38,7 @@ }, { "conversation": "00000016-0000-0007-0000-00690000002d", - "managed": true + "managed": false }, { "conversation": "00000043-0000-001f-0000-007500000002", @@ -46,19 +46,19 @@ }, { "conversation": "00000002-0000-0012-0000-006200000028", - "managed": true + "managed": false }, { "conversation": "00000019-0000-003a-0000-002300000023", - "managed": true + "managed": false }, { "conversation": "00000050-0000-006d-0000-00610000000c", - "managed": true + "managed": false }, { "conversation": "00000068-0000-0048-0000-003200000004", - "managed": true + "managed": false }, { "conversation": "00000003-0000-0024-0000-002000000015", @@ -66,15 +66,15 @@ }, { "conversation": "00000027-0000-0003-0000-007600000028", - "managed": true + "managed": false }, { "conversation": "00000074-0000-005d-0000-00100000005d", - "managed": true + "managed": false }, { "conversation": "00000071-0000-0075-0000-000a0000002c", - "managed": true + "managed": false }, { "conversation": "00000012-0000-0071-0000-004d00000010", @@ -94,11 +94,11 @@ }, { "conversation": "0000002d-0000-005f-0000-007f0000001b", - "managed": true + "managed": false }, { "conversation": "00000057-0000-0050-0000-002100000074", - "managed": true + "managed": false }, { "conversation": "00000077-0000-0063-0000-00360000000e", @@ -114,11 +114,11 @@ }, { "conversation": "00000029-0000-0043-0000-006700000030", - "managed": true + "managed": false }, { "conversation": "00000039-0000-003e-0000-008000000051", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversationList_team_9.json b/libs/wire-api/test/golden/testObject_TeamConversationList_team_9.json index c83346051a0..a9c45447710 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversationList_team_9.json +++ b/libs/wire-api/test/golden/testObject_TeamConversationList_team_9.json @@ -6,23 +6,23 @@ }, { "conversation": "00000080-0000-0009-0000-006500000038", - "managed": true + "managed": false }, { "conversation": "0000004e-0000-000a-0000-004e00000039", - "managed": true + "managed": false }, { "conversation": "00000062-0000-001e-0000-004c00000058", - "managed": true + "managed": false }, { "conversation": "00000004-0000-0021-0000-00670000000a", - "managed": true + "managed": false }, { "conversation": "0000004f-0000-0063-0000-004a0000004b", - "managed": true + "managed": false }, { "conversation": "00000044-0000-0017-0000-006300000067", @@ -30,11 +30,11 @@ }, { "conversation": "0000006a-0000-0070-0000-002e0000000a", - "managed": true + "managed": false }, { "conversation": "00000049-0000-0080-0000-006000000025", - "managed": true + "managed": false }, { "conversation": "0000007d-0000-0040-0000-001700000066", @@ -42,15 +42,15 @@ }, { "conversation": "00000057-0000-0045-0000-00610000006c", - "managed": true + "managed": false }, { "conversation": "00000001-0000-0042-0000-005b00000057", - "managed": true + "managed": false }, { "conversation": "00000048-0000-0032-0000-000000000069", - "managed": true + "managed": false }, { "conversation": "00000003-0000-0022-0000-00370000005b", @@ -62,7 +62,7 @@ }, { "conversation": "0000003a-0000-0067-0000-00060000003e", - "managed": true + "managed": false }, { "conversation": "0000001e-0000-0043-0000-002800000065", @@ -70,11 +70,11 @@ }, { "conversation": "00000053-0000-001f-0000-001700000006", - "managed": true + "managed": false }, { "conversation": "00000068-0000-0024-0000-004900000037", - "managed": true + "managed": false }, { "conversation": "00000005-0000-0019-0000-00670000005c", @@ -82,15 +82,15 @@ }, { "conversation": "00000029-0000-0003-0000-00520000004c", - "managed": true + "managed": false }, { "conversation": "00000080-0000-002f-0000-002b0000006f", - "managed": true + "managed": false }, { "conversation": "00000021-0000-002e-0000-004f0000005e", - "managed": true + "managed": false }, { "conversation": "0000006a-0000-0023-0000-00560000001b", @@ -98,23 +98,23 @@ }, { "conversation": "00000066-0000-007b-0000-00160000005c", - "managed": true + "managed": false }, { "conversation": "0000004e-0000-0008-0000-006b00000049", - "managed": true + "managed": false }, { "conversation": "0000005b-0000-0020-0000-005000000006", - "managed": true + "managed": false }, { "conversation": "00000052-0000-0038-0000-003400000074", - "managed": true + "managed": false }, { "conversation": "00000067-0000-006f-0000-00370000002e", - "managed": true + "managed": false } ] } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_11.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_11.json index c3ed7357a11..25cf779c07c 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_11.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_11.json @@ -1,4 +1,4 @@ { "conversation": "00000003-0000-0041-0000-002600000041", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_14.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_14.json index 0e57b1c36d9..70ac6497480 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_14.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_14.json @@ -1,4 +1,4 @@ { "conversation": "0000005b-0000-0065-0000-002a00000060", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_15.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_15.json index d57937b90e8..bc6c7526159 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_15.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_15.json @@ -1,4 +1,4 @@ { "conversation": "0000001f-0000-0037-0000-005a0000004d", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_17.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_17.json index 6cee0ea4117..49f37f2faec 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_17.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_17.json @@ -1,4 +1,4 @@ { "conversation": "00000009-0000-0060-0000-005c00000049", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_19.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_19.json index e89e0e335b8..f4165939bdc 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_19.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_19.json @@ -1,4 +1,4 @@ { "conversation": "0000003d-0000-0025-0000-00170000002e", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_4.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_4.json index 4649545ec67..36244e41508 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_4.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_4.json @@ -1,4 +1,4 @@ { "conversation": "0000002d-0000-0034-0000-004600000023", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_8.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_8.json index 4c6909cb827..32455b74b26 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_8.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_8.json @@ -1,4 +1,4 @@ { "conversation": "0000002e-0000-006d-0000-003700000042", - "managed": true + "managed": false } diff --git a/libs/wire-api/test/golden/testObject_TeamConversation_team_9.json b/libs/wire-api/test/golden/testObject_TeamConversation_team_9.json index 62036a981f9..4e9f0537f6c 100644 --- a/libs/wire-api/test/golden/testObject_TeamConversation_team_9.json +++ b/libs/wire-api/test/golden/testObject_TeamConversation_team_9.json @@ -1,4 +1,4 @@ { "conversation": "0000000d-0000-001b-0000-006800000047", - "managed": true + "managed": false } 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 03a2b24609b..e11f7e41f12 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 @@ -94,8 +94,6 @@ tests = testRoundTrip @Connection.UserConnectionList, testRoundTrip @Connection.ConnectionUpdate, testRoundTrip @Conversation.Conversation, - testRoundTrip @Conversation.NewConvUnmanaged, - testRoundTrip @Conversation.NewConvManaged, testRoundTrip @(Conversation.ConversationList ConvId), testRoundTrip @(Conversation.ConversationList Conversation.Conversation), testRoundTrip @Conversation.Access, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index b983ea00ffb..fd063fc7f11 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -324,8 +324,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.NewBotRequest_provider Test.Wire.API.Golden.Generated.NewBotResponse_provider Test.Wire.API.Golden.Generated.NewClient_user - Test.Wire.API.Golden.Generated.NewConvManaged_user - Test.Wire.API.Golden.Generated.NewConvUnmanaged_user + Test.Wire.API.Golden.Generated.NewConv_user Test.Wire.API.Golden.Generated.NewLegalHoldClient_team Test.Wire.API.Golden.Generated.NewLegalHoldService_team Test.Wire.API.Golden.Generated.NewOtrMessage_user diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 27a45dbcf9a..774532db7f7 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -814,14 +814,10 @@ addBot zuid zcon cid add = do maxSize <- fromIntegral . setMaxConvSize <$> view settings unless (length (cmOthers mems) < maxSize - 1) $ throwStd tooManyMembers - -- For team conversations: bots are not allowed in managed and in + -- For team conversations: bots are not allowed in -- team-only conversations unless (Set.member ServiceAccessRole (cnvAccessRoles cnv)) $ throwStd invalidConv - for_ (cnvTeam cnv) $ \tid -> do - tc <- lift (RPC.getTeamConv zuid tid cid) >>= maybeConvNotFound - when (view Teams.managedConversation tc) $ - throwStd invalidConv -- Lookup the relevant service data scon <- DB.lookupServiceConn pid sid >>= maybeServiceNotFound unless (sconEnabled scon) $ diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 5bbc50e43b7..1fff41468d4 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1291,7 +1291,7 @@ createConvWithAccessRoles ars g u us = . header "Z-Type" "access" . header "Z-Connection" "conn" . contentJson - . body (RequestBodyLBS (encode (NewConvUnmanaged conv))) + . body (RequestBodyLBS (encode conv)) where conv = NewConv us [] Nothing Set.empty ars Nothing Nothing Nothing roleNameWireAdmin diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 34700b3a301..4a4d9c9ad29 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -36,7 +36,7 @@ import Data.Misc (Milliseconds) import Data.Range import qualified Data.Set as Set import qualified Data.Text.Encoding as T -import Galley.Types (ConvTeamInfo (..), NewConv (..), NewConvManaged (..), NewConvUnmanaged (..)) +import Galley.Types (ConvTeamInfo (..), NewConv (..)) import Galley.Types.Conversations.Roles (roleNameWireAdmin) import qualified Galley.Types.Teams as Team import qualified Galley.Types.Teams.Intra as Team @@ -209,10 +209,9 @@ updatePermissions from tid (to, perm) galley = createTeamConv :: HasCallStack => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId createTeamConv g tid u us mtimer = do - let tinfo = Just $ ConvTeamInfo tid False + let tinfo = Just $ ConvTeamInfo tid let conv = - NewConvUnmanaged $ - NewConv us [] Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin + NewConv us [] Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin r <- post ( g @@ -228,28 +227,6 @@ createTeamConv g tid u us mtimer = do fromByteString $ getHeader' "Location" r --- See Note [managed conversations] -createManagedConv :: HasCallStack => Galley -> TeamId -> UserId -> [UserId] -> Maybe Milliseconds -> Http ConvId -createManagedConv g tid u us mtimer = do - let tinfo = Just $ ConvTeamInfo tid True - let conv = - NewConvManaged $ - NewConv us [] Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin - r <- - post - ( g - . path "/i/conversations/managed" - . zUser u - . zConn "conn" - . contentJson - . lbytes (encode conv) - ) - Galley -> TeamId -> ConvId -> UserId -> Http () deleteTeamConv g tid cid u = do delete diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index 853bda1a63c..a78439bb2d9 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -247,7 +247,7 @@ testAddRemoteUsersToLocalConv brig1 galley1 brig2 galley2 = do alice <- randomUser brig1 bob <- randomUser brig2 - let newConv = NewConvUnmanaged $ NewConv [] [] (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin + let newConv = NewConv [] [] (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin convId <- fmap cnvQualifiedId . responseJsonError =<< post diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 70fd87e91c0..07ddde9be7e 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -674,7 +674,7 @@ getConversationQualified galley usr cnv = createConversation :: (MonadIO m, MonadHttp m) => Galley -> UserId -> [Qualified UserId] -> m ResponseLBS createConversation galley zusr usersToAdd = do - let conv = NewConvUnmanaged $ NewConv [] usersToAdd (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin + let conv = NewConv [] usersToAdd (Just "gossip") mempty Nothing Nothing Nothing Nothing roleNameWireAdmin post $ galley . path "/conversations" diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 1e1ffd12b91..68562d43fea 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -24,7 +24,6 @@ -- with this program. If not, see . module Galley.API.Create ( createGroupConversation, - internalCreateManagedConversationH, createSelfConversation, createOne2OneConversation, createConnectConversation, @@ -51,7 +50,6 @@ 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.Effects.WaiRoutes import Galley.Intra.Push import Galley.Options import Galley.Types.Conversations.Members @@ -59,16 +57,11 @@ import Galley.Types.Teams (ListType (..), Perm (..), TeamBinding (Binding), notT import Galley.Types.UserList import Galley.Validation import Imports hiding ((\\)) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Predicate hiding (Error, setStatus) -import Network.Wai.Utilities hiding (Error) import Polysemy import Polysemy.Error import Polysemy.Input import qualified Polysemy.TinyLog as P import Wire.API.Conversation hiding (Conversation, Member) -import qualified Wire.API.Conversation as Public import Wire.API.ErrorDescription import Wire.API.Event.Conversation hiding (Conversation) import Wire.API.Federation.Error @@ -103,111 +96,17 @@ createGroupConversation :: r => Local UserId -> ConnId -> - Public.NewConvUnmanaged -> + NewConv -> Sem r ConversationResponse -createGroupConversation user conn wrapped@(Public.NewConvUnmanaged body) = - case newConvTeam body of - Nothing -> createRegularGroupConv user conn wrapped - Just tinfo -> createTeamGroupConv user conn tinfo body - --- | An internal endpoint for creating managed group conversations. Will --- throw an error for everything else. -internalCreateManagedConversationH :: - Members - '[ ConversationStore, - BrigAccess, - Error ActionError, - Error ConversationError, - Error InternalError, - Error InvalidInput, - Error LegalHoldError, - Error NotATeamMember, - FederatorAccess, - GundeckAccess, - Input (Local ()), - Input Opts, - Input UTCTime, - LegalHoldStore, - TeamStore, - P.TinyLog, - WaiRoutes - ] - r => - UserId ::: ConnId ::: JsonRequest NewConvManaged -> - Sem r Response -internalCreateManagedConversationH (zusr ::: zcon ::: req) = do - lusr <- qualifyLocal zusr - newConv <- fromJsonBody req - handleConversationResponse <$> internalCreateManagedConversation lusr zcon newConv - -internalCreateManagedConversation :: - Members - '[ ConversationStore, - BrigAccess, - Error ActionError, - Error ConversationError, - Error InternalError, - Error InvalidInput, - Error LegalHoldError, - Error NotATeamMember, - FederatorAccess, - GundeckAccess, - Input Opts, - LegalHoldStore, - Input UTCTime, - TeamStore, - P.TinyLog - ] - r => - Local UserId -> - ConnId -> - NewConvManaged -> - Sem r ConversationResponse -internalCreateManagedConversation lusr zcon (NewConvManaged body) = do - tinfo <- note CannotCreateManagedConv (newConvTeam body) - createTeamGroupConv lusr zcon tinfo body - -ensureNoLegalholdConflicts :: - Members '[Error LegalHoldError, Input Opts, LegalHoldStore, TeamStore] r => - [Remote UserId] -> - [UserId] -> - Sem r () -ensureNoLegalholdConflicts remotes locals = do - let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes - whenM (anyLegalholdActivated locals) $ - unlessM (allLegalholdConsentGiven locals) $ - throw MissingLegalholdConsent - --- | A helper for creating a regular (non-team) group conversation. -createRegularGroupConv :: - Members - '[ ConversationStore, - BrigAccess, - FederatorAccess, - Error ActionError, - Error InternalError, - Error InvalidInput, - Error LegalHoldError, - GundeckAccess, - Input Opts, - Input UTCTime, - LegalHoldStore, - TeamStore, - P.TinyLog - ] - r => - Local UserId -> - ConnId -> - NewConvUnmanaged -> - Sem r ConversationResponse -createRegularGroupConv lusr zcon (NewConvUnmanaged body) = do +createGroupConversation lusr conn body = do + let tinfo = newConvTeam body + allUsers = newConvMembers lusr body name <- rangeCheckedMaybe (newConvName body) - let allUsers = newConvMembers lusr body o <- input checkedUsers <- checkedConvSize o allUsers - ensureConnected lusr allUsers + checkCreateConvPermissions lusr body tinfo allUsers ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) - c <- + conv <- E.createConversation NewConversation { ncType = RegularConv, @@ -221,46 +120,44 @@ createRegularGroupConv lusr zcon (NewConvUnmanaged body) = do ncUsers = checkedUsers, ncRole = newConvUsersRole body } - notifyCreatedConversation Nothing lusr (Just zcon) c - conversationCreated lusr c + now <- input + -- NOTE: We only send (conversation) events to members of the conversation + notifyCreatedConversation (Just now) lusr (Just conn) conv + conversationCreated lusr conv + +ensureNoLegalholdConflicts :: + Members '[Error LegalHoldError, Input Opts, LegalHoldStore, TeamStore] r => + [Remote UserId] -> + [UserId] -> + Sem r () +ensureNoLegalholdConflicts remotes locals = do + let FutureWork _remotes = FutureWork @'LegalholdPlusFederationNotImplemented remotes + whenM (anyLegalholdActivated locals) $ + unlessM (allLegalholdConsentGiven locals) $ + throw MissingLegalholdConsent --- | A helper for creating a team group conversation, used by the endpoint --- handlers above. Only supports unmanaged conversations. -createTeamGroupConv :: +checkCreateConvPermissions :: Members - '[ ConversationStore, - BrigAccess, + '[ BrigAccess, Error ActionError, Error ConversationError, - Error InternalError, - Error InvalidInput, - Error LegalHoldError, Error NotATeamMember, - FederatorAccess, - GundeckAccess, - Input Opts, - Input UTCTime, - LegalHoldStore, - TeamStore, - P.TinyLog + TeamStore ] r => Local UserId -> - ConnId -> - Public.ConvTeamInfo -> - Public.NewConv -> - Sem r ConversationResponse -createTeamGroupConv lusr zcon tinfo body = do - name <- rangeCheckedMaybe (newConvName body) - let allUsers = newConvMembers lusr body - convTeam = cnvTeamId tinfo - + NewConv -> + Maybe ConvTeamInfo -> + UserList UserId -> + Sem r () +checkCreateConvPermissions lusr _newConv Nothing allUsers = + ensureConnected lusr allUsers +checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do + let convTeam = cnvTeamId tinfo zusrMembership <- E.getTeamMember convTeam (tUnqualified lusr) void $ permissionCheck CreateConversation zusrMembership - o <- input - checkedUsers <- checkedConvSize o allUsers convLocalMemberships <- mapM (E.getTeamMember convTeam) (ulLocals allUsers) - ensureAccessRole (accessRoles body) (zip (ulLocals allUsers) convLocalMemberships) + ensureAccessRole (accessRoles newConv) (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 -- regular conversations, therefore we check for 'AddRemoveConvMember' only if @@ -273,29 +170,11 @@ createTeamGroupConv lusr zcon tinfo body = do -- think of is that 'partners' can create convs but not be admins... when (length allUsers > 1) $ do void $ permissionCheck DoNotUseDeprecatedAddRemoveConvMember zusrMembership + -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. ensureConnectedToLocals (tUnqualified lusr) (notTeamMember (ulLocals allUsers) (catMaybes convLocalMemberships)) ensureConnectedToRemotes lusr (ulRemotes allUsers) - ensureNoLegalholdConflicts (ulRemotes allUsers) (ulLocals allUsers) - conv <- - E.createConversation - NewConversation - { ncType = RegularConv, - ncCreator = tUnqualified lusr, - ncAccess = access body, - ncAccessRoles = accessRoles body, - ncName = name, - ncTeam = fmap cnvTeamId (newConvTeam body), - ncMessageTimer = newConvMessageTimer body, - ncReceiptMode = newConvReceiptMode body, - ncUsers = checkedUsers, - ncRole = newConvUsersRole body - } - now <- input - -- NOTE: We only send (conversation) events to members of the conversation - notifyCreatedConversation (Just now) lusr (Just zcon) conv - conversationCreated lusr conv ---------------------------------------------------------------------------- -- Other kinds of conversations @@ -335,22 +214,20 @@ createOne2OneConversation :: r => Local UserId -> ConnId -> - NewConvUnmanaged -> + NewConv -> Sem r ConversationResponse -createOne2OneConversation lusr zcon (NewConvUnmanaged j) = do +createOne2OneConversation lusr zcon j = do let allUsers = newConvMembers lusr j other <- ensureOne (ulAll lusr allUsers) when (qUntagged lusr == other) $ throw . InvalidOp $ One2OneConv mtid <- case newConvTeam j of - Just ti - | cnvManaged ti -> throw NoManagedTeamConv - | otherwise -> do - foldQualified - lusr - (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) - (const (pure Nothing)) - other + Just ti -> do + foldQualified + lusr + (\lother -> checkBindingTeamPermissions lother (cnvTeamId ti)) + (const (pure Nothing)) + other Nothing -> ensureConnected lusr allUsers $> Nothing n <- rangeCheckedMaybe (newConvName j) foldQualified @@ -490,41 +367,7 @@ createConnectConversation :: Connect -> Sem r ConversationResponse createConnectConversation lusr conn j = do - foldQualified - lusr - (\lrcpt -> createLegacyConnectConversation lusr conn lrcpt j) - (createConnectConversationWithRemote lusr conn) - (cRecipient j) - -createConnectConversationWithRemote :: - Member (Error FederationError) r => - Local UserId -> - Maybe ConnId -> - Remote UserId -> - Sem r ConversationResponse -createConnectConversationWithRemote _ _ _ = - throw FederationNotImplemented - -createLegacyConnectConversation :: - Members - '[ ConversationStore, - Error ActionError, - Error InvalidInput, - Error ConversationError, - Error InternalError, - FederatorAccess, - GundeckAccess, - Input UTCTime, - MemberStore, - P.TinyLog - ] - r => - Local UserId -> - Maybe ConnId -> - Local UserId -> - Connect -> - Sem r ConversationResponse -createLegacyConnectConversation lusr conn lrecipient j = do + lrecipient <- ensureLocal lusr (cRecipient j) (x, y) <- toUUIDs (tUnqualified lusr) (tUnqualified lrecipient) n <- rangeCheckedMaybe (cName j) conv <- E.getConversation (Data.localOne2OneConvId x y) @@ -601,11 +444,6 @@ conversationExisted :: Sem r ConversationResponse conversationExisted lusr cnv = Existed <$> conversationView lusr cnv -handleConversationResponse :: ConversationResponse -> Response -handleConversationResponse = \case - Created cnv -> json cnv & setStatus status201 . location (qUnqualified . cnvQualifiedId $ cnv) - Existed cnv -> json cnv & setStatus status200 . location (qUnqualified . cnvQualifiedId $ cnv) - notifyCreatedConversation :: Members '[Error InternalError, FederatorAccess, GundeckAccess, Input UTCTime, P.TinyLog] r => Maybe UTCTime -> diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 7993acc8c80..8f8b635f22c 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -68,7 +68,6 @@ data ActionError | InvalidOp ConvType | OperationDenied String | NotConnected - | NoAddToManaged | BroadcastLimitExceeded | InvalidTeamStatusUpdate | InvalidPermissions @@ -85,7 +84,6 @@ instance APIError ActionError where toWai (OperationDenied p) = errorDescriptionToWai $ operationDeniedSpecialized p toWai NotConnected = errorDescriptionTypeToWai @NotConnected toWai InvalidTargetUserOp = invalidTargetUserOp - toWai NoAddToManaged = noAddToManaged toWai BroadcastLimitExceeded = errorDescriptionTypeToWai @BroadcastLimitExceeded toWai InvalidTeamStatusUpdate = invalidTeamStatusUpdate toWai InvalidPermissions = invalidPermissions @@ -121,7 +119,6 @@ data ConversationError | TooManyMembers | ConvMemberNotFound | NoBindingTeamMembers - | NoManagedTeamConv | GuestLinksDisabled instance APIError ConversationError where @@ -130,7 +127,6 @@ instance APIError ConversationError where toWai TooManyMembers = errorDescriptionTypeToWai @TooManyMembers toWai ConvMemberNotFound = errorDescriptionTypeToWai @ConvMemberNotFound toWai NoBindingTeamMembers = noBindingTeamMembers - toWai NoManagedTeamConv = noManagedTeamConv toWai GuestLinksDisabled = guestLinksDisabled data TeamError @@ -367,9 +363,6 @@ bulkGetMemberLimitExceeded = "too-many-uids" ("Can only process " <> cs (show @Int hardTruncationLimit) <> " user ids per request.") -noAddToManaged :: Error -noAddToManaged = mkError status403 "no-add-to-managed" "Adding users/bots directly to managed conversation is not allowed." - invalidPermissions :: Error invalidPermissions = mkError status403 "invalid-permissions" "The specified permissions are invalid." @@ -385,9 +378,6 @@ tooManyTeamMembersOnTeamWithLegalhold = mkError status403 "too-many-members-for- teamMemberNotFound :: Error teamMemberNotFound = mkError status404 "no-team-member" "team member not found" -noManagedTeamConv :: Error -noManagedTeamConv = mkError status400 "no-managed-team-conv" "Managed team conversations have been deprecated." - guestLinksDisabled :: Error guestLinksDisabled = mkError status409 "guest-links-disabled" "The guest link feature is disabled and all guest links have been revoked." diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index d6e98038b99..3c1179eb18c 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -320,13 +320,6 @@ internalSitemap = do capture "cnv" .&. capture "usr" - -- This endpoint can lead to the following events being sent: - -- - ConvCreate event to members - post "/i/conversations/managed" (continue Create.internalCreateManagedConversationH) $ - zauthUserId - .&. zauthConnId - .&. jsonRequest @NewConvManaged - -- This endpoint can lead to the following events being sent: -- - MemberJoin event to you, if the conversation existed and had < 2 members before -- - MemberJoin event to other, if the conversation existed and only the other was member diff --git a/services/galley/src/Galley/API/One2One.hs b/services/galley/src/Galley/API/One2One.hs index e0ea6df3721..9983d7ded48 100644 --- a/services/galley/src/Galley/API/One2One.hs +++ b/services/galley/src/Galley/API/One2One.hs @@ -1,19 +1,3 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2021 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index d0dbaacad84..bac8563893c 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -436,8 +436,7 @@ uncheckedDeleteTeam lusr zcon tid = do when (isJust team) $ do Spar.deleteTeam tid now <- input - convs <- - filter (not . view managedConversation) <$> E.getTeamConversations tid + convs <- 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 @@ -1093,7 +1092,7 @@ uncheckedDeleteTeamMember lusr zcon tid remove mems = do for_ conv $ \dc -> when (remove `isMember` Data.convLocalMembers dc) $ do 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) $ + unless (mems ^. teamMemberListType == ListTruncated) $ pushEvent tmids edata now dc pushEvent :: Set UserId -> Conv.EventData -> UTCTime -> Data.Conversation -> Sem r () pushEvent exceptTo edata now dc = do @@ -1339,12 +1338,7 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) memList = . Log.field "action" (Log.val "Teams.addTeamMemberInternal") sizeBeforeAdd <- ensureNotTooLarge tid E.createTeamMember tid new - cc <- filter (view managedConversation) <$> E.getTeamConversations tid now <- input - for_ cc $ \c -> do - lcid <- qualifyLocal (c ^. conversationId) - luid <- qualifyLocal (new ^. userId) - E.createMember lcid luid let e = newEvent MemberJoin tid now & eventData ?~ EdMemberJoin (new ^. userId) E.push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 66ffd60a5cc..54b6f910639 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -93,7 +93,6 @@ 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.Effects.WaiRoutes import Galley.Intra.Push import Galley.Options @@ -1428,7 +1427,6 @@ addBot lusr zcon b = do c <- 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 c t <- input E.createClient (botUserId (b ^. addBotId)) (b ^. addBotClient) @@ -1462,11 +1460,6 @@ addBot lusr zcon b = do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] return (bots, users) - teamConvChecks :: ConvId -> TeamId -> Sem r () - teamConvChecks cid tid = do - tcv <- E.getTeamConversation tid cid - when (maybe True (view managedConversation) tcv) $ - throw NoAddToManaged rmBotH :: Members diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index 27c61631877..99c5ff4fcc7 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -62,7 +62,7 @@ createConversation (NewConversation ty usr acc arole name mtid mtimer recpt user setType BatchLogged setConsistency LocalQuorum addPrepQuery Cql.insertConv (conv, ty, usr, Cql.Set (toList acc), Cql.Set (toList arole), fmap fromRange name, Just tid, mtimer, recpt) - addPrepQuery Cql.insertTeamConv (tid, conv, False) + addPrepQuery Cql.insertTeamConv (tid, conv) let newUsers = fmap (,role) (fromConvSize users) (lmems, rmems) <- addMembers conv (ulAddLocal (usr, roleNameWireAdmin) newUsers) pure $ @@ -169,7 +169,7 @@ createOne2OneConversation conv self other name mtid = do setType BatchLogged setConsistency LocalQuorum addPrepQuery Cql.insertConv (conv, One2OneConv, tUnqualified self, privateOnly, Cql.Set [], fromRange <$> name, Just tid, Nothing, Nothing) - addPrepQuery Cql.insertTeamConv (tid, conv, False) + addPrepQuery Cql.insertTeamConv (tid, conv) (lmems, rmems) <- addMembers conv (toUserList self [qUntagged self, other]) pure Conversation diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index 8301c46ffb5..0e3ebaf5ec1 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -106,12 +106,11 @@ instance Cql AccessRoleV2 where instance Cql ConvTeamInfo where ctype = Tagged $ UdtColumn "teaminfo" [("teamid", UuidColumn), ("managed", BooleanColumn)] - toCql t = CqlUdt [("teamid", toCql (cnvTeamId t)), ("managed", toCql (cnvManaged t))] + toCql t = CqlUdt [("teamid", toCql (cnvTeamId t)), ("managed", toCql False)] fromCql (CqlUdt u) = do t <- note "missing 'teamid' in teaminfo" ("teamid" `lookup` u) >>= fromCql - m <- note "missing 'managed' in teaminfo" ("managed" `lookup` u) >>= fromCql - pure (ConvTeamInfo t m) + pure (ConvTeamInfo t) fromCql _ = Left "teaminfo: udt expected" instance Cql TeamBinding where diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index 68b646a11cd..4d199920a53 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -51,14 +51,14 @@ selectTeamBinding = "select binding from team where team = ?" selectTeamBindingWritetime :: PrepQuery R (Identity TeamId) (Identity (Maybe Int64)) selectTeamBindingWritetime = "select writetime(binding) from team where team = ?" -selectTeamConv :: PrepQuery R (TeamId, ConvId) (Identity Bool) -selectTeamConv = "select managed from team_conv where team = ? and conv = ?" +selectTeamConv :: PrepQuery R (TeamId, ConvId) (Identity ConvId) +selectTeamConv = "select conv from team_conv where team = ? and conv = ?" -selectTeamConvs :: PrepQuery R (Identity TeamId) (ConvId, Bool) -selectTeamConvs = "select conv, managed from team_conv where team = ? order by conv" +selectTeamConvs :: PrepQuery R (Identity TeamId) (Identity ConvId) +selectTeamConvs = "select conv from team_conv where team = ? order by conv" -selectTeamConvsFrom :: PrepQuery R (TeamId, ConvId) (ConvId, Bool) -selectTeamConvsFrom = "select conv, managed from team_conv where team = ? and conv > ? order by conv" +selectTeamConvsFrom :: PrepQuery R (TeamId, ConvId) (Identity ConvId) +selectTeamConvsFrom = "select conv from team_conv where team = ? and conv > ? order by conv" selectTeamMember :: PrepQuery @@ -138,8 +138,8 @@ selectUserTeamsFrom = "select team from user_team where user = ? and team > ? or insertTeam :: PrepQuery W (TeamId, UserId, Text, Text, Maybe Text, TeamStatus, TeamBinding) () insertTeam = "insert into team (team, creator, name, icon, icon_key, deleted, status, binding) values (?, ?, ?, ?, ?, false, ?, ?)" -insertTeamConv :: PrepQuery W (TeamId, ConvId, Bool) () -insertTeamConv = "insert into team_conv (team, conv, managed) values (?, ?, ?)" +insertTeamConv :: PrepQuery W (TeamId, ConvId) () +insertTeamConv = "insert into team_conv (team, conv) values (?, ?)" deleteTeamConv :: PrepQuery W (TeamId, ConvId) () deleteTeamConv = "delete from team_conv where team = ? and conv = ?" diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 27d756f141c..c0ae2938f10 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -161,12 +161,12 @@ getTeamName tid = teamConversation :: TeamId -> ConvId -> Client (Maybe TeamConversation) teamConversation t c = - fmap (newTeamConversation c . runIdentity) + fmap (newTeamConversation . runIdentity) <$> retry x1 (query1 Cql.selectTeamConv (params LocalQuorum (t, c))) getTeamConversations :: TeamId -> Client [TeamConversation] getTeamConversations t = - map (uncurry newTeamConversation) + map (newTeamConversation . runIdentity) <$> retry x1 (query Cql.selectTeamConvs (params LocalQuorum (Identity t))) teamIdsFrom :: UserId -> Maybe TeamId -> Range 1 100 Int32 -> Client (ResultSet TeamId) @@ -418,7 +418,7 @@ newTeamMember' lh tid (uid, perms, minvu, minvt, fromMaybe defUserLegalHoldStatu teamConversationsForPagination :: TeamId -> Maybe ConvId -> Range 1 HardTruncationLimit Int32 -> Client (Page TeamConversation) teamConversationsForPagination tid start (fromRange -> max) = - fmap (uncurry newTeamConversation) <$> case start of + fmap (newTeamConversation . runIdentity) <$> case start of Just c -> paginate Cql.selectTeamConvsFrom (paramsP LocalQuorum (tid, c) max) Nothing -> paginate Cql.selectTeamConvs (paramsP LocalQuorum (Identity tid) max) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2e03ad4dec4..a6405832a30 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1490,7 +1490,7 @@ testAccessUpdateGuestRemoved = do (qUnqualified alice) defNewConv { newConvQualifiedUsers = [bob, charlie, dee], - newConvTeam = Just (ConvTeamInfo tid False) + newConvTeam = Just (ConvTeamInfo tid) } postO2OConv alice bob (Just "gossip1") + cnv1 <- responseJsonError =<< postO2OConv alice bob (Just "gossip1") postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing + cnv2 <- + responseJsonError =<< postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing + (Request -> Request) -> UserId -> [Qualified UserId] -> m ResponseLBS postConvHelper g zusr newUsers = do - let conv = NewConvUnmanaged $ NewConv [] newUsers (Just "gossip") (Set.fromList []) Nothing Nothing Nothing Nothing roleNameWireAdmin + let conv = NewConv [] newUsers (Just "gossip") (Set.fromList []) Nothing Nothing Nothing Nothing roleNameWireAdmin post $ g . path "/conversations" . zUser zusr . zConn "conn" . zType "access" . json conv postSelfConvOk :: TestM () @@ -1955,7 +1957,7 @@ postConvO2OFailWithSelf :: TestM () postConvO2OFailWithSelf = do g <- view tsGalley alice <- randomUser - let inv = NewConvUnmanaged (NewConv [alice] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin) + let inv = NewConv [alice] [] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin post (g . path "/conversations/one2one" . zUser alice . zConn "conn" . zType "access" . json inv) !!! do const 403 === statusCode const (Just "invalid-op") === fmap label . responseJsonUnsafe diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 5ebb4d902f4..dbd02c8a28a 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -119,7 +119,6 @@ tests s = test s "add team conversation (no role as argument)" testAddTeamConvLegacy, test s "add team conversation with role" testAddTeamConvWithRole, test s "add team conversation as partner (fail)" testAddTeamConvAsExternalPartner, - test s "add managed conversation through public endpoint (fail)" testAddManagedConv, -- Queue is emptied here to ensure that lingering events do not affect other tests test s "add team member to conversation without connection" (testAddTeamMemberToConv >> ensureQueueEmpty), test s "update conversation as member" (testUpdateTeamConv RoleMember roleNameWireAdmin), @@ -883,25 +882,6 @@ testAddTeamConvAsExternalPartner = do const 403 === statusCode const "operation-denied" === (Error.label . responseJsonUnsafeWithMsg "error label") -testAddManagedConv :: TestM () -testAddManagedConv = do - g <- view tsGalley - owner <- Util.randomUser - tid <- Util.createNonBindingTeam "foo" owner [] - let tinfo = ConvTeamInfo tid True - let conv = - NewConvManaged $ - NewConv [owner] [] (Just "blah") (Set.fromList []) Nothing (Just tinfo) Nothing Nothing roleNameWireAdmin - post - ( g - . path "/conversations" - . zUser owner - . zConn "conn" - . zType "access" - . json conv - ) - !!! const 400 === statusCode - testAddTeamMemberToConv :: TestM () testAddTeamMemberToConv = do personalUser <- Util.randomUser diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 4cb1ebbd594..d18f5d28365 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -481,7 +481,7 @@ getInvitationCode t ref = do createTeamConvLegacy :: HasCallStack => UserId -> TeamId -> [UserId] -> Maybe Text -> TestM ConvId createTeamConvLegacy u tid us name = do g <- view tsGalley - let tinfo = ConvTeamInfo tid False + let tinfo = ConvTeamInfo tid let convPayload = object [ "users" .= us, @@ -512,10 +512,9 @@ createTeamConvAccess u tid us name acc role mtimer convRole = do createTeamConvAccessRaw :: UserId -> TeamId -> [UserId] -> Maybe Text -> Maybe (Set Access) -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> Maybe RoleName -> TestM ResponseLBS createTeamConvAccessRaw u tid us name acc role mtimer convRole = do g <- view tsGalley - let tinfo = ConvTeamInfo tid False + let tinfo = ConvTeamInfo tid let conv = - NewConvUnmanaged $ - NewConv us [] name (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) + NewConv us [] name (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) post ( g . path "/conversations" @@ -541,8 +540,7 @@ createOne2OneTeamConv :: UserId -> UserId -> Maybe Text -> TeamId -> TestM Respo createOne2OneTeamConv u1 u2 n tid = do g <- view tsGalley let conv = - NewConvUnmanaged $ - NewConv [u2] [] n mempty Nothing (Just $ ConvTeamInfo tid False) Nothing Nothing roleNameWireAdmin + NewConv [u2] [] n mempty Nothing (Just $ ConvTeamInfo tid) Nothing Nothing roleNameWireAdmin post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConv :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> TestM ResponseLBS @@ -564,7 +562,7 @@ postConvQualified u n = do . zUser u . zConn "conn" . zType "access" - . json (NewConvUnmanaged n) + . json n postConvWithRemoteUsers :: HasCallStack => @@ -584,7 +582,7 @@ postConvWithRemoteUsers u n = postTeamConv :: TeamId -> UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> TestM ResponseLBS postTeamConv tid u us name a r mtimer = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv us [] name (Set.fromList a) r (Just (ConvTeamInfo tid False)) mtimer Nothing roleNameWireAdmin + let conv = NewConv us [] name (Set.fromList a) r (Just (ConvTeamInfo tid)) mtimer Nothing roleNameWireAdmin post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv deleteTeamConv :: (HasGalley m, MonadIO m, MonadHttp m) => TeamId -> ConvId -> UserId -> m ResponseLBS @@ -613,7 +611,7 @@ postConvWithRole u members name access arole timer role = postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe (Set AccessRoleV2) -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv us [] name (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin + let conv = NewConv us [] name (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postSelfConv :: UserId -> TestM ResponseLBS @@ -624,7 +622,7 @@ postSelfConv u = do postO2OConv :: UserId -> UserId -> Maybe Text -> TestM ResponseLBS postO2OConv u1 u2 n = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv [u2] [] n mempty Nothing Nothing Nothing Nothing roleNameWireAdmin + let conv = NewConv [u2] [] n mempty Nothing Nothing Nothing Nothing roleNameWireAdmin post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS From 431c9b3bedb5cf9aea04876e088b4a32a299f1a5 Mon Sep 17 00:00:00 2001 From: zebot Date: Mon, 14 Feb 2022 14:21:09 +0100 Subject: [PATCH 36/58] chore: [charts] Update team-settings version (#2109) Co-authored-by: Zebot --- changelog.d/0-release-notes/team-settings-upgrade | 2 +- charts/team-settings/values.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade index dbb2b895a84..1d65468f4de 100644 --- a/changelog.d/0-release-notes/team-settings-upgrade +++ b/changelog.d/0-release-notes/team-settings-upgrade @@ -1 +1 @@ -Upgrade team-settings version to 4.6.0-v0.29.3-0-4d9c229 +Upgrade team-settings version to 4.6.1-v0.29.3-0-28cbbd7 diff --git a/charts/team-settings/values.yaml b/charts/team-settings/values.yaml index 092ff8f719b..cd16b0e039a 100644 --- a/charts/team-settings/values.yaml +++ b/charts/team-settings/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/team-settings - tag: "4.6.0-v0.29.3-0-4d9c229" + tag: "4.6.1-v0.29.3-0-28cbbd7" service: https: externalPort: 443 From d8710962c65486ef997f3855e7d9504f9af73600 Mon Sep 17 00:00:00 2001 From: zebot Date: Mon, 14 Feb 2022 14:22:05 +0100 Subject: [PATCH 37/58] chore: [charts] Update webapp version (#2111) Co-authored-by: Zebot --- changelog.d/0-release-notes/webapp-upgrade | 2 +- charts/webapp/values.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade index 40ea570f4a9..48ab8b478fc 100644 --- a/changelog.d/0-release-notes/webapp-upgrade +++ b/changelog.d/0-release-notes/webapp-upgrade @@ -1 +1 @@ -Upgrade webapp version to 2022-02-07-production.0-v0.29.2-0-a940a2e +Upgrade webapp version to 2022-02-08-production.0-v0.29.2-0-4d437bb diff --git a/charts/webapp/values.yaml b/charts/webapp/values.yaml index b1297070bc2..fe3cdbf7dec 100644 --- a/charts/webapp/values.yaml +++ b/charts/webapp/values.yaml @@ -9,7 +9,7 @@ resources: cpu: "1" image: repository: quay.io/wire/webapp - tag: "2022-02-07-production.0-v0.29.2-0-a940a2e" + tag: "2022-02-08-production.0-v0.29.2-0-4d437bb" service: https: externalPort: 443 From 5e164e45b7fffbb927b2f4d60ec167c0008c6928 Mon Sep 17 00:00:00 2001 From: jschaul Date: Mon, 14 Feb 2022 15:04:32 +0100 Subject: [PATCH 38/58] Stay consistent with #2079 (#2090) --- hack/helm_vars/wire-server/values.yaml.gotmpl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index 98810a0b212..ffc2b22184c 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -18,7 +18,7 @@ cassandra-migrations: imagePullPolicy: {{ .Values.imagePullPolicy }} cassandra: host: cassandra-ephemeral - replicaCount: 1 + replicationFactor: 1 elasticsearch-index: imagePullPolicy: {{ .Values.imagePullPolicy }} elasticsearch: From aab6ed9f58683878f84d05fdb0f00ef5c19061f9 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 14 Feb 2022 18:22:43 +0100 Subject: [PATCH 39/58] Add pull policy to helmfile-single (#2128) --- hack/helmfile-single.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/hack/helmfile-single.yaml b/hack/helmfile-single.yaml index 8d5c81a0413..c6107920b38 100644 --- a/hack/helmfile-single.yaml +++ b/hack/helmfile-single.yaml @@ -13,6 +13,7 @@ environments: values: - namespace: {{ requiredEnv "NAMESPACE" }} - federationDomain: {{ requiredEnv "FEDERATION_DOMAIN" }} + - imagePullPolicy: Always repositories: - name: stable From b4b8bc519b01b22af58d3301f28b639239c3f407 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 15 Feb 2022 06:46:56 +0100 Subject: [PATCH 40/58] Cleanup after review (#2126) This includes adding an assertion, inverting a condition for better readability of an if-else expression and removing an unnecessary call. --- .../test/integration/API/Teams/LegalHold.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 40ff822f854..20b0d8ce6c0 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -712,6 +712,9 @@ testInWhitelist = do "requestLegalHoldDevice when already pending should leave status as Pending" UserLegalHoldPending userStatus + do + -- owner cannot approve legalhold device + withLHWhitelist tid (approveLegalHoldDevice' g (Just defPassword) owner member tid) !!! testResponse 403 (Just "access-denied") do -- approve works withLHWhitelist tid (approveLegalHoldDevice' g (Just defPassword) member member tid) !!! testResponse 200 Nothing @@ -761,8 +764,6 @@ testOldClientsBlockDeviceHandshake = do putLHWhitelistTeam tid !!! const 200 === statusCode withDummyTestServiceForTeam legalholder tid $ \_chan -> do - putLHWhitelistTeam tid !!! const 200 === statusCode - legalholderLHDevice <- doEnableLH legalholder legalholder _legalholder2LHDevice <- doEnableLH legalholder legalholder2 @@ -850,8 +851,12 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect cannon <- view tsCannon WS.bracketR2 cannon legalholder peer $ \(legalholderWs, peerWs) -> withDummyTestServiceForTeam legalholder tid $ \_chan -> do - if connectFirst + if not connectFirst then do + void doEnableLH + postConnection legalholder peer !!! do testResponse 403 (Just "missing-legalhold-consent") + postConnection peer legalholder !!! do testResponse 403 (Just "missing-legalhold-consent") + else do postConnection legalholder peer !!! const 201 === statusCode mbConn :: Maybe UserConnection <- @@ -927,10 +932,6 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect ] !!! do const 201 === statusCode - else do - void doEnableLH - postConnection legalholder peer !!! do testResponse 403 (Just "missing-legalhold-consent") - postConnection peer legalholder !!! do testResponse 403 (Just "missing-legalhold-consent") data GroupConvAdmin = LegalholderIsAdmin From b419ab154d789b16794ea28443c99b144bb4f575 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 15 Feb 2022 09:22:57 +0100 Subject: [PATCH 41/58] support default as icon update (#2130) --- libs/wire-api/src/Wire/API/Team.hs | 27 ++++++++++++++++++- services/galley/test/integration/API/Teams.hs | 2 ++ 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index 6f31c1c7c7d..5b3563e1819 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -72,12 +72,16 @@ where import Control.Lens (makeLenses) import Data.Aeson (FromJSON, ToJSON, Value (..)) import Data.Aeson.Types (Parser) +import qualified Data.Attoparsec.ByteString as Atto (Parser, string) +import Data.Attoparsec.Combinator (choice) +import Data.ByteString.Conversion import Data.Id (TeamId, UserId) import Data.Misc (PlainTextPassword (..)) import Data.Range import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc +import qualified Data.Text.Encoding as T import Imports import Test.QuickCheck.Gen (suchThat) import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) @@ -255,9 +259,30 @@ newTeamSchema name sch = -------------------------------------------------------------------------------- -- TeamUpdateData +data IconUpdate = IconUpdate AssetKey | DefaultIcon + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform IconUpdate) + deriving (ToJSON, FromJSON, S.ToSchema) via Schema IconUpdate + +instance FromByteString IconUpdate where + parser = + choice + [ IconUpdate <$> (parser :: Atto.Parser AssetKey), + DefaultIcon <$ Atto.string "default" + ] + +instance ToByteString IconUpdate where + builder (IconUpdate key) = builder key + builder DefaultIcon = "default" + +instance ToSchema IconUpdate where + schema = + (T.decodeUtf8 . toByteString') + .= parsedText "IconUpdate" (runParser parser . T.encodeUtf8) + data TeamUpdateData = TeamUpdateData { _nameUpdate :: Maybe (Range 1 256 Text), - _iconUpdate :: Maybe AssetKey, + _iconUpdate :: Maybe IconUpdate, _iconKeyUpdate :: Maybe (Range 1 256 Text) } deriving stock (Eq, Show, Generic) diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index dbd02c8a28a..0cd2a8d9297 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1203,6 +1203,8 @@ testUpdateTeamIconValidation = do "icon" .= String "3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" ] update payloadWithValidIcon 200 + let payloadSetIconToDefault = object ["icon" .= String "default"] + update payloadSetIconToDefault 200 testUpdateTeam :: TestM () testUpdateTeam = do From 99448d3948fe23b0146eb4370aa8a0357c22f80b Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 15 Feb 2022 11:53:55 +0100 Subject: [PATCH 42/58] Specify how a message to a deleted legalhold device is refused to be sent (#2131) The test was a bit misleading about the assumptions regarding this. --- .../specify-sending-to-deleted-legalhold-device | 1 + .../galley/test/integration/API/Teams/LegalHold.hs | 13 +++++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) create mode 100644 changelog.d/5-internal/specify-sending-to-deleted-legalhold-device diff --git a/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device b/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device new file mode 100644 index 00000000000..d4eccbc8486 --- /dev/null +++ b/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device @@ -0,0 +1 @@ +Specify (in a test) how a message to a deleted legalhold device is refused to be sent. diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 20b0d8ce6c0..22c7e9398cf 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -817,6 +817,8 @@ testNoConsentBlockOne2OneConv :: HasCallStack => Bool -> Bool -> Bool -> Bool -> testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnection = do -- FUTUREWORK: maybe regular user for legalholder? (legalholder :: UserId, tid) <- createBindingTeam + regularClient <- randomClient legalholder (head someLastPrekeys) + peer :: UserId <- if teamPeer then fst <$> createBindingTeam else randomUser galley <- view tsGalley @@ -895,7 +897,8 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect peer peerClient (qUnqualified convId) - [ (legalholder, legalholderLHDevice, "cipher") + [ (legalholder, legalholderLHDevice, "cipher"), + (legalholder, regularClient, "cipher") ] !!! do const 404 === statusCode @@ -928,10 +931,16 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect peer peerClient (qUnqualified convId) - [ (legalholder, legalholderLHDevice, "cipher") + [ (legalholder, legalholderLHDevice, "cipher"), + (legalholder, regularClient, "cipher") ] !!! do const 201 === statusCode + assertMismatchWithMessage + (Just "legalholderLHDevice is deleted") + [] + [] + [(legalholder, Set.singleton legalholderLHDevice)] data GroupConvAdmin = LegalholderIsAdmin From b435f3083b8fa5e76b5f3b76b1db40cfa898f148 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Feb 2022 14:20:43 +0100 Subject: [PATCH 43/58] Build ubuntu20 docker images with cabal instead of stack (#2119) --- build/ubuntu/Dockerfile.fast-intermediate | 6 ++++-- build/ubuntu/Dockerfile.intermediate | 4 ++-- changelog.d/5-internal/cabal-builds | 1 + 3 files changed, 7 insertions(+), 4 deletions(-) create mode 100644 changelog.d/5-internal/cabal-builds diff --git a/build/ubuntu/Dockerfile.fast-intermediate b/build/ubuntu/Dockerfile.fast-intermediate index a4563d0ffca..28668d439da 100644 --- a/build/ubuntu/Dockerfile.fast-intermediate +++ b/build/ubuntu/Dockerfile.fast-intermediate @@ -1,5 +1,5 @@ ARG builder=quay.io/wire/ubuntu20-builder -ARG deps=quay.io/wire/ubuntu-deps +ARG deps=quay.io/wire/ubuntu20-deps:develop #--- Builder stage --- FROM ${builder} as builder @@ -8,7 +8,9 @@ WORKDIR /wire-server/ COPY . /wire-server/ -RUN make clean fast +RUN echo "optimization: False" > ./cabal.project.local && \ + ./hack/bin/cabal-project-local-template.sh "ghc-options: -O0" >> ./cabal.project.local && \ + WIRE_BUILD_WITH_CABAL=1 make clean install #--- Minified stage --- FROM ${deps} diff --git a/build/ubuntu/Dockerfile.intermediate b/build/ubuntu/Dockerfile.intermediate index 61562ab4f07..58edbc4415a 100644 --- a/build/ubuntu/Dockerfile.intermediate +++ b/build/ubuntu/Dockerfile.intermediate @@ -6,7 +6,7 @@ # docker build -f build/alpine/Dockerfile.intermediate ARG builder=quay.io/wire/ubuntu20-builder -ARG deps=quay.io/wire/ubuntu20-deps +ARG deps=quay.io/wire/ubuntu20-deps:develop #--- Builder stage --- FROM ${builder} as builder @@ -15,7 +15,7 @@ WORKDIR /wire-server/ COPY . /wire-server/ -RUN make clean install +RUN WIRE_BUILD_WITH_CABAL=1 make clean install #--- Minified stage --- FROM ${deps} diff --git a/changelog.d/5-internal/cabal-builds b/changelog.d/5-internal/cabal-builds new file mode 100644 index 00000000000..18ff94be6bf --- /dev/null +++ b/changelog.d/5-internal/cabal-builds @@ -0,0 +1 @@ +Build ubuntu20 docker images with cabal instead of stack From ae447b1798bad2e68060f93c694589f5cd29268a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 15 Feb 2022 15:28:14 +0100 Subject: [PATCH 44/58] 2nd Auth Factor for "Create authentication token for SCIM service" and "login" API (#2124) (types & swagger only, no implementation) Co-authored-by: fisx --- changelog.d/0-release-notes/pr-2124 | 1 + changelog.d/1-api-changes/pr-2124 | 1 + charts/nginz/values.yaml | 4 ++ deploy/services-demo/conf/nginz/nginx.conf | 5 +++ libs/api-bot/src/Network/Wire/Bot/Monad.hs | 2 +- .../src/Wire/API/Routes/Public/Brig.hs | 8 ++++ libs/wire-api/src/Wire/API/User.hs | 40 +++++++++++++++++++ libs/wire-api/src/Wire/API/User/Activation.hs | 1 + libs/wire-api/src/Wire/API/User/Auth.hs | 19 ++++++--- libs/wire-api/src/Wire/API/User/Scim.hs | 12 ++++-- .../golden/Test/Wire/API/Golden/Generated.hs | 8 +++- .../Wire/API/Golden/Generated/Login_user.hs | 10 +++++ .../SndFactorPasswordChallengeAction_user.hs | 28 +++++++++++++ .../test/golden/testObject_Login_user_1.json | 3 +- .../test/golden/testObject_Login_user_12.json | 3 +- .../test/golden/testObject_Login_user_20.json | 3 +- .../test/golden/testObject_Login_user_3.json | 3 +- .../test/golden/testObject_Login_user_5.json | 3 +- .../test/golden/testObject_Login_user_6.json | 3 +- .../test/golden/testObject_Login_user_7.json | 3 +- .../test/golden/testObject_Login_user_8.json | 3 +- .../test/golden/testObject_Login_user_9.json | 3 +- ...ct_SndFactorPasswordChallengeAction_user_1 | 1 + ...ct_SndFactorPasswordChallengeAction_user_2 | 1 + .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 2 + libs/wire-api/wire-api.cabal | 1 + services/brig/src/Brig/API/Public.hs | 8 ++++ services/brig/src/Brig/User/API/Auth.hs | 5 ++- services/brig/src/Brig/User/Auth.hs | 7 +++- .../brig/test/integration/API/User/Account.hs | 2 +- .../brig/test/integration/API/User/Auth.hs | 6 +-- .../integration/API/User/PasswordReset.hs | 2 +- .../integration/API/UserPendingActivation.hs | 3 +- services/brig/test/integration/Util.hs | 2 +- .../Test/Spar/Scim/AuthSpec.hs | 39 +++++++++++------- services/spar/test-integration/Util/Email.hs | 2 +- services/spar/test/Arbitrary.hs | 2 +- 37 files changed, 204 insertions(+), 45 deletions(-) create mode 100644 changelog.d/0-release-notes/pr-2124 create mode 100644 changelog.d/1-api-changes/pr-2124 create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SndFactorPasswordChallengeAction_user.hs create mode 100644 libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_1 create mode 100644 libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_2 diff --git a/changelog.d/0-release-notes/pr-2124 b/changelog.d/0-release-notes/pr-2124 new file mode 100644 index 00000000000..7e2b460e70c --- /dev/null +++ b/changelog.d/0-release-notes/pr-2124 @@ -0,0 +1 @@ +This change requires an nginz upgrade to expose the newly added endpoint for sending a verification code. diff --git a/changelog.d/1-api-changes/pr-2124 b/changelog.d/1-api-changes/pr-2124 new file mode 100644 index 00000000000..9cebece307e --- /dev/null +++ b/changelog.d/1-api-changes/pr-2124 @@ -0,0 +1 @@ +New endpoint (`POST /verification-code/send`) for generating and sending a verification code for 2nd factor authentication actions. diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 3cf782871e6..37a6ef5418f 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -281,6 +281,10 @@ nginx_conf: - path: ~* ^/teams/([^/]*)/search$ envs: - all + - path: /verification-code/send + envs: + - all + disable_zauth: true galley: - path: /conversations/code-check disable_zauth: true diff --git a/deploy/services-demo/conf/nginz/nginx.conf b/deploy/services-demo/conf/nginz/nginx.conf index aa85a7cca58..0b86eb2c1bf 100644 --- a/deploy/services-demo/conf/nginz/nginx.conf +++ b/deploy/services-demo/conf/nginz/nginx.conf @@ -219,6 +219,11 @@ http { proxy_pass http://brig; } + location /verification-code/send { + include common_response_no_zauth.conf; + proxy_pass http://brig; + } + ## brig authenticated endpoints location /self { diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index 79bc2792167..da64c0cebe6 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -689,7 +689,7 @@ mkBot :: BotTag -> User -> PlainTextPassword -> BotNet Bot mkBot tag user pw = do log Info $ botLogFields (userId user) tag . msg (val "Login") let ident = fromMaybe (error "No email") (userEmail user) - let cred = PasswordLogin (LoginByEmail ident) pw Nothing + let cred = PasswordLogin (LoginByEmail ident) pw Nothing Nothing auth <- login cred >>= maybe (throwM LoginFailed) return aref <- nextAuthRefresh auth env <- BotNet ask diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 525b3aabf9b..9859e947211 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -172,6 +172,14 @@ type UserAPI = :> ReqBody '[JSON] ListUsersQuery :> Post '[JSON] [UserProfile] ) + :<|> Named + "send-verification-code" + ( Summary "Send a verification code to a given email address." + :> "verification-code" + :> "send" + :> ReqBody '[JSON] SendVerificationCode + :> MultiVerb 'POST '[JSON] '[RespondEmpty 200 "Verification code sent."] () + ) type SelfAPI = Named diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 5d11283717c..be3dd749a2d 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -97,6 +97,11 @@ module Wire.API.User modelUser, modelUserIdList, modelVerifyDelete, + + -- * 2nd factor auth + SndFactorPasswordChallengeAction (..), + SendVerificationCode (..), + TeamFeatureSndFPasswordChallengeNotImplemented (..), ) where @@ -1151,3 +1156,38 @@ instance S.ToSchema ListUsersQuery where & S.description ?~ "exactly one of qualified_ids or qualified_handles must be provided." & S.properties .~ InsOrdHashMap.fromList [("qualified_ids", uids), ("qualified_handles", handles)] & S.example ?~ toJSON (ListUsersByIds [Qualified (Id UUID.nil) (Domain "example.com")]) + +----------------------------------------------------------------------------- +-- SndFactorPasswordChallenge + +-- | remove this type once we have an implementation in order to find all the places where we need to touch code. +data TeamFeatureSndFPasswordChallengeNotImplemented + = TeamFeatureSndFPasswordChallengeNotImplemented + +data SndFactorPasswordChallengeAction = GenerateScimToken | Login + deriving stock (Eq, Show, Enum, Bounded, Generic) + deriving (Arbitrary) via (GenericUniform SndFactorPasswordChallengeAction) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema SndFactorPasswordChallengeAction) + +instance ToSchema SndFactorPasswordChallengeAction where + schema = + enum @Text "SndFactorPasswordChallengeAction" $ + mconcat + [ element "generate_scim_token" GenerateScimToken, + element "login" Login + ] + +data SendVerificationCode = SendVerificationCode + { svcAction :: SndFactorPasswordChallengeAction, + svcEmail :: Email + } + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform SendVerificationCode) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema SendVerificationCode + +instance ToSchema SendVerificationCode where + schema = + object "SendVerificationCode" $ + SendVerificationCode + <$> svcAction .= field "action" schema + <*> svcEmail .= field "email" schema diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index cd85f248857..a4a2f2a0565 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -80,6 +80,7 @@ newtype ActivationKey = ActivationKey -- | A random code for use with an 'ActivationKey' that is usually transmitted -- out-of-band, e.g. via email or sms. +-- FUTUREWORK(leif): rename to VerificationCode newtype ActivationCode = ActivationCode {fromActivationCode :: AsciiBase64Url} deriving stock (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index a718f24cb7a..e8fac171d23 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -66,6 +66,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (UTCTime) import Imports import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) +import Wire.API.User.Activation import Wire.API.User.Identity (Email, Phone) -------------------------------------------------------------------------------- @@ -73,7 +74,7 @@ import Wire.API.User.Identity (Email, Phone) -- | Different kinds of logins. data Login - = PasswordLogin LoginId PlainTextPassword (Maybe CookieLabel) + = PasswordLogin LoginId PlainTextPassword (Maybe CookieLabel) (Maybe ActivationCode) | SmsLogin Phone LoginCode (Maybe CookieLabel) deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Login) @@ -103,11 +104,19 @@ modelLogin = Doc.defineModel "Login" $ do \to allow targeted revocation of all cookies granted to that \ \specific client." Doc.optional + Doc.property "verification_code" Doc.string' $ do + Doc.description "The login verification code for 2nd factor authentication. Required only if SndFactorPasswordChallenge is enabled for the team/server." + Doc.optional instance ToJSON Login where toJSON (SmsLogin p c l) = object ["phone" .= p, "code" .= c, "label" .= l] - toJSON (PasswordLogin login password label) = - object ["password" .= password, "label" .= label, loginIdPair login] + toJSON (PasswordLogin login password label mbCode) = + object + [ "password" .= password, + "label" .= label, + loginIdPair login, + "verification_code" .= mbCode + ] instance FromJSON Login where parseJSON = withObject "Login" $ \o -> do @@ -117,10 +126,10 @@ instance FromJSON Login where SmsLogin <$> o .: "phone" <*> o .: "code" <*> o .:? "label" Just pw -> do loginId <- parseJSON (Object o) - PasswordLogin loginId pw <$> o .:? "label" + PasswordLogin loginId pw <$> (o .:? "label") <*> (o .:? "verification_code") loginLabel :: Login -> Maybe CookieLabel -loginLabel (PasswordLogin _ _ l) = l +loginLabel (PasswordLogin _ _ l _) = l loginLabel (SmsLogin _ _ l) = l -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index e1255157aa9..a96a61ed070 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -83,6 +83,7 @@ import Web.Scim.Schema.Schema (Schema (CustomSchema)) import qualified Web.Scim.Schema.Schema as Scim import qualified Web.Scim.Schema.User as Scim import qualified Web.Scim.Schema.User as Scim.User +import Wire.API.User.Activation import Wire.API.User.Identity (Email) import Wire.API.User.Profile as BT import qualified Wire.API.User.RichInfo as RI @@ -365,7 +366,9 @@ data CreateScimToken = CreateScimToken { -- | Token description (as memory aid for whoever is creating the token) createScimTokenDescr :: !Text, -- | User password, which we ask for because creating a token is a "powerful" operation - createScimTokenPassword :: !(Maybe PlainTextPassword) + createScimTokenPassword :: !(Maybe PlainTextPassword), + -- | User code (sent by email), for 2nd factor to 'createScimTokenPassword' + createScimTokenCode :: !(Maybe ActivationCode) } deriving (Eq, Show) @@ -373,6 +376,7 @@ instance A.FromJSON CreateScimToken where parseJSON = A.withObject "CreateScimToken" $ \o -> do createScimTokenDescr <- o A..: "description" createScimTokenPassword <- o A..:? "password" + createScimTokenCode <- o A..:? "code" pure CreateScimToken {..} -- Used for integration tests @@ -380,7 +384,8 @@ instance A.ToJSON CreateScimToken where toJSON CreateScimToken {..} = A.object [ "description" A..= createScimTokenDescr, - "password" A..= createScimTokenPassword + "password" A..= createScimTokenPassword, + "code" A..= createScimTokenCode ] -- | Type used for the response of 'APIScimTokenCreate'. @@ -463,7 +468,8 @@ instance ToSchema CreateScimToken where & type_ .~ Just SwaggerObject & properties .~ [ ("description", textSchema), - ("password", textSchema) + ("password", textSchema), + ("code", textSchema) ] & required .~ ["description"] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index 9d9d1b0c614..f0f20bc7e3a 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -189,6 +189,7 @@ import qualified Test.Wire.API.Golden.Generated.ServiceToken_provider import qualified Test.Wire.API.Golden.Generated.Service_provider import qualified Test.Wire.API.Golden.Generated.SimpleMember_user import qualified Test.Wire.API.Golden.Generated.SimpleMembers_user +import qualified Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user import qualified Test.Wire.API.Golden.Generated.TeamBinding_team import qualified Test.Wire.API.Golden.Generated.TeamContact_user import qualified Test.Wire.API.Golden.Generated.TeamConversationList_team @@ -1206,5 +1207,10 @@ tests = testGroup "Golden: TeamSearchVisibility_team" $ testObjects [(Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_1, "testObject_TeamSearchVisibility_team_1.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_2, "testObject_TeamSearchVisibility_team_2.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_3, "testObject_TeamSearchVisibility_team_3.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_4, "testObject_TeamSearchVisibility_team_4.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_5, "testObject_TeamSearchVisibility_team_5.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_6, "testObject_TeamSearchVisibility_team_6.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_7, "testObject_TeamSearchVisibility_team_7.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_8, "testObject_TeamSearchVisibility_team_8.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_9, "testObject_TeamSearchVisibility_team_9.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_10, "testObject_TeamSearchVisibility_team_10.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_11, "testObject_TeamSearchVisibility_team_11.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_12, "testObject_TeamSearchVisibility_team_12.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_13, "testObject_TeamSearchVisibility_team_13.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_14, "testObject_TeamSearchVisibility_team_14.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_15, "testObject_TeamSearchVisibility_team_15.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_16, "testObject_TeamSearchVisibility_team_16.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_17, "testObject_TeamSearchVisibility_team_17.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_18, "testObject_TeamSearchVisibility_team_18.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_19, "testObject_TeamSearchVisibility_team_19.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibility_team.testObject_TeamSearchVisibility_team_20, "testObject_TeamSearchVisibility_team_20.json")], testGroup "Golden: TeamSearchVisibilityView_team" $ - testObjects [(Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_1, "testObject_TeamSearchVisibilityView_team_1.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_2, "testObject_TeamSearchVisibilityView_team_2.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_3, "testObject_TeamSearchVisibilityView_team_3.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_4, "testObject_TeamSearchVisibilityView_team_4.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_5, "testObject_TeamSearchVisibilityView_team_5.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_6, "testObject_TeamSearchVisibilityView_team_6.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_7, "testObject_TeamSearchVisibilityView_team_7.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_8, "testObject_TeamSearchVisibilityView_team_8.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_9, "testObject_TeamSearchVisibilityView_team_9.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_10, "testObject_TeamSearchVisibilityView_team_10.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_11, "testObject_TeamSearchVisibilityView_team_11.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_12, "testObject_TeamSearchVisibilityView_team_12.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_13, "testObject_TeamSearchVisibilityView_team_13.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_14, "testObject_TeamSearchVisibilityView_team_14.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_15, "testObject_TeamSearchVisibilityView_team_15.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_16, "testObject_TeamSearchVisibilityView_team_16.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_17, "testObject_TeamSearchVisibilityView_team_17.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_18, "testObject_TeamSearchVisibilityView_team_18.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_19, "testObject_TeamSearchVisibilityView_team_19.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_20, "testObject_TeamSearchVisibilityView_team_20.json")] + testObjects [(Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_1, "testObject_TeamSearchVisibilityView_team_1.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_2, "testObject_TeamSearchVisibilityView_team_2.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_3, "testObject_TeamSearchVisibilityView_team_3.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_4, "testObject_TeamSearchVisibilityView_team_4.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_5, "testObject_TeamSearchVisibilityView_team_5.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_6, "testObject_TeamSearchVisibilityView_team_6.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_7, "testObject_TeamSearchVisibilityView_team_7.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_8, "testObject_TeamSearchVisibilityView_team_8.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_9, "testObject_TeamSearchVisibilityView_team_9.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_10, "testObject_TeamSearchVisibilityView_team_10.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_11, "testObject_TeamSearchVisibilityView_team_11.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_12, "testObject_TeamSearchVisibilityView_team_12.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_13, "testObject_TeamSearchVisibilityView_team_13.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_14, "testObject_TeamSearchVisibilityView_team_14.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_15, "testObject_TeamSearchVisibilityView_team_15.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_16, "testObject_TeamSearchVisibilityView_team_16.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_17, "testObject_TeamSearchVisibilityView_team_17.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_18, "testObject_TeamSearchVisibilityView_team_18.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_19, "testObject_TeamSearchVisibilityView_team_19.json"), (Test.Wire.API.Golden.Generated.TeamSearchVisibilityView_team.testObject_TeamSearchVisibilityView_team_20, "testObject_TeamSearchVisibilityView_team_20.json")], + testGroup "Golden: SndFactorPasswordChallengeAction_user" $ + testObjects + [ (Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user.testObject_SndFactorPasswordChallengeAction_user_1, "testObject_SndFactorPasswordChallengeAction_user_1"), + (Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user.testObject_SndFactorPasswordChallengeAction_user_2, "testObject_SndFactorPasswordChallengeAction_user_2") + ] ] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs index 7e35d440095..45c0896958d 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Login_user.hs @@ -23,6 +23,7 @@ import Data.Handle (Handle (Handle, fromHandle)) import Data.Misc (PlainTextPassword (PlainTextPassword)) import Imports (Maybe (Just, Nothing)) import Wire.API.User (Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone)) +import Wire.API.User.Activation (ActivationCode (..)) import Wire.API.User.Auth ( CookieLabel (CookieLabel, cookieLabelText), Login (..), @@ -38,6 +39,7 @@ testObject_Login_user_1 = "\b5Ta\61971\150647\186716fa&\1047748o!ov\SI\1100133i\DC4\ETXY\SOR\991323\1086159Ta^s\ETB\SI[\189068\988899\26508\CAN6\STXp\1069462-9\983823&\NAK\1052068]^\13044;>-Z$Z\NAK\r\1101550a\RS%\NUL:\188721\47674\157548?e]\ETX \142608 C\SOH\SIS%8m\1091987V\147131[\1006262\&6\171610\1011219\164656SX\n%\1061259*>\t+\132427Y\989558\993346\GSU\1067541\&6TU!*\40114\&90\1055516\RSV\162483N\t*\EOT{I<\1084278\SOH\183116!c\\\n\1107501\183146\DC1,-xX\EMV?\t\168648\1054239\DC2\DEL1\SOHu\SOH\63459\53061\SO+h\ACK::\RS\21356_g,\SO*\v\DC4\1093710HFF\188918\1081075fF\ESC2\SOHT\DC1)\fc\35905l\1061547\f#~\STX]\1035086/Or)kY\1031423\SOHNCk\1067954\&5\1083470x=H\NUL\23760\1058646\1099097E/$\DELpbi\137522\FSKi\15676\1018134\t7\"OL\54208\7516\&5\43466\NUL(\1030852\166514\SOH\149343\994835\25513C==\GSTV3\DELl6\999006.Z)$\16723|\172732\1090303J;O\GSbw\vI\1101024I\SYN\DC2^\149630\STX3%i\EMW\138614\DC4\1113619tsL5\147087W\96700(_,\1091179*\1041287rckx\SOH\SIs\SOHJd\140574\SYNev.\DC4\DLE\99082.\1106785\996992\143448\US_\ETBf\STX\SO\DC3\1043748\&6O\DC1Q\SOH'\GS,|]W\SIa\62568\151062.\v\aH&-L\DC2+\147179\1095524\EOTm)\19925\181147\183368!\185223\142946m\DC4\DC3\1034282m\GS\185509>>\"NDw\1076877hY\1033831sFKz^ \1108187\&5Qec\NAK}|\1108194.Q\173114imb\1027220 p;\1089082\SYN\1065748kF\1102854r8o\DC1" ) (Just (CookieLabel {cookieLabelText = "r"})) + Nothing testObject_Login_user_2 :: Login testObject_Login_user_2 = @@ -54,6 +56,7 @@ testObject_Login_user_3 = "&\RS\DC4\1104052Z\11418n\SO\158691\1010906/\127253'\1063038m\1010345\"\9772\138717\RS(&\996590\SOf1Wf'I\SI\100286\1047270\1033961\DC1Jq\1050673Y\\Bedu@\1014647c\1003986D\53211\1050614S\144414\ETX\ETXW>\1005358\DC4\rSO8FXy\166833a\EM\170017\SUBNF\158145L\RS$5\NULk\RSz*s\148780\157980\v\175417\"SY\DEL\STX\994691\1103514ub5q\ENQ\1014299\vN.\t\183536:l\1105396\RS\1027721\a\168001\SO\vt\1098704W\SYN\1042396\1109979\a'v\ETB\64211\NAK\59538\STX \NAK\STX\49684,\1111630x\1047668^\1067127\27366I;\NAKb\1092049o\162763_\190546MME\1022528\SI\1096252H;\SO\ETBs\SO\1065937{Knlrd;\35750\DC4\SI\1075008TO\1090529\999639U\48787\1099927t\1068680^y\17268u$\DC1Jp\1054308\164905\164446\STX\"\1095399*\SO\1004302\32166\990924X\1098844\ETXsK}\b\143918\NUL0\988724\&12\171116\tM052\189551\EOT0\RS\986138\1084688{ji\ESC\1020800\27259&t \SI\ESCy\aL\136111\131558\994027\r\1054821ga,\DC4do,tx[I&\DC4h\DLE\ETX\DLEBpm\1002292-\a]/ZI\1033117q]w3n\46911e\23692kYo5\1090844'K\1089820}v\146759;\1018792\\=\41264\&8g\DLEg*has\44159\1006118\DC3\USYg?I\19462\NAKaW2\150415m\t}h\155161RbU\STX\ETBlz2!\DC3JW5\ESC\1026156U\SOg,rpO\5857]0\ESC\479\1005443F\SI\1045994\RS\SO\11908rl\1104306~\ACK+Mn{5\993784a\EM2\v{jM\ETBT\1058105$\DC1\1099974\GSj_~Z\1007141P\SOH\EOTo@TJhk\EOT\ETBk:-\96583[p\DLE\DC1\RS'\r\STXQ,,\1016866?H\rh\30225\rj\147982\DC2\\(u\ESCu\154705\1002696o\DC4\988492\1103465\1052034\DC1q\GS-\b\40807\DC1qW>\fys\8130,'\159954<" ) (Just (CookieLabel {cookieLabelText = "\1082362\66362>XC"})) + (Just (ActivationCode "123456")) testObject_Login_user_4 :: Login testObject_Login_user_4 = @@ -76,6 +79,7 @@ testObject_Login_user_5 = "\120347\184756DU\1035832hp\1006715t~\DC2\SOH\STX*\1053210y1\1078382H\173223{e\\S\SO?c_7\t\DC4X\135187\&6\172722E\100168j\SUB\t\SYN\1088511>HO]60\990035\ETX\"+w,t\1066040\ak(b%u\151197`>b\1028272e\ACKc\151393\1107996)\12375\&7\1082464`\186313yO+v%\1033664\rc<\65764\&2>8u\1094258\1080669\1113623\75033a\179193\NAK=\EOT\1077021\&8R&j\1042630\ESC\t4sj-\991835\40404n\136765\1064089N\GS\\\1026123\72288\&5\r\97004(P!\DEL\29235\26855\b\1067772Mr~\65123\EMjt>Z\GS~\140732A\1031358\SO\\>\DC16\">%\45860\1084751I@u5\187891\vrY\r;7\1071052#\1078407\1016286\CAN'\63315\1041397\EM_I_zY\987300\149441\EMd\1039844cd\DEL\1061999\136326Cp3\26325\GSXj\n\46305jy\44050\58825\t-\19065\43336d\1046547L\SUBYF\ACKPOL\54766\DC2\DC1\DC1\DC2*\rH\DLE(?\DC3F\25820\DLE\r]\1069451j\170177 @\ENQT\1100685s\FSF2\NAK]8\a\DC3!\NAKW\176469\1110834K\1025058\1112222_%\1001818\1113069'\1098149\70360(#\SOHky\t\ETB!\17570\NAK\DC4\ESC{\119317U2LS'" ) (Just (CookieLabel {cookieLabelText = "LGz%\119949j\f\RS/\SOH"})) + (Just (ActivationCode "123456")) testObject_Login_user_6 :: Login testObject_Login_user_6 = @@ -85,6 +89,7 @@ testObject_Login_user_6 = "K?)V\148106}_\185335\1060952\fJ3!\986581\1062221\51615\166583\1071064\a\1015675\SOH7\\#z9\133503\1081163\985690\1041362\EM\DC3\156174'\r)~Ke9+\175606\175778\994126M\1099049\"h\SOHTh\EOT`;\ACK\1093024\ENQ\1026474'e{\FSv\40757\US\143355*\16236\1076902\52767:E]:R\1093823K}l\1111648Y\51665\1049318S~\EOT#T\1029316\&1hIWn\v`\45455Kb~\ESC\DLEdT\FS\SI\1092141f\ETBY7\DEL\RS\131804\t\998971\13414\48242\GSG\DC3BH#\DEL\\RAd\166099g\1072356\1054332\SIk&\STXE\22217\FS\FS\FS$t\1001957:O\1098769q}_\1039296.\SOH\DC4\STX\157262c`L>\1050744l\1086722m'BtB5\1003280,t\"\1066340\&9(#\ENQ4\SIIy>\1031158\1100542\GSbf\"i\ETB\14367a\1086113C@\1078844\1092137\32415\NAK\999161\23344*N\SYN\ESC:iXibA\136851\169508q\1048663]:9r\63027\73801\NUL\1050763\USCN\US\147710\1048697\1016861eR\RSZbD5!8N\ESCV\7344\ACK\173064\SUBuz\1053950\188308~\ESC\SI%{3I/F\25232/DMS\US>o\187199\63000Z\1108766\GS[K\184801\94661\1088369\995346\ESCO-4\CAN\US\FSZp" ) (Just (CookieLabel {cookieLabelText = "\1014596'\998013KW\\\NUL\DC4"})) + (Just (ActivationCode "123456")) testObject_Login_user_7 :: Login testObject_Login_user_7 = @@ -94,6 +99,7 @@ testObject_Login_user_7 = "&\991818\1023244\83352\STXJ<-~\STX>\v\74228\151871\&5QN\53968\166184ql\NAK\74290\&3}{\DC3\173242S\22739;\t7\183958_F~D*f\1049940)\1067330-9\20699\&7GK= %\RS@kOF#\179945\1094401\124994\&8_\42309\GSL\37698\ETX\1047946\&0Wl1A`LYz\USy\20728\SUBo\ESC[\DC4\bt\66640a\ETXs~\USF\175140G`$\vG\DC1\1044421\128611/\1014458C>\SI" ) (Just (CookieLabel {cookieLabelText = "\SO\NAKeC/"})) + (Just (ActivationCode "123456")) testObject_Login_user_8 :: Login testObject_Login_user_8 = @@ -103,6 +109,7 @@ testObject_Login_user_8 = "z>\1088515\1024903/\137135\1092812\b%$\1037736\143620:}\t\CAN\1058585\1044157)\12957\1005180s\1006270\CAN}\40034\EM[\41342\vX#VG,df4\141493\&8m5\46365OTK\144460\37582\DEL\44719\9670Z\"ZS\ESCms|[Q%\1088673\ENQW\\\1000857C\185096+\1070458\4114\17825v\180321\41886){\1028513\DEL\143570f\187156}:X-\b2N\EM\USl\127906\49608Y\1071393\1012763r2.1\49912\EOT+\137561\DC3\145480]'\1028275s\997684\42805.}\185059o\992118X\132901\11013\r\SUBNq6\1019605'\fd\RS\14503\1097628,:%\t\151916\73955QD\1086880\ESC(q4KDQ2zcI\DLE>\EM5\993596\&1\fBkd\DC3\ACK:F:\EOT\100901\11650O N\FS,N\1054390\1000247[h\DEL9\5932:xZ=\f\1085312\DC3u\RS\fe#\SUB^$lkx\32804 \rr\SUBJ\1013606\1017057\FSR][_5\NAK\58351\11748\35779\&5\24821\1055669\996852\37445K!\1052768eRR%\32108+h~1\993198\35871lTzS$\DLE\1060275\"*\1086839pmRE\DC3(\US^\8047Jc\10129\1071815i\n+G$|\993993\156283g\FS\fgU3Y\119068\ACKf)\1093562\SYN\78340\1100638/\NULPi\43622{\1048095j\1083269\FS9\132797\1024684\32713w$\45599\126246)Si\167172\29311FX\1057490j{`\44452`\999383\159809\&4u%\1070378P*\1057403\25422\DELC\RSR\SYN-\51098\1011541g\68666:S>c\15266\132940\DLEY\1066831~a)YW_J\1063076P\a+ U\1084883j\EMk\SOH\1096984\DC1\18679e\172760\175328,\5135g@\DC2\GSHXl.\ETB\153793\&2\DC3mY\1054891\tv?L8L\1074044N\133565\nb1j\1044024\148213xfQ=\\\ENQe\995818\1023862U\DC2p{\SO\1099404jd^@U\994269tP.\DC2Y%R`a\r\160622\&7}HnUf\132856m^7:\NAK=\52348>l\95313hwp27\149950jE\fx=!.\DC3]Ar\tw\DC4&\SUBk\194572s\1042820\4498I\146071\61461\1060645dsY\DLE\181922dX.\146295i]\151113\1028288\rWS\USU\1098732\SUB\49884\1083906\DLE\STXN~-\SO6\190031\1110322\\O\185165Jc\1052359\1071278\NULHSo\DLE-W\DC36\170321I\1068712)\99800={\99796h\27961\61707M\1022570FwJQ\1111976ck\SUB\CAN|UV-\NAK\SOH|\DC4;\f\156907\145795\ENQS\NAK.B\"D\163007#o*\126577\32988m\RS\1049834B3Gg;\DC1\\\180659\1098926\ENQ B^\SI\152630$e\39220\170037>fMgC\187276,o\128488\\?\1033955~/s\SOH?MMc;D18Ne\EOT\CAN)*\STX\GS\16268\f\RSUc\EOTV9&c\3517\a\986228a'PPG\100445\179638>[\3453\&2\64964Xc\131306[0\1002646\b\99652B\DC1[\1029237\GS\19515\US\EMs-u\ETBs\1067133\1005008\161663n\1072320?\1045643ck\DC48XC\174289\RSI2\2862\STX\DLEM\ESC\n?<\\\DC3E\72219\GS\n$cyS\136198!,\v9\ETB/\DC1\62324?P\ETB\41758\DC2\999537~\1058761W-W4K8.\DC27\EML\1078049h\SI}t+H\SUB\ESCX\120523s\EOTt\177703taa\GS\f\152365(v\1024552M\ESCvg3P1\1032835\57603]g\3933\&4T\NAK$\38212);\\8\1109165\nK\NAK}D'^fJ'\143205e\174052\39597!\EM.\DC2{\\CEp\1045384\ETBk_\1083904\18397\164138\1063468]MG$\187650[E\1112126\b\1073487{b\50650\ESC^b@W\NAK$\FS<\1023895&\155992R\ACKJ\SI\1093108\1101041\41438n\1007134\&8]\148288\ENQ}|k\STX\CANQ\USI\a\CANDZ\1062877\NUL\50197rb\18947\&3G%\FS\162081\EOT\NAK4YB0-i\1018065IM\1073908[\1111554:Cr$\99636)L\136837W\40897.x;\41461\1030711\995525\USkb\CANY9)\SYN4\SI\1103461Av.\r\f\1061861\&9{\SO\ETBP\f\33538u\r-9cB4\1016091G\RS\22817\1014740r\128247HcsPm\59419s\120987!|J<\DLE8\FS[\NAKWYAK\75011^\987050c3\1042176\aC\ETX\ETB\1053739Y\DC4f\ACK\1060945!\1032209:RlQ!BX\f=\1070694f\151362\DEL\113727O\ETX\\\"\53275B<\RSLV4g%3\1098063\ACK`\NAK>\n\44626kp\986102\171479\DEL\60526H\20888lyJ\DC2)\1055149(\1027099A\FSh\EOTj\35251\DC4M\ESCP-q\bn\CAN\143310~\GS\EM\"o\21512%*e2\165597L\1023807sy\152913\&2m\GS\1049046{EG]\DC16B+{\983622IYa\1008153\&5,<\ESCX\f\SI\186613\153744E\134407\1011088L<\EMdUO\ETB\SUBZYm\ACK\1086320R\SUB\991954\DC3^\60967s\fu_g\EM?i~}\DELV2\148681R\FS\EOT3j\45841m\1542\1100884\n7S\SIT5j\170914\SI\1015133\141587h\182480Q\146618\59914\DEL\NAKZM\1110574\&02f\129340l!*\SOH\1027033\SOH\1070384\1094775\t\72805\ESCa:q UKEN\RS-\n\ETXH\22365a\1074707\b\37494\"\1035508\149695\1033139R4\ETX\DLE\FS\STX\1004750%\"@\1009369\&6=/x\NULP\EOT\174871/\190041\f\f\1005146?*\fIcKW\DELQ\"\1001726P*\1095849\&6=d\n\157680\RS\1087962\EOT\DC2I\47501U\b=Pc\DLE" ) (Just (CookieLabel {cookieLabelText = "\SI\128787-\125004:\136001\39864\ACK\SO"})) + (Just (ActivationCode "123456")) testObject_Login_user_13 :: Login testObject_Login_user_13 = @@ -187,3 +196,4 @@ testObject_Login_user_20 = "ryzP\DC39\11027-1A)\b,u\8457j~0\1090580\1033743\fI\170254er\DC4V|}'kzG%A;3H\amD\STXU1\NUL^\1043764\DLEO&5u\EOT\SUB\167046\&0A\996223X\DC2\FS7fEt\97366rPvytT\136915!\100713$Q|BI+EM5\NAK\t\DELRKrE\DLE\US\r?.\STX|@1v^\vycpu\n$\DC2\186675\131718-Q\151081\n\r\1033981\68381O\ENQ*\68660Z\USo\EOTn\188565%&\DC3Me*\STX;\DLE034\nv\NAK\140398(\1075494\990138n@\1108345|\48421d\n*\SI\NUL}\NAKA!\1045882\1036527Hx\ETB3\STX{#T|5|GC\1089070z.\USN\1080851\22324\vu\SYN~LP\147583CV\SO q\151952\DC2e8h\USg\1019358;\f\996107\1108688At\1022346)\USG\DC3\166541\39337|\1042043\SI\134073\EOTc~6\DLE:u\165393##^\nn{d\CAN\ng\16237\ESC\US\US~A8};T\RS\NAK)&\b\ACK\1106044\GS(\DC3u;\1094683;=e\1051162\"\40669vCt)o\987006m\43912\78088l1+\1036284[\STXFLx\1080932:\1031973\992752\&71/kE\93787p\DC4Ij\ETB\194985&\SUB^\FSl1\ACK\1019548\ETXW,+3\128058\95671\DLE7\59727\&7rG'\1078914JC9M\1053804\SYN\DC2\44350>~\1016308Y\1062059=i-\fS\172440\156520K2-@\ENQ\f\1108851_1D-&\128386lR\187248/\993988$:\31415:\52267Dg\1015243O\1010173\170117\SO\179807\&2z\NAKq\141547c\FSliJ{\1055925\1060070'BL\168670;\STX\1046844\18443B\NUL\7839b\1072569:w\1108016Ad\SUB6\NAKo\55279\nsPWM{\ETXfW\1018373JT\1021361$\989069\54608\190318\173259u4\1103286\t\34021\1039458\"\153264UM\1084148\1095406\34105\1105325\t\nIn'\1070532\21097\16091\EM\DC1<\v\bW\SI}\141807\b\1072339\1035283\GS`\1094467x\NUL\986937K\FSj\1079287\DC1\SI\168992d\991620k4\SUB\1009876\49943^\58464\1052547\1016875i2=$:[f\1064579\DC2n\NAKJ<=\2028\SI!z\1105364\SON\NAK\EM\180748V\1024876CQ_G\nY#ky\132779k\DC3\ENQ}OC\96566}~M\EMp\ETX\RSx\b\183962\1073008\b8/\DC4?\1081654B\1025870\EOT\SO\DELU\1020905\ESC=%\51062J\168855\ETB\992593\990312\985186\to\1101036X_@@\45111\43952$" ) (Just (CookieLabel {cookieLabelText = "\1055424\r9\998420`\NAKx"})) + (Just (ActivationCode "123456")) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SndFactorPasswordChallengeAction_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SndFactorPasswordChallengeAction_user.hs new file mode 100644 index 00000000000..4daba80e3ae --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/SndFactorPasswordChallengeAction_user.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedLists #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user where + +import Wire.API.User (SndFactorPasswordChallengeAction (..)) + +testObject_SndFactorPasswordChallengeAction_user_1 :: SndFactorPasswordChallengeAction +testObject_SndFactorPasswordChallengeAction_user_1 = GenerateScimToken + +testObject_SndFactorPasswordChallengeAction_user_2 :: SndFactorPasswordChallengeAction +testObject_SndFactorPasswordChallengeAction_user_2 = Login diff --git a/libs/wire-api/test/golden/testObject_Login_user_1.json b/libs/wire-api/test/golden/testObject_Login_user_1.json index 5bcec3392d3..9c1fccea60b 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_1.json +++ b/libs/wire-api/test/golden/testObject_Login_user_1.json @@ -1,5 +1,6 @@ { "email": "4􅄛\u000bEaP@\u0005\n\u001c\u001b󳟬i03!", "label": "r", - "password": "\u00085Ta𤱷𭥜fa&󿳄o!ov\u000f􌥥i\u0014\u0003Y\u000eR󲁛􉋏Ta^s\u0017\u000f[𮊌󱛣枌\u00186\u0002p􅆖-9󰌏&\u0015􀶤]^㋴;>-Z$Z\u0015\r􌻮a\u001e%\u0000:𮄱먺𦝬?e]\u0003 𢴐 C\u0001\u000fS%8m􊦓V𣺻[󵪶6𩹚󶸓𨌰SX\n%􃆋*>\t+𠕋Y󱥶󲡂\u001dU􄨕6TU!*鲲90􁬜\u001eV𧪳N\t*\u0004{I<􈭶\u0001𬭌!c\\\n􎘭𬭪\u0011,-xX\u0019V?\t𩋈􁘟\u00121\u0001u\u0001콅\u000e+h\u0006::\u001e卬_g,\u000e*\u000b\u0014􋁎HFF𮇶􇻳fF\u001b2\u0001T\u0011)\u000cc豁l􃊫\u000c#~\u0002]󼭎/Or)kY󻳿\u0001NCk􄮲5􈡎x=H\u0000峐􂝖􌕙E/$pbi𡤲\u001cKi㴼󸤖\t7\"OL폀ᵜ5꧊\u0000(󻫄𨩲\u0001𤝟󲸓掩C==\u001dTV3l6󳹞.Z)$䅓|𪊼􊋿J;O\u001dbw\u000bI􌳠I\u0016\u0012^𤡾\u00023%i\u0019W𡵶\u0014􏸓tsL5𣺏W𗦼(_,􊙫*󾎇rckx\u0001\u000fs\u0001Jd𢔞\u0016ev.\u0014\u0010𘌊.􎍡󳚀𣁘\u001f_\u0017f\u0002\u000e\u0013󾴤6O\u0011Q\u0001'\u001d,|]W\u000fa𤸖.\u000b\u0007H&-L\u0012+𣻫􋝤\u0004m)䷕𬎛𬱈!𭎇𢹢m\u0014\u0013󼠪m\u001d𭒥>>\"NDw􆺍hY󼙧sFKz^ 􎣛5Qec\u0015}|􎣢.Q𪐺imb󺲔 p;􉸺\u0016􄌔kF􍐆r8o\u0011" + "password": "\u00085Ta𤱷𭥜fa&󿳄o!ov\u000f􌥥i\u0014\u0003Y\u000eR󲁛􉋏Ta^s\u0017\u000f[𮊌󱛣枌\u00186\u0002p􅆖-9󰌏&\u0015􀶤]^㋴;>-Z$Z\u0015\r􌻮a\u001e%\u0000:𮄱먺𦝬?e]\u0003 𢴐 C\u0001\u000fS%8m􊦓V𣺻[󵪶6𩹚󶸓𨌰SX\n%􃆋*>\t+𠕋Y󱥶󲡂\u001dU􄨕6TU!*鲲90􁬜\u001eV𧪳N\t*\u0004{I<􈭶\u0001𬭌!c\\\n􎘭𬭪\u0011,-xX\u0019V?\t𩋈􁘟\u00121\u0001u\u0001콅\u000e+h\u0006::\u001e卬_g,\u000e*\u000b\u0014􋁎HFF𮇶􇻳fF\u001b2\u0001T\u0011)\u000cc豁l􃊫\u000c#~\u0002]󼭎/Or)kY󻳿\u0001NCk􄮲5􈡎x=H\u0000峐􂝖􌕙E/$pbi𡤲\u001cKi㴼󸤖\t7\"OL폀ᵜ5꧊\u0000(󻫄𨩲\u0001𤝟󲸓掩C==\u001dTV3l6󳹞.Z)$䅓|𪊼􊋿J;O\u001dbw\u000bI􌳠I\u0016\u0012^𤡾\u00023%i\u0019W𡵶\u0014􏸓tsL5𣺏W𗦼(_,􊙫*󾎇rckx\u0001\u000fs\u0001Jd𢔞\u0016ev.\u0014\u0010𘌊.􎍡󳚀𣁘\u001f_\u0017f\u0002\u000e\u0013󾴤6O\u0011Q\u0001'\u001d,|]W\u000fa𤸖.\u000b\u0007H&-L\u0012+𣻫􋝤\u0004m)䷕𬎛𬱈!𭎇𢹢m\u0014\u0013󼠪m\u001d𭒥>>\"NDw􆺍hY󼙧sFKz^ 􎣛5Qec\u0015}|􎣢.Q𪐺imb󺲔 p;􉸺\u0016􄌔kF􍐆r8o\u0011", + "verification_code": null } diff --git a/libs/wire-api/test/golden/testObject_Login_user_12.json b/libs/wire-api/test/golden/testObject_Login_user_12.json index 8a64a9fb2f7..eaf85348770 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_12.json +++ b/libs/wire-api/test/golden/testObject_Login_user_12.json @@ -1,5 +1,6 @@ { "label": "\u000f🜓-𞡌:𡍁鮸\u0006\u000e", "password": "n􋜩Q𩗀\u001b󵅀&Q/\rdꠚ\u001f\u0004w2C\u0006􁹬𫝔\u0004\u0004v󶥜\u0008f,b\u0002󷜰'𪹐C]G듡󸓯𮤾4\u0000Y.𪘲\u000e3sI菌F􈲾5剑rG/:\"󷣦X띟6\u001c:\u0018\u0007eYwWT􈦚𡛑Msbm\u0015@󰗜󷜉\u0004^\u001c𣹘\u0015@\u0005>\u000c\u001eUc\u0004V9&cල\u0007󰱴a'PPG𘡝𫶶>[ൽ2ﷄXc𠃪[0󴲖\u0008𘕄B\u0011[󻑵\u001d䰻\u001f\u0019s-u\u0017s􄡽󵗐𧝿n􅳀?󿒋ck\u00148XC𪣑\u001eI2ମ\u0002\u0010M\u001b\n?<\\\u0013E𑨛\u001d\n$cyS𡐆!,\u000b9\u0017/\u0011?P\u0017ꌞ\u0012󴁱~􂟉W-W4K8.\u00127\u0019L􇌡h\u000f}t+H\u001a\u001bX𝛋s\u0004t𫘧taa\u001d\u000c𥌭(v󺈨M\u001bvg3P1󼊃]gཝ4T\u0015$镄);\\8􎲭\nK\u0015}D'^fJ'𢽥e𪟤骭!\u0019.\u0012{\\CEp󿎈\u0017k_􈨀䟝𨄪􃨬]MG$𭴂[E􏠾\u0008􆅏{b엚\u001b^b@W\u0015$\u001c<󹾗&𦅘R\u0006J\u000f􊷴􌳱ꇞn󵸞8]𤍀\u0005}|k\u0002\u0018Q\u001fI\u0007\u0018DZ􃟝\u0000쐕rb䨃3G%\u001c𧤡\u0004\u00154YB0-i󸣑IM􆋴[􏘂:Cr$𘔴)L𡚅W鿁.x;ꇵ󻨷󳃅\u001fkb\u0018Y9)\u00164\u000f􍙥Av.\r\u000c􃏥9{\u000e\u0017P\u000c茂u\r-9cB4󸄛G\u001e夡󷯔r📷HcsPms𝢛!|J<\u00108\u001c[\u0015WYAK𒔃^󰾪c3󾜀\u0007C\u0003\u0017􁐫Y\u0014f\u0006􃁑!󼀑:RlQ!BX\u000c=􅙦f𤽂𛰿O\u0003\\\"퀛B<\u001eLV4g%3􌅏\u0006`\u0015>\n깒kp󰯶𩷗H冘lyJ\u0012)􁦭(󺰛A\u001ch\u0004j観\u0014M\u001bP-q\u0008n\u0018𢿎~\u001d\u0019\"o合%*e2𨛝L󹼿sy𥕑2m\u001d􀇖{EG]\u00116B+{󰉆IYa󶈙5,<\u001bX\u000c\u000f𭣵𥢐E𠴇󶶐L<\u0019dUO\u0017\u001aZYm\u0006􉍰R\u001a󲋒\u0013^s\u000cu_g\u0019?i~}V2𤓉R\u001c\u00043j댑m؆􌱔\n7S\u000fT5j𩮢\u000f󷵝𢤓h𬣐Q𣲺\u0015ZM􏈮02f🤼l!*\u0001󺯙\u0001􅔰􋑷\t𑱥\u001ba:q UKEN\u001e-\n\u0003H坝a􆘓\u0008鉶\"󼳴𤢿󼎳R4\u0003\u0010\u001c\u0002󵓎%\"@󶛙6=/x\u0000P\u0004𪬗/𮙙\u000c\u000c󵙚?*\u000cIcKWQ\"󴣾P*􋢩6=d\n𦟰\u001e􉧚\u0004\u0012I릍U\u0008=Pc\u0010", - "phone": "+153353668" + "phone": "+153353668", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_20.json b/libs/wire-api/test/golden/testObject_Login_user_20.json index 6e65bd2e8e5..df758baf81d 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_20.json +++ b/libs/wire-api/test/golden/testObject_Login_user_20.json @@ -1,5 +1,6 @@ { "email": "[%@,", "label": "􁫀\r9󳰔`\u0015x", - "password": "ryzP\u00139⬓-1A)\u0008,u℉j~0􊐔󼘏\u000cI𩤎er\u0014V|}'kzG%A;3H\u0007mD\u0002U1\u0000^󾴴\u0010O&5u\u0004\u001a𨲆0A󳍿X\u0012\u001c7fEt𗱖rPvytT𡛓!𘥩$Q|BI+EM5\u0015\tRKrE\u0010\u001f\r?.\u0002|@1v^\u000bycpu\n$\u0012𭤳𠊆-Q𤸩\n\r󼛽𐬝O\u0005*𐰴Z\u001fo\u0004n𮂕%&\u0013Me*\u0002;\u0010034\nv\u0015𢑮(􆤦󱮺n@􎥹|봥d\n*\u000f\u0000}\u0015A!󿕺󽃯Hx\u00173\u0002{#T|5|GC􉸮z.\u001fN􇸓圴\u000bu\u0016~LP𤁿CV\u000e q𥆐\u0012e8h\u001fg󸷞;\u000c󳌋􎫐At󹦊)\u001fG\u0013𨪍馩|󾙻\u000f𠮹\u0004c~6\u0010:u𨘑##^\nn{d\u0018\ng㽭\u001b\u001f\u001f~A8};T\u001e\u0015)&\u0008\u0006􎁼\u001d(\u0013u;􋐛;=e􀨚\"黝vCt)o󰽾mꮈ𓄈l1+󼿼[\u0002FLx􇹤:󻼥󲗰71/kE𖹛p\u0014Ij\u0017蓳&\u001a^\u001cl1\u0006󸺜\u0003W,+3🐺𗖷\u001077rG'􇚂JC9M􁑬\u0016\u0012괾>~󸇴Y􃒫=i-\u000cS𪆘𦍨K2-@\u0005\u000c􎭳_1D-&🖂lR𭭰/󲫄$:窷:찫Dg󷷋O󶧽𩢅\u000e𫹟2z\u0015q𢣫c\u001cliJ{􁲵􂳦'BL𩋞;\u0002󿤼䠋B\u0000ẟb􅶹:w􎠰Ad\u001a6\u0015oퟯ\nsPWM{\u0003fW󸨅JT󹖱$󱞍핐𮝮𪓋u4􍖶\t蓥󽱢\"𥚰UM􈫴􋛮蔹􍶭\t\nIn'􅗄剩㻛\u0019\u0011<\u000b\u0008W\u000f}𢧯\u0008􅳓󼰓\u001d`􋍃x\u0000󰼹K\u001cj􇟷\u0011\u000f𩐠d󲆄k4\u001a󶣔쌗^􀾃󸐫i2=$:[f􃺃\u0012n\u0015J<=߬\u000f!z􍷔\u000eN\u0015\u0019𬈌V󺍬CQ_G\nY#ky𠚫k\u0013\u0005}OC𗤶}~M\u0019p\u0003\u001ex\u0008𬺚􅽰\u00088/\u0014?􈄶B󺝎\u0004\u000eU󹏩\u001b=%읶J𩎗\u0017󲕑󱱨󰡢\to􌳬X_@@뀷ꮰ$" + "password": "ryzP\u00139⬓-1A)\u0008,u℉j~0􊐔󼘏\u000cI𩤎er\u0014V|}'kzG%A;3H\u0007mD\u0002U1\u0000^󾴴\u0010O&5u\u0004\u001a𨲆0A󳍿X\u0012\u001c7fEt𗱖rPvytT𡛓!𘥩$Q|BI+EM5\u0015\tRKrE\u0010\u001f\r?.\u0002|@1v^\u000bycpu\n$\u0012𭤳𠊆-Q𤸩\n\r󼛽𐬝O\u0005*𐰴Z\u001fo\u0004n𮂕%&\u0013Me*\u0002;\u0010034\nv\u0015𢑮(􆤦󱮺n@􎥹|봥d\n*\u000f\u0000}\u0015A!󿕺󽃯Hx\u00173\u0002{#T|5|GC􉸮z.\u001fN􇸓圴\u000bu\u0016~LP𤁿CV\u000e q𥆐\u0012e8h\u001fg󸷞;\u000c󳌋􎫐At󹦊)\u001fG\u0013𨪍馩|󾙻\u000f𠮹\u0004c~6\u0010:u𨘑##^\nn{d\u0018\ng㽭\u001b\u001f\u001f~A8};T\u001e\u0015)&\u0008\u0006􎁼\u001d(\u0013u;􋐛;=e􀨚\"黝vCt)o󰽾mꮈ𓄈l1+󼿼[\u0002FLx􇹤:󻼥󲗰71/kE𖹛p\u0014Ij\u0017蓳&\u001a^\u001cl1\u0006󸺜\u0003W,+3🐺𗖷\u001077rG'􇚂JC9M􁑬\u0016\u0012괾>~󸇴Y􃒫=i-\u000cS𪆘𦍨K2-@\u0005\u000c􎭳_1D-&🖂lR𭭰/󲫄$:窷:찫Dg󷷋O󶧽𩢅\u000e𫹟2z\u0015q𢣫c\u001cliJ{􁲵􂳦'BL𩋞;\u0002󿤼䠋B\u0000ẟb􅶹:w􎠰Ad\u001a6\u0015oퟯ\nsPWM{\u0003fW󸨅JT󹖱$󱞍핐𮝮𪓋u4􍖶\t蓥󽱢\"𥚰UM􈫴􋛮蔹􍶭\t\nIn'􅗄剩㻛\u0019\u0011<\u000b\u0008W\u000f}𢧯\u0008􅳓󼰓\u001d`􋍃x\u0000󰼹K\u001cj􇟷\u0011\u000f𩐠d󲆄k4\u001a󶣔쌗^􀾃󸐫i2=$:[f􃺃\u0012n\u0015J<=߬\u000f!z􍷔\u000eN\u0015\u0019𬈌V󺍬CQ_G\nY#ky𠚫k\u0013\u0005}OC𗤶}~M\u0019p\u0003\u001ex\u0008𬺚􅽰\u00088/\u0014?􈄶B󺝎\u0004\u000eU󹏩\u001b=%읶J𩎗\u0017󲕑󱱨󰡢\to􌳬X_@@뀷ꮰ$", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_3.json b/libs/wire-api/test/golden/testObject_Login_user_3.json index 2bf69d1d46d..54947a4de3b 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_3.json +++ b/libs/wire-api/test/golden/testObject_Login_user_3.json @@ -1,5 +1,6 @@ { "handle": "c2wp.7s5.", "label": "􈏺𐌺>XC", - "password": "&\u001e\u0014􍢴ZⲚn\u000e𦯣󶳚/🄕'􃡾m󶪩\"☬𡷝\u001e(&󳓮\u000ef1Wf'I\u000f𘞾󿫦󼛩\u0011Jq􀠱Y\\Bedu@󷭷c󵇒D쿛􀟶S𣐞\u0003\u0003W>󵜮\u0014\rSO8FXy𨮱a\u0019𩠡\u001aNF𦧁L\u001e$5\u0000k\u001ez*s𤔬𦤜\u000b𪴹\"SY\u0002󲶃􍚚ub5q\u0005󷨛\u000bN.\t𬳰:l􍷴\u001e󺺉\u0007𩁁\u000e\u000bt􌏐W\u0016󾟜􎿛\u0007'v\u0017䀘\u0015\u0002 \u0015\u0002숔,􏙎x󿱴^􄡷櫦I;\u0015b􊧑o𧯋_𮡒MME󹩀\u000f􋨼H;\u000e\u0017s\u000e􄏑{Knlrd;讦\u0014\u000f􆝀TO􊏡󴃗U뺓􌢗t􄺈^y䍴u$\u0011Jp􁙤𨐩𨉞\u0002\"􋛧*\u000e󵌎綦󱻌X􌑜\u0003sK}\u0008𣈮\u00000󱘴12𩱬\tM052𮑯\u00040\u001e󰰚􈴐{ji\u001b󹎀橻&t \u000f\u001by\u0007L𡎯𠇦󲫫\r􁡥ga,\u0014do,tx[I&\u0014h\u0010\u0003\u0010Bpm󴬴-\u0007]/ZI󼎝q]w3n뜿e岌kYo5􊔜'K􊄜}v𣵇;󸮨\\=ꄰ8g\u0010g*has걿󵨦\u0013\u001fYg?I䰆\u0015aW2𤮏m\t}h𥸙RbU\u0002\u0017lz2!\u0013JW5\u001b󺡬U\u000eg,rpOᛡ]0\u001bǟ󵞃F\u000f󿗪\u001e\u000e⺄rl􍦲~\u0006+Mn{5󲧸a\u00192\u000b{jM\u0017T􂔹$\u0011􌣆\u001dj_~Z󵸥P\u0001\u0004o@TJhk\u0004\u0017k:-𗥇[p\u0010\u0011\u001e'\r\u0002Q,,󸐢?H\rh瘑\rj𤈎\u0012\\(u\u001bu𥱑󴳈o\u0014󱕌􍙩􀶂\u0011q\u001d-\u0008齧\u0011qW>\u000cysῂ,'𧃒<" + "password": "&\u001e\u0014􍢴ZⲚn\u000e𦯣󶳚/🄕'􃡾m󶪩\"☬𡷝\u001e(&󳓮\u000ef1Wf'I\u000f𘞾󿫦󼛩\u0011Jq􀠱Y\\Bedu@󷭷c󵇒D쿛􀟶S𣐞\u0003\u0003W>󵜮\u0014\rSO8FXy𨮱a\u0019𩠡\u001aNF𦧁L\u001e$5\u0000k\u001ez*s𤔬𦤜\u000b𪴹\"SY\u0002󲶃􍚚ub5q\u0005󷨛\u000bN.\t𬳰:l􍷴\u001e󺺉\u0007𩁁\u000e\u000bt􌏐W\u0016󾟜􎿛\u0007'v\u0017䀘\u0015\u0002 \u0015\u0002숔,􏙎x󿱴^􄡷櫦I;\u0015b􊧑o𧯋_𮡒MME󹩀\u000f􋨼H;\u000e\u0017s\u000e􄏑{Knlrd;讦\u0014\u000f􆝀TO􊏡󴃗U뺓􌢗t􄺈^y䍴u$\u0011Jp􁙤𨐩𨉞\u0002\"􋛧*\u000e󵌎綦󱻌X􌑜\u0003sK}\u0008𣈮\u00000󱘴12𩱬\tM052𮑯\u00040\u001e󰰚􈴐{ji\u001b󹎀橻&t \u000f\u001by\u0007L𡎯𠇦󲫫\r􁡥ga,\u0014do,tx[I&\u0014h\u0010\u0003\u0010Bpm󴬴-\u0007]/ZI󼎝q]w3n뜿e岌kYo5􊔜'K􊄜}v𣵇;󸮨\\=ꄰ8g\u0010g*has걿󵨦\u0013\u001fYg?I䰆\u0015aW2𤮏m\t}h𥸙RbU\u0002\u0017lz2!\u0013JW5\u001b󺡬U\u000eg,rpOᛡ]0\u001bǟ󵞃F\u000f󿗪\u001e\u000e⺄rl􍦲~\u0006+Mn{5󲧸a\u00192\u000b{jM\u0017T􂔹$\u0011􌣆\u001dj_~Z󵸥P\u0001\u0004o@TJhk\u0004\u0017k:-𗥇[p\u0010\u0011\u001e'\r\u0002Q,,󸐢?H\rh瘑\rj𤈎\u0012\\(u\u001bu𥱑󴳈o\u0014󱕌􍙩􀶂\u0011q\u001d-\u0008齧\u0011qW>\u000cysῂ,'𧃒<", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_5.json b/libs/wire-api/test/golden/testObject_Login_user_5.json index 13b2f46ee04..19f1aa2570f 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_5.json +++ b/libs/wire-api/test/golden/testObject_Login_user_5.json @@ -1,5 +1,6 @@ { "handle": "c372iaa_v5onjcck67rlzq4dn5_oxhtx7dpx7v82lp1rhx0e97i26--8r3c6k773bxtlzmkjc20-11_047ydua_o9_5u4sll_fl3ng_0sa.", "label": "LGz%𝒍j\u000c\u001e/\u0001", - "password": "𝘛𭆴DU󼸸hp󵱻t~\u0012\u0001\u0002*􁈚y1􇑮H𪒧{e\\S\u000e?c_7\t\u0014X𡀓6𪊲E𘝈j\u001a\t\u0016􉯿>HO]60󱭓\u0003\"+w,t􄐸\u0007k(b%u𤺝`>b󻂰e\u0006c𤽡􎠜)し7􈑠`𭟉yO+v%󼗀\rc<𐃤2>8u􋉲􇵝􏸗𒔙a𫯹\u0015=\u0004􆼝8R&j󾣆\u001b\t4sj-󲉛鷔n𡘽􃲙N\u001d\\󺡋𑩠5\r𗫬(P!爳棧\u0008􄫼Mr~﹣\u0019jt>Z\u001d~𢖼A󻲾\u000e\\>\u00116\">%댤􈵏I@u5𭷳\u000brY\r;7􅟌#􇒇󸇞\u0018'󾏵\u0019_I_zY󱂤𤟁\u0019d󽷤cd􃑯𡒆Cp3曕\u001dXj\n듡jy값\t-䩹ꥈd󿠓L\u001aYF\u0006POL헮\u0012\u0011\u0011\u0012*\rH\u0010(?\u0013F擜\u0010\r]􅆋j𩣁 @\u0005T􌮍s\u001cF2\u0015]8\u0007\u0013!\u0015W𫅕􏌲K󺐢􏢞_%󴥚􏯭'􌆥𑋘(#\u0001ky\t\u0017!䒢\u0015\u0014\u001b{𝈕U2LS'" + "password": "𝘛𭆴DU󼸸hp󵱻t~\u0012\u0001\u0002*􁈚y1􇑮H𪒧{e\\S\u000e?c_7\t\u0014X𡀓6𪊲E𘝈j\u001a\t\u0016􉯿>HO]60󱭓\u0003\"+w,t􄐸\u0007k(b%u𤺝`>b󻂰e\u0006c𤽡􎠜)し7􈑠`𭟉yO+v%󼗀\rc<𐃤2>8u􋉲􇵝􏸗𒔙a𫯹\u0015=\u0004􆼝8R&j󾣆\u001b\t4sj-󲉛鷔n𡘽􃲙N\u001d\\󺡋𑩠5\r𗫬(P!爳棧\u0008􄫼Mr~﹣\u0019jt>Z\u001d~𢖼A󻲾\u000e\\>\u00116\">%댤􈵏I@u5𭷳\u000brY\r;7􅟌#􇒇󸇞\u0018'󾏵\u0019_I_zY󱂤𤟁\u0019d󽷤cd􃑯𡒆Cp3曕\u001dXj\n듡jy값\t-䩹ꥈd󿠓L\u001aYF\u0006POL헮\u0012\u0011\u0011\u0012*\rH\u0010(?\u0013F擜\u0010\r]􅆋j𩣁 @\u0005T􌮍s\u001cF2\u0015]8\u0007\u0013!\u0015W𫅕􏌲K󺐢􏢞_%󴥚􏯭'􌆥𑋘(#\u0001ky\t\u0017!䒢\u0015\u0014\u001b{𝈕U2LS'", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_6.json b/libs/wire-api/test/golden/testObject_Login_user_6.json index 27db0bca02d..498aa516f3e 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_6.json +++ b/libs/wire-api/test/golden/testObject_Login_user_6.json @@ -1,5 +1,6 @@ { "label": "󷭄'󳩽KW\\\u0000\u0014", "password": "K?)V𤊊}_𭏷􃁘\u000cJ3!󰷕􃕍즟𨪷􅟘\u0007󷽻\u00017\\#z9𠥿􇽋󰩚󾏒\u0019\u0013𦈎'\r)~Ke9+𪷶𪺢󲭎M􌔩\"h\u0001Th\u0004`;\u0006􊶠\u0005󺦪'e{\u001cv鼵\u001f𢿻*㽬􆺦츟:E]:R􋂿K}l􏙠Y집􀋦S~\u0004#T󻓄1hIWn\u000b`놏Kb~\u001b\u0010dT\u001c\u000f􊨭f\u0017Y7\u001e𠋜\t󳸻㑦뱲\u001dG\u0013BH#\\RAd𨣓g􅳤􁙼\u000fk&\u0002E囉\u001c\u001c\u001c$t󴧥:O􌐑q}_󽯀.\u0001\u0014\u0002𦙎c`L>􀡸l􉔂m'BtB5󴼐,t\"􄕤9(#\u00054\u000fIy>󻯶􌫾\u001dbf\"i\u0017㠟a􉊡C@􇘼􊨩纟\u0015󳻹嬰*N\u0016\u001b:iXibA𡚓𩘤q􀁗]:9r𒁉\u0000􀢋\u001fCN\u001f𤃾􀁹󸐝eR\u001eZbD5!8N\u001bVᲰ\u0006𪐈\u001auz􁓾𭾔~\u001b\u000f%{3I/F抐/DMS\u001f>o𭬿Z􎬞\u001d[K𭇡𗇅􉭱󳀒\u001bO-4\u0018\u001f\u001cZp", - "phone": "+930266260693371" + "phone": "+930266260693371", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_7.json b/libs/wire-api/test/golden/testObject_Login_user_7.json index 08463885c07..a492835be1e 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_7.json +++ b/libs/wire-api/test/golden/testObject_Login_user_7.json @@ -1,5 +1,6 @@ { "email": "BG@⽩c\u000b}\u000fL$_", "label": "\u000e\u0015eC/", - "password": "&󲉊󹴌𔖘\u0002J<-~\u0002>\u000b𒇴𥄿5QN틐𨤨ql\u0015𒈲3}{\u0013𪒺S壓;\t7𬺖_F~D*f􀕔)􄥂-9僛7GK= %\u001e@kOF#𫻩􋌁𞡂8_ꕅ\u001dL鍂\u0003󿶊0Wl1A`LYz\u001fy僸\u001ao\u001b[\u0014\u0008t𐑐a\u0003s~\u001fF𪰤G`$\u000bG\u0011󾿅🙣/󷪺C>\u000f" + "password": "&󲉊󹴌𔖘\u0002J<-~\u0002>\u000b𒇴𥄿5QN틐𨤨ql\u0015𒈲3}{\u0013𪒺S壓;\t7𬺖_F~D*f􀕔)􄥂-9僛7GK= %\u001e@kOF#𫻩􋌁𞡂8_ꕅ\u001dL鍂\u0003󿶊0Wl1A`LYz\u001fy僸\u001ao\u001b[\u0014\u0008t𐑐a\u0003s~\u001fF𪰤G`$\u000bG\u0011󾿅🙣/󷪺C>\u000f", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_Login_user_8.json b/libs/wire-api/test/golden/testObject_Login_user_8.json index 5ac8f6d0b56..49eb4bbfed5 100644 --- a/libs/wire-api/test/golden/testObject_Login_user_8.json +++ b/libs/wire-api/test/golden/testObject_Login_user_8.json @@ -1,5 +1,6 @@ { "email": "@~^G􆪐\\", "label": null, - "password": "z>􉰃󺎇/𡞯􊳌\u0008%$󽖨𣄄:}\t\u0018􂜙󾺽)㊝󵙼s󵪾\u0018}鱢\u0019[ꅾ\u000bX#VG,df4𢢵8m5딝OTK𣑌鋎꺯◆Z\"ZS\u001bms|[Q%􉲡\u0005W\\󴖙C𭌈+􅕺ဒ䖡v𬁡ꎞ){󻆡𣃒f𭬔}:X-\u00082N\u0019\u001fl🎢쇈Y􅤡󷐛r2.1싸\u0004+𡥙\u0013𣡈]'󻂳s󳤴ꜵ.}𭋣o󲍶X𠜥⬅\r\u001aNq6󸻕'\u000cd\u001e㢧􋾜,:%\t𥅬𒃣QD􉖠\u001b(q4KDQ2zcI\u0010>\u00195󲤼1\u000cBkd\u0013\u0006:F:\u0004𘨥ⶂO N\u001c,N􁚶󴌷[h9ᜬ:xZ=\u000c􈾀\u0013u\u001e\u000ce#\u001a^$lkx耤 \rr\u001aJ󷝦󸓡\u001cR][_5\u0015ⷤ诃5惵􁮵󳗴鉅K!􁁠eRR%絬+h~1󲞮谟lTzS$\u0010􂶳\"*􉕷pmRE\u0013(\u001f^ὯJc➑􅫇i\n+G$|󲫉𦉻g\u001c\u000cgU3Y𝄜\u0006f)􊾺\u0016𓈄􌭞/\u0000Piꩦ{󿸟j􈞅\u001c9𠚽󺊬翉w$눟𞴦)Si𨴄牿FX􂋒j{`궤`󳿗𧁁4u%􅔪P*􂉻捎C\u001eR\u0016-잚󶽕g𐰺:S>c㮢𠝌\u0010Y􄝏~a)YW_J􃢤P\u0007+ U􈷓j\u0019k\u0001􋴘\u0011䣷e𪋘𪳠,ᐏg@\u0012\u001dHXl.\u0017𥣁2\u0013mY􁢫\tv?L8L􆍼N𠦽\nb1j󾸸𤋵xfQ=\\\u0005e󳇪󹽶U\u0012p{\u000e􌚌jd^@U󲯝tP.\u0012Y%R`a\r𧍮7}HnUf𠛸m^7:\u0015=챼>l𗑑hwp27𤦾jE\u000cx=!.\u0013]Ar\tw\u0014&\u001ak㒞s󾦄ᆒI𣪗􂼥dsY\u0010𬚢dX.𣭷i]𤹉󻃀\rWS\u001fU􌏬\u001a시􈨂\u0010\u0002N~-\u000e6𮙏􏄲\\O𭍍Jc􀻇􅢮\u0000HSo\u0010-W\u00136𩥑I􄺨)𘗘={𘗔h洹M󹩪FwJQ􏞨ck\u001a\u0018|UV-\u0015\u0001|\u0014;\u000c𦓫𣦃\u0005S\u0015.B\"D𧲿#o*𞹱胜m\u001e􀓪B3Gg;\u0011\\𬆳􌒮\u0005 B^\u000f𥐶$e餴𩠵>fMgC𭮌,o🗨\\?󼛣~/s\u0001?MMc;D18Ne\u0004\u0018)*\u0002\u001d㾌􉰃󺎇/𡞯􊳌\u0008%$󽖨𣄄:}\t\u0018􂜙󾺽)㊝󵙼s󵪾\u0018}鱢\u0019[ꅾ\u000bX#VG,df4𢢵8m5딝OTK𣑌鋎꺯◆Z\"ZS\u001bms|[Q%􉲡\u0005W\\󴖙C𭌈+􅕺ဒ䖡v𬁡ꎞ){󻆡𣃒f𭬔}:X-\u00082N\u0019\u001fl🎢쇈Y􅤡󷐛r2.1싸\u0004+𡥙\u0013𣡈]'󻂳s󳤴ꜵ.}𭋣o󲍶X𠜥⬅\r\u001aNq6󸻕'\u000cd\u001e㢧􋾜,:%\t𥅬𒃣QD􉖠\u001b(q4KDQ2zcI\u0010>\u00195󲤼1\u000cBkd\u0013\u0006:F:\u0004𘨥ⶂO N\u001c,N􁚶󴌷[h9ᜬ:xZ=\u000c􈾀\u0013u\u001e\u000ce#\u001a^$lkx耤 \rr\u001aJ󷝦󸓡\u001cR][_5\u0015ⷤ诃5惵􁮵󳗴鉅K!􁁠eRR%絬+h~1󲞮谟lTzS$\u0010􂶳\"*􉕷pmRE\u0013(\u001f^ὯJc➑􅫇i\n+G$|󲫉𦉻g\u001c\u000cgU3Y𝄜\u0006f)􊾺\u0016𓈄􌭞/\u0000Piꩦ{󿸟j􈞅\u001c9𠚽󺊬翉w$눟𞴦)Si𨴄牿FX􂋒j{`궤`󳿗𧁁4u%􅔪P*􂉻捎C\u001eR\u0016-잚󶽕g𐰺:S>c㮢𠝌\u0010Y􄝏~a)YW_J􃢤P\u0007+ U􈷓j\u0019k\u0001􋴘\u0011䣷e𪋘𪳠,ᐏg@\u0012\u001dHXl.\u0017𥣁2\u0013mY􁢫\tv?L8L􆍼N𠦽\nb1j󾸸𤋵xfQ=\\\u0005e󳇪󹽶U\u0012p{\u000e􌚌jd^@U󲯝tP.\u0012Y%R`a\r𧍮7}HnUf𠛸m^7:\u0015=챼>l𗑑hwp27𤦾jE\u000cx=!.\u0013]Ar\tw\u0014&\u001ak㒞s󾦄ᆒI𣪗􂼥dsY\u0010𬚢dX.𣭷i]𤹉󻃀\rWS\u001fU􌏬\u001a시􈨂\u0010\u0002N~-\u000e6𮙏􏄲\\O𭍍Jc􀻇􅢮\u0000HSo\u0010-W\u00136𩥑I􄺨)𘗘={𘗔h洹M󹩪FwJQ􏞨ck\u001a\u0018|UV-\u0015\u0001|\u0014;\u000c𦓫𣦃\u0005S\u0015.B\"D𧲿#o*𞹱胜m\u001e􀓪B3Gg;\u0011\\𬆳􌒮\u0005 B^\u000f𥐶$e餴𩠵>fMgC𭮌,o🗨\\?󼛣~/s\u0001?MMc;D18Ne\u0004\u0018)*\u0002\u001d㾌1/\t\u0015 󶫒󷘿z苐Bv􎲋(=<\u000eq􍪬?L᪽􄗻ஜc󳤌<&!􍚌󴆏j~O3USw\u0012\u0003\u0007\u0017+󺀡Ny粰(/Sco\u0002{3\u000fEh\u0016󼆏󹫐气-\u001c.'\u0005X𘉸𤮓Ti3􀩲\"%\u0016\u0008𮀜+\u0004\u0002^􎧯)2bR\u0006\u000fJB[󿊻&O9{w{aV\u0005gZ?3z􄈭8፳𦔖󱴵`􃥔\"PE)uKq|w\u00160\u001b. \u0003𑻠sxW𧉥󴚗m\u00057e)𓁘󶑼:s\u0018Yj⚎㿤\u0006\u001flTu􏄥I.􉙜O#kQ\u001e!g􃔗\u0018Q\u001f𪍃\u0016\u0006|\"M\"P\u001f\u0003@ZPq󸌖gY𤒍=\u0007􂍭l8󾌀3󲻄󹪢CN<𤆤gJ󽡢]𗋔mX~\u0006w3\u0010𫸴8\u00076\u0004}\u0010i\u0013L5󼂐PY^|!Vz\u001b4走!iLa⼻\u0014􂭺𩀜\u001d:󾟿𤢈h\\dLx􉣕\u0019𥚚\u001a𠷫R%ps7𗏀s􆓓fg\nIf􄢿\u0011l\u001a󹮗-n_ឱUY?4d]|c\\[T\u0007jS䦖휆鄐aK󺖖􏩠\u0003\u001cx+" + "password": ">1/\t\u0015 󶫒󷘿z苐Bv􎲋(=<\u000eq􍪬?L᪽􄗻ஜc󳤌<&!􍚌󴆏j~O3USw\u0012\u0003\u0007\u0017+󺀡Ny粰(/Sco\u0002{3\u000fEh\u0016󼆏󹫐气-\u001c.'\u0005X𘉸𤮓Ti3􀩲\"%\u0016\u0008𮀜+\u0004\u0002^􎧯)2bR\u0006\u000fJB[󿊻&O9{w{aV\u0005gZ?3z􄈭8፳𦔖󱴵`􃥔\"PE)uKq|w\u00160\u001b. \u0003𑻠sxW𧉥󴚗m\u00057e)𓁘󶑼:s\u0018Yj⚎㿤\u0006\u001flTu􏄥I.􉙜O#kQ\u001e!g􃔗\u0018Q\u001f𪍃\u0016\u0006|\"M\"P\u001f\u0003@ZPq󸌖gY𤒍=\u0007􂍭l8󾌀3󲻄󹪢CN<𤆤gJ󽡢]𗋔mX~\u0006w3\u0010𫸴8\u00076\u0004}\u0010i\u0013L5󼂐PY^|!Vz\u001b4走!iLa⼻\u0014􂭺𩀜\u001d:󾟿𤢈h\\dLx􉣕\u0019𥚚\u001a𠷫R%ps7𗏀s􆓓fg\nIf􄢿\u0011l\u001a󹮗-n_ឱUY?4d]|c\\[T\u0007jS䦖휆鄐aK󺖖􏩠\u0003\u001cx+", + "verification_code": "123456" } diff --git a/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_1 b/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_1 new file mode 100644 index 00000000000..d7d7e107861 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_1 @@ -0,0 +1 @@ +"generate_scim_token" diff --git a/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_2 b/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_2 new file mode 100644 index 00000000000..4608126e46a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_SndFactorPasswordChallengeAction_user_2 @@ -0,0 +1 @@ +"login" 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 e11f7e41f12..91364575360 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 @@ -252,6 +252,8 @@ tests = testRoundTrip @User.DeleteUser, testRoundTrip @User.VerifyDeleteUser, testRoundTrip @User.DeletionCodeTimeout, + testRoundTrip @User.SndFactorPasswordChallengeAction, + testRoundTrip @User.SendVerificationCode, testRoundTrip @User.Activation.ActivationKey, -- FUTUREWORK: this should probably be tested individually, -- but ActivationTarget currently doesn't have JSON instances itself. diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index fd063fc7f11..75b3dcc0652 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -385,6 +385,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.Scheme_user Test.Wire.API.Golden.Generated.SearchResult_20Contact_user Test.Wire.API.Golden.Generated.SearchResult_20TeamContact_user + Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user Test.Wire.API.Golden.Generated.SelfProfile_user Test.Wire.API.Golden.Generated.SendActivationCode_user Test.Wire.API.Golden.Generated.SendLoginCode_user diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 101008ee77b..da9b6c90e5a 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -170,6 +170,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"get-user-by-handle-qualified" Handle.getHandleInfo :<|> Named @"list-users-by-unqualified-ids-or-handles" listUsersByUnqualifiedIdsOrHandles :<|> Named @"list-users-by-ids-or-handles" listUsersByIdsOrHandles + :<|> Named @"send-verification-code" (const sendVerificationCode) selfAPI :: ServerT SelfAPI Handler selfAPI = @@ -1060,6 +1061,13 @@ activate (Public.Activate tgt code dryrun) respond (Just ident) first = ActivationResp $ Public.ActivationResponse ident first respond Nothing _ = ActivationRespSuccessNoIdent +-- Verification + +sendVerificationCode :: Handler () +sendVerificationCode = + case Public.TeamFeatureSndFPasswordChallengeNotImplemented of + _ -> pure () + -- Deprecated deprecatedOnboardingH :: JSON ::: UserId ::: JsonRequest Value -> Handler Response diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index dae3407e7ea..e25ae0a82ae 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -88,9 +88,10 @@ routesPublic = do document "POST" "sendLoginCode" $ do Doc.summary "Send a login code to a verified phone number." Doc.notes - "This operation generates and sends a login code. \ + "This operation generates and sends a login code via sms for phone login. \ \A login code can be used only once and times out after \ - \10 minutes. Only one login code may be pending at a time." + \10 minutes. Only one login code may be pending at a time.\ + \For 2nd factor authentication login with email and password, use the `/verification-code/send` endpoint." Doc.body (Doc.ref Public.modelSendLoginCode) $ Doc.description "JSON body" Doc.returns (Doc.ref Public.modelLoginCodeResponse) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index fc6868072cd..e11fb2cf127 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -71,6 +71,7 @@ import Network.Wai.Utilities.Error ((!>>)) import System.Logger (field, msg, val, (~~)) import qualified System.Logger.Class as Log import Wire.API.Team.Feature (TeamFeatureStatusNoConfig (..), TeamFeatureStatusValue (..)) +import Wire.API.User (TeamFeatureSndFPasswordChallengeNotImplemented (..)) data Access u = Access { accessToken :: !AccessToken, @@ -110,7 +111,11 @@ lookupLoginCode phone = Data.lookupLoginCode u login :: Login -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) -login (PasswordLogin li pw label) typ = do +login (PasswordLogin li pw label _) typ = do + case TeamFeatureSndFPasswordChallengeNotImplemented of + -- mark this place to implement handling verification codes later + -- (for now just ignore them unconditionally.) + _ -> pure () uid <- resolveLoginId li Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") checkRetryLimit uid diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 86ebf716563..808f075999d 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1072,7 +1072,7 @@ testPasswordChange brig = do put (brig . path "/self/password" . contentJson . zUser uid . body pwChange) !!! const 200 === statusCode -- login with new password - login brig (PasswordLogin (LoginByEmail email) newPass Nothing) PersistentCookie + login brig (PasswordLogin (LoginByEmail email) newPass Nothing Nothing) PersistentCookie !!! const 200 === statusCode -- try to change the password to itself should fail put (brig . path "/self/password" . contentJson . zUser uid . body pwChange') diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 828209c187d..73e0375fd4f 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -318,7 +318,7 @@ testHandleLogin brig = do let update = RequestBodyLBS . encode $ HandleUpdate hdl put (brig . path "/self/handle" . contentJson . zUser usr . zConn "c" . Http.body update) !!! const 200 === statusCode - let l = PasswordLogin (LoginByHandle (Handle hdl)) defPassword Nothing + let l = PasswordLogin (LoginByHandle (Handle hdl)) defPassword Nothing Nothing login brig l PersistentCookie !!! const 200 === statusCode -- | Check that local part after @+@ is ignored by equality on email addresses if the domain is @@ -370,11 +370,11 @@ testLoginFailure brig = do Just email <- userEmail <$> randomUser brig -- login with wrong password let badpw = PlainTextPassword "wrongpassword" - login brig (PasswordLogin (LoginByEmail email) badpw Nothing) PersistentCookie + login brig (PasswordLogin (LoginByEmail email) badpw Nothing Nothing) PersistentCookie !!! const 403 === statusCode -- login with wrong / non-existent email let badmail = Email "wrong" "wire.com" - login brig (PasswordLogin (LoginByEmail badmail) defPassword Nothing) PersistentCookie + login brig (PasswordLogin (LoginByEmail badmail) defPassword Nothing Nothing) PersistentCookie !!! const 403 === statusCode -- @END diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index a1da873e571..507f66b17c1 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -55,7 +55,7 @@ testPasswordReset brig = do -- try login login brig (defEmailLogin email) PersistentCookie !!! const 403 === statusCode - login brig (PasswordLogin (LoginByEmail email) newpw Nothing) PersistentCookie + login brig (PasswordLogin (LoginByEmail email) newpw Nothing Nothing) PersistentCookie !!! const 200 === statusCode -- reset password again to the same new password, get 400 "must be different" do diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 5dd0cfe45c8..3c7565d8b1d 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -108,7 +108,8 @@ createScimToken spar' owner = do createToken spar' owner $ CreateScimToken { createScimTokenDescr = "testCreateToken", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } pure tok diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 07ddde9be7e..3d67663cb98 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -820,7 +820,7 @@ defEmailLogin :: Email -> Login defEmailLogin e = emailLogin e defPassword (Just defCookieLabel) emailLogin :: Email -> PlainTextPassword -> Maybe CookieLabel -> Login -emailLogin e = PasswordLogin (LoginByEmail e) +emailLogin e pw cl = PasswordLogin (LoginByEmail e) pw cl Nothing somePrekeys :: [Prekey] somePrekeys = diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index eb642d86d7a..f66ec2296a4 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -85,7 +85,8 @@ testCreateToken = do owner CreateScimToken { createScimTokenDescr = "testCreateToken", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } -- Try to do @GET /Users@ and check that it succeeds let fltr = filterBy "externalId" "67c196a0-cd0e-11ea-93c7-ef550ee48502" @@ -105,21 +106,24 @@ testTokenLimit = do owner CreateScimToken { createScimTokenDescr = "testTokenLimit / #1", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } _ <- createToken owner CreateScimToken { createScimTokenDescr = "testTokenLimit / #2", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } -- Try to create the third token and see that it fails createToken_ owner CreateScimToken { createScimTokenDescr = "testTokenLimit / #3", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } (env ^. teSpar) !!! checkErr 403 (Just "token-limit-reached") @@ -138,13 +142,13 @@ testNumIdPs = do SAML.SampleIdP metadata _ _ _ <- SAML.makeSampleIdPMetadata void $ call $ Util.callIdpCreate apiversion spar (Just owner) metadata - createToken owner (CreateScimToken "eins" (Just defPassword)) + createToken owner (CreateScimToken "eins" (Just defPassword) Nothing) >>= deleteToken owner . stiId . createScimTokenResponseInfo addSomeIdP - createToken owner (CreateScimToken "zwei" (Just defPassword)) + createToken owner (CreateScimToken "zwei" (Just defPassword) Nothing) >>= deleteToken owner . stiId . createScimTokenResponseInfo addSomeIdP - createToken_ owner (CreateScimToken "drei" (Just defPassword)) (env ^. teSpar) + createToken_ owner (CreateScimToken "drei" (Just defPassword) Nothing) (env ^. teSpar) !!! checkErr 400 (Just "more-than-one-idp") -- @SF.Provisioning @TSFI.RESTfulAPI @S2 @@ -168,7 +172,8 @@ testCreateTokenAuthorizesOnlyAdmins = do uid CreateScimToken { createScimTokenDescr = "testCreateToken", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } (env ^. teSpar) @@ -194,7 +199,8 @@ testCreateTokenRequiresPassword = do owner CreateScimToken { createScimTokenDescr = "testCreateTokenRequiresPassword", - createScimTokenPassword = Nothing + createScimTokenPassword = Nothing, + createScimTokenCode = Nothing } (env ^. teSpar) !!! checkErr 403 (Just "access-denied") @@ -203,7 +209,8 @@ testCreateTokenRequiresPassword = do owner CreateScimToken { createScimTokenDescr = "testCreateTokenRequiresPassword", - createScimTokenPassword = Just (PlainTextPassword "wrong password") + createScimTokenPassword = Just (PlainTextPassword "wrong password"), + createScimTokenCode = Nothing } (env ^. teSpar) !!! checkErr 403 (Just "access-denied") @@ -227,14 +234,16 @@ testListTokens = do owner CreateScimToken { createScimTokenDescr = "testListTokens / #1", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } _ <- createToken owner CreateScimToken { createScimTokenDescr = "testListTokens / #2", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } -- Check that the token is on the list list <- scimTokenListTokens <$> listTokens owner @@ -331,7 +340,8 @@ testDeletedTokensAreUnusable = do owner CreateScimToken { createScimTokenDescr = "testDeletedTokensAreUnusable", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } -- An operation with the token should succeed let fltr = filterBy "externalId" "67c196a0-cd0e-11ea-93c7-ef550ee48502" @@ -353,7 +363,8 @@ testDeletedTokensAreUnlistable = do owner CreateScimToken { createScimTokenDescr = "testDeletedTokensAreUnlistable", - createScimTokenPassword = Just defPassword + createScimTokenPassword = Just defPassword, + createScimTokenCode = Nothing } -- Delete the token deleteToken owner (stiId tokenInfo) diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index f476aaeaec2..f3ebef1b101 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -54,7 +54,7 @@ changeEmailBrig brig usr newEmail = do changeEmailBrigCreds brig cky tok newEmail where emailLogin :: Email -> Misc.PlainTextPassword -> Maybe Auth.CookieLabel -> Auth.Login - emailLogin e = Auth.PasswordLogin (Auth.LoginByEmail e) + emailLogin e pw cl = Auth.PasswordLogin (Auth.LoginByEmail e) pw cl Nothing login :: Auth.Login -> Auth.CookieType -> (MonadIO m, MonadHttp m) => m ResponseLBS login l t = diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index da0c37e79ac..71e9133934e 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -61,7 +61,7 @@ instance Arbitrary ScimTokenInfo where <*> arbitrary instance Arbitrary CreateScimToken where - arbitrary = CreateScimToken <$> arbitrary <*> arbitrary + arbitrary = CreateScimToken <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary CreateScimTokenResponse where arbitrary = CreateScimTokenResponse <$> arbitrary <*> arbitrary From d605a82211de7bb9ddc788dc39f5995f63d0df14 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Feb 2022 09:35:36 +0100 Subject: [PATCH 45/58] Minimal client API versioning (#2116) * Add GET /api-version endpoint * Add version middleware This rewrites requests from `/vN/path` to `/path`. * Install version middleware on every service * Use wai-extra for rewriting WAI requests Simply changing the `pathInfo` field is not enough, because some Wai applications or middleware are relying on the `rawPathInfo` field. * Add version prefixes to nginz chart --- .../0-release-notes/api-version-prefix | 1 + .../1-api-changes/api-version-endpoint | 1 + charts/nginz/templates/conf/_nginx.conf.tpl | 7 +- charts/nginz/values.yaml | 93 +++++++++++-------- libs/wire-api/package.yaml | 2 + libs/wire-api/src/Wire/API/Routes/Version.hs | 80 ++++++++++++++++ .../src/Wire/API/Routes/Version/Wai.hs | 47 ++++++++++ libs/wire-api/src/Wire/API/VersionInfo.hs | 27 ++++++ libs/wire-api/wire-api.cabal | 5 + services/brig/brig.cabal | 1 + services/brig/src/Brig/API/Public.hs | 2 + services/brig/src/Brig/Run.hs | 5 + services/brig/test/integration/API/Version.hs | 59 ++++++++++++ services/brig/test/integration/Main.hs | 5 +- services/cannon/src/Cannon/Run.hs | 2 + services/cargohold/src/CargoHold/Run.hs | 2 + services/galley/src/Galley/Run.hs | 2 + services/gundeck/src/Gundeck/Run.hs | 2 + services/proxy/package.yaml | 1 + services/proxy/proxy.cabal | 3 +- services/proxy/src/Proxy/Run.hs | 2 + services/spar/src/Spar/Run.hs | 2 + 22 files changed, 307 insertions(+), 44 deletions(-) create mode 100644 changelog.d/0-release-notes/api-version-prefix create mode 100644 changelog.d/1-api-changes/api-version-endpoint create mode 100644 libs/wire-api/src/Wire/API/Routes/Version.hs create mode 100644 libs/wire-api/src/Wire/API/Routes/Version/Wai.hs create mode 100644 libs/wire-api/src/Wire/API/VersionInfo.hs create mode 100644 services/brig/test/integration/API/Version.hs diff --git a/changelog.d/0-release-notes/api-version-prefix b/changelog.d/0-release-notes/api-version-prefix new file mode 100644 index 00000000000..0622cdb3d2a --- /dev/null +++ b/changelog.d/0-release-notes/api-version-prefix @@ -0,0 +1 @@ +For wire.com operators: to enable versioned API paths, make sure that nginz is deployed. diff --git a/changelog.d/1-api-changes/api-version-endpoint b/changelog.d/1-api-changes/api-version-endpoint new file mode 100644 index 00000000000..b41a413a2fd --- /dev/null +++ b/changelog.d/1-api-changes/api-version-endpoint @@ -0,0 +1 @@ +Added minimal API version support: a list of supported API versions can be found at the endpoint `GET /api-version`. Versions can be selected by adding a prefix of the form `/vN` to every route, where `N` is the desired version number (so for example `/v1/conversations` to access version 1 of the `/conversations` endpoint). diff --git a/charts/nginz/templates/conf/_nginx.conf.tpl b/charts/nginz/templates/conf/_nginx.conf.tpl index 58cade243b0..c6c9969e127 100644 --- a/charts/nginz/templates/conf/_nginx.conf.tpl +++ b/charts/nginz/templates/conf/_nginx.conf.tpl @@ -207,7 +207,7 @@ http { } {{ range $path := .Values.nginx_conf.disabled_paths }} - location {{ $path }} { + location ~* ^(/v[0-9]+)?{{ $path }} { return 404; } @@ -227,7 +227,10 @@ http { rewrite ^/api-docs{{ $location.path }} {{ $location.path }}/api-docs?base_url=https://{{ $.Values.nginx_conf.env }}-nginz-https.{{ $.Values.nginx_conf.external_env_domain }}/ break; {{- end }} - location {{ $location.path }} { + {{- $versioned := ternary $location.versioned true (hasKey $location "versioned") -}} + {{- $path := printf "%s%s" (ternary "(/v[0-9]+)?" "" $versioned) $location.path }} + + location ~* ^{{ $path }} { # remove access_token from logs, see 'Note sanitized_request' above. set $sanitized_request $request; diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 37a6ef5418f..9b56a17d632 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -43,13 +43,13 @@ nginx_conf: # title: "Production" disabled_paths: - /conversations/last-events - - ~* ^/conversations/([^/]*)/knock - - ~* ^/conversations/([^/]*)/hot-knock - - ~* ^/conversations/([^/]*)/messages - - ~* ^/conversations/([^/]*)/client-messages - - ~* ^/conversations/([^/]*)/events - - ~* ^/conversations/([^/]*)/call - - ~* ^/conversations/([^/]*)/call/state + - /conversations/([^/]*)/knock + - /conversations/([^/]*)/hot-knock + - /conversations/([^/]*)/messages + - /conversations/([^/]*)/client-messages + - /conversations/([^/]*)/events + - /conversations/([^/]*)/call + - /conversations/([^/]*)/call/state - /search/top - /search/common # -- The origins from which we allow CORS requests. These are combined with 'external_env_domain' to form a full url @@ -59,12 +59,12 @@ nginx_conf: - account upstreams: cargohold: - - path: ~* ^/conversations/([^/]*)/assets + - path: /conversations/([^/]*)/assets envs: - all max_body_size: "0" disable_request_buffering: true - - path: ~* ^/conversations/([^/]*)/otr/assets + - path: /conversations/([^/]*)/otr/assets envs: - all max_body_size: "0" @@ -96,7 +96,7 @@ nginx_conf: - path: /list-users envs: - all - - path: ~* ^/api/swagger.json$ + - path: /api/swagger.json$ disable_zauth: true envs: - all @@ -110,7 +110,7 @@ nginx_conf: - path: /connections envs: - all - - path: ~* ^/list-connections$ + - path: /list-connections$ envs: - all - path: /invitations @@ -162,7 +162,7 @@ nginx_conf: - path: /bot/users envs: - all - - path: ~* ^/conversations/([^/]*)/bots + - path: /conversations/([^/]*)/bots envs: - all - path: /invitations/info @@ -196,41 +196,49 @@ nginx_conf: - staging disable_zauth: true basic_auth: true + versioned: false - path: /i/users/login-code envs: - staging disable_zauth: true basic_auth: true + versioned: false - path: /i/users/invitation-code envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/i/users/([^/]*)/rich-info + versioned: false + - path: /i/users/([^/]*)/rich-info envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/i/teams/([^/]*)/suspend + versioned: false + - path: /i/teams/([^/]*)/suspend envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/i/teams/([^/]*)/unsuspend + versioned: false + - path: /i/teams/([^/]*)/unsuspend envs: - staging disable_zauth: true basic_auth: true + versioned: false - path: /i/provider/activation-code envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/i/legalhold/whitelisted-teams(.*) + versioned: false + - path: /i/legalhold/whitelisted-teams(.*) envs: - staging disable_zauth: true basic_auth: true + versioned: false - path: /cookies envs: - all @@ -253,17 +261,17 @@ nginx_conf: - path: /search envs: - all - - path: ~* ^/teams/([^/]*)/invitations(.*) + - path: /teams/([^/]*)/invitations(.*) envs: - all - - path: ~* ^/teams/([^/]*)/services(.*) + - path: /teams/([^/]*)/services(.*) envs: - all - - path: ~* ^/teams/invitations/info$ + - path: /teams/invitations/info$ envs: - all disable_zauth: true - - path: ~* ^/teams/invitations/by-email$ + - path: /teams/invitations/by-email$ envs: - all disable_zauth: true @@ -272,13 +280,14 @@ nginx_conf: - staging disable_zauth: true basic_auth: true + versioned: false - path: /calls envs: - all - - path: ~* ^/teams/([^/]*)/size$ + - path: /teams/([^/]*)/size$ envs: - all - - path: ~* ^/teams/([^/]*)/search$ + - path: /teams/([^/]*)/search$ envs: - all - path: /verification-code/send @@ -290,12 +299,12 @@ nginx_conf: disable_zauth: true envs: - all - - path: ~* ^/conversations/([^/]*)/otr/messages + - path: /conversations/([^/]*)/otr/messages envs: - all max_body_size: 40m body_buffer_size: 256k - - path: ~* ^/conversations/([^/]*)/([^/]*)/proteus/messages + - path: /conversations/([^/]*)/([^/]*)/proteus/messages envs: - all max_body_size: 40m @@ -317,57 +326,60 @@ nginx_conf: envs: - all doc: true - - path: ~* ^/teams$ + - path: /teams$ envs: - all - - path: ~* ^/teams/([^/]*)$ + - path: /teams/([^/]*)$ envs: - all - - path: ~* ^/teams/([^/]*)/members(.*) + - path: /teams/([^/]*)/members(.*) envs: - all - - path: ~* ^/teams/([^/]*)/get-members-by-ids-using-post(.*) + - path: /teams/([^/]*)/get-members-by-ids-using-post(.*) envs: - all - - path: ~* ^/teams/([^/]*)/conversations(.*) + - path: /teams/([^/]*)/conversations(.*) envs: - all - - path: ~* ^/teams/([^/]*)/members/csv$ + - path: /teams/([^/]*)/members/csv$ envs: - all - - path: ~* ^/teams/([^/]*)/legalhold(.*) + - path: /teams/([^/]*)/legalhold(.*) envs: - all - - path: ~* ^/i/teams/([^/]*)/legalhold(.*) + - path: /i/teams/([^/]*)/legalhold(.*) envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/custom-backend/by-domain/([^/]*)$ + versioned: false + - path: /custom-backend/by-domain/([^/]*)$ disable_zauth: true envs: - all - - path: ~* ^/i/custom-backend/by-domain/([^/]*)$ + - path: /i/custom-backend/by-domain/([^/]*)$ disable_zauth: true basic_auth: true envs: - staging - - path: ~* ^/teams/api-docs + versioned: false + - path: /teams/api-docs envs: - all disable_zauth: true - - path: ~* ^/teams/([^/]*)/features + - path: /teams/([^/]*)/features envs: - all - - path: ~* ^/teams/([^/]*)/features/([^/])* + - path: /teams/([^/]*)/features/([^/])* envs: - all - - path: ~* /i/teams/([^/]*)/features/([^/]*) + - path: /i/teams/([^/]*)/features/([^/]*) envs: - staging disable_zauth: true basic_auth: true - - path: ~* ^/feature-configs(.*) + versioned: false + - path: /feature-configs(.*) envs: - all - path: /galley-api/swagger-ui @@ -395,6 +407,7 @@ nginx_conf: basic_auth: true envs: - staging + versioned: false - path: /sso-initiate-bind envs: - all @@ -436,7 +449,7 @@ nginx_conf: envs: - all disable_zauth: true - - path: ~* ^/teams/([^/]*)/billing(.*) + - path: /teams/([^/]*)/billing(.*) envs: - all calling-test: diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index b8b8c30c3ad..8a369f82054 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -90,6 +90,8 @@ library: - wire-message-proto-lens - x509 - wai + - wai-extra + - wai-utilities - wai-websockets - websockets diff --git a/libs/wire-api/src/Wire/API/Routes/Version.hs b/libs/wire-api/src/Wire/API/Routes/Version.hs new file mode 100644 index 00000000000..acd525dc336 --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Version.hs @@ -0,0 +1,80 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Routes.Version where + +import Control.Lens ((?~)) +import Data.Aeson (FromJSON, ToJSON (..)) +import qualified Data.Aeson as Aeson +import Data.Schema +import qualified Data.Swagger as S +import qualified Data.Text as Text +import qualified Data.Text.Read as Text +import Imports +import Servant +import Servant.Swagger +import Wire.API.Routes.Named +import Wire.API.VersionInfo + +data Version = V0 | V1 + deriving stock (Eq, Ord, Bounded, Enum, Show) + deriving (FromJSON, ToJSON) via (Schema Version) + +instance ToSchema Version where + schema = + enum @Integer "Version" . mconcat $ + [ element 0 V0, + element 1 V1 + ] + +readVersionNumber :: Text -> Maybe Integer +readVersionNumber v = do + ('v', rest) <- Text.uncons v + case Text.decimal rest of + Right (n, "") -> pure n + _ -> Nothing + +mkVersion :: Integer -> Maybe Version +mkVersion n = case Aeson.fromJSON (Aeson.Number (fromIntegral n)) of + Aeson.Error _ -> Nothing + Aeson.Success v -> pure v + +supportedVersions :: [Version] +supportedVersions = [minBound .. maxBound] + +newtype VersionInfo = VersionInfo {vinfoSupported :: [Version]} + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema VersionInfo) + +instance ToSchema VersionInfo where + schema = + (S.schema . S.example ?~ toJSON (VersionInfo supportedVersions)) + (VersionInfo <$> vinfoSupported .= vinfoSchema schema) + +type VersionAPI = + Named + "get-version" + ( "api-version" + :> Get '[JSON] VersionInfo + ) + +versionAPI :: Applicative m => ServerT VersionAPI m +versionAPI = + Named @"get-version" $ + pure . VersionInfo $ supportedVersions + +versionSwagger :: S.Swagger +versionSwagger = toSwagger (Proxy @VersionAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs b/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs new file mode 100644 index 00000000000..b0ba0c2ef8b --- /dev/null +++ b/libs/wire-api/src/Wire/API/Routes/Version/Wai.hs @@ -0,0 +1,47 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.Routes.Version.Wai where + +import qualified Data.Text.Lazy as LText +import Imports +import qualified Network.HTTP.Types as HTTP +import Network.Wai +import Network.Wai.Middleware.Rewrite +import Network.Wai.Utilities.Error +import Network.Wai.Utilities.Response +import Wire.API.Routes.Version + +-- | Strip off version prefix. Return 404 if the version is not supported. +versionMiddleware :: Middleware +versionMiddleware app req k = case parseVersion req of + Nothing -> app req k + Just (req', n) -> case mkVersion n of + Just _ -> app req' k + Nothing -> + k $ + errorRs' $ + mkError HTTP.status404 "unsupported-version" $ + "Version " <> LText.pack (show n) <> " is not supported" + +parseVersion :: Request -> Maybe (Request, Integer) +parseVersion req = do + (version, pinfo) <- case pathInfo req of + [] -> Nothing + (x : xs) -> pure (x, xs) + n <- readVersionNumber version + pure (rewriteRequestPure (\(_, q) _ -> (pinfo, q)) req, n) diff --git a/libs/wire-api/src/Wire/API/VersionInfo.hs b/libs/wire-api/src/Wire/API/VersionInfo.hs new file mode 100644 index 00000000000..7c888e684df --- /dev/null +++ b/libs/wire-api/src/Wire/API/VersionInfo.hs @@ -0,0 +1,27 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.VersionInfo + ( vinfoSchema, + ) +where + +import Data.Schema +import Imports + +vinfoSchema :: ValueSchema NamedSwaggerDoc v -> ValueSchema NamedSwaggerDoc [v] +vinfoSchema sch = object "VersionInfo" $ field "supported" (array sch) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 75b3dcc0652..0a7751a8d9c 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -65,6 +65,8 @@ library Wire.API.Routes.Public.Spar Wire.API.Routes.Public.Util Wire.API.Routes.QualifiedCapture + Wire.API.Routes.Version + Wire.API.Routes.Version.Wai Wire.API.Routes.WebSocket Wire.API.ServantProto Wire.API.Swagger @@ -97,6 +99,7 @@ library Wire.API.User.Search Wire.API.UserMap Wire.API.Util.Aeson + Wire.API.VersionInfo Wire.API.Wrapped other-modules: Paths_wire_api @@ -218,6 +221,8 @@ library , uuid >=1.3 , vector >=0.12 , wai + , wai-extra + , wai-utilities , wai-websockets , websockets , wire-message-proto-lens diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 48fcbc3f34e..eee5ef22f98 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -424,6 +424,7 @@ executable brig-integration API.User.RichInfo API.User.Util API.UserPendingActivation + API.Version Federation.End2end Federation.Util Index.Create diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index da9b6c90e5a..f1c7bef947f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -108,6 +108,7 @@ import qualified Wire.API.Routes.Public.Galley as GalleyAPI import qualified Wire.API.Routes.Public.LegalHold as LegalHoldAPI import qualified Wire.API.Routes.Public.Spar as SparAPI import qualified Wire.API.Routes.Public.Util as Public +import Wire.API.Routes.Version import qualified Wire.API.Swagger as Public.Swagger (models) import qualified Wire.API.Team as Public import Wire.API.Team.LegalHold (LegalholdProtectee (..)) @@ -130,6 +131,7 @@ swaggerDocsAPI :: Servant.Server SwaggerDocsAPI swaggerDocsAPI = swaggerSchemaUIServer $ ( brigSwagger + <> versionSwagger <> GalleyAPI.swaggerDoc <> LegalHoldAPI.swaggerDoc <> SparAPI.swaggerDoc diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index f4352769120..dce7a876161 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -69,6 +69,8 @@ import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options import Wire.API.Routes.Public.Brig +import Wire.API.Routes.Version +import Wire.API.Routes.Version.Wai -- FUTUREWORK: If any of these async threads die, we will have no clue about it -- and brig could start misbehaving. We should ensure that brig dies whenever a @@ -114,6 +116,7 @@ mkApp o = do . GZip.gunzip . GZip.gzip GZip.def . catchErrors (e ^. applog) [Right $ e ^. metrics] + . versionMiddleware . lookupRequestIdMiddleware app e r k = runHandler e r (Server.route rtree r k) k @@ -127,6 +130,7 @@ mkApp o = do :<|> Servant.hoistServer (Proxy @BrigAPI) (toServantHandler e) servantSitemap :<|> Servant.hoistServer (Proxy @IAPI.API) (toServantHandler e) IAPI.servantSitemap :<|> Servant.hoistServer (Proxy @FederationAPI) (toServantHandler e) federationSitemap + :<|> versionAPI :<|> Servant.Tagged (app e) ) @@ -135,6 +139,7 @@ type ServantCombinedAPI = :<|> BrigAPI :<|> IAPI.API :<|> FederationAPI + :<|> VersionAPI :<|> Servant.Raw ) diff --git a/services/brig/test/integration/API/Version.hs b/services/brig/test/integration/API/Version.hs new file mode 100644 index 00000000000..eefdf7879c8 --- /dev/null +++ b/services/brig/test/integration/API/Version.hs @@ -0,0 +1,59 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module API.Version (tests) where + +import Bilge +import Bilge.Assert +import Imports +import qualified Network.Wai.Utilities.Error as Wai +import Test.Tasty +import Test.Tasty.HUnit +import Util +import Wire.API.Routes.Version + +tests :: Manager -> Brig -> TestTree +tests p brig = + testGroup + "version" + [ test p "GET /api-version" $ testVersion brig, + test p "GET /v1/api-version" $ testVersionV1 brig, + test p "GET /v500/api-version" $ testUnsupportedVersion brig + ] + +testVersion :: Brig -> Http () +testVersion brig = do + vinfo <- + responseJsonError =<< get (brig . path "/api-version") + Http () +testVersionV1 brig = do + vinfo <- + responseJsonError =<< get (brig . path "/v1/api-version") + Http () +testUnsupportedVersion brig = do + e <- + responseJsonError =<< get (brig . path "/v500/api-version") + Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g + let versionApi = API.Version.tests mg b withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" @@ -157,7 +159,8 @@ runTests iConf brigOpts otherArgs = do userPendingActivation, browseTeam, federationEndpoints, - internalApi + internalApi, + versionApi ] <> [federationEnd2End | includeFederationTests] where diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 1f01bd7a90b..55c190f0663 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -50,6 +50,7 @@ import qualified System.Logger.Class as LC import qualified System.Logger.Extended as L import System.Random.MWC (createSystemRandom) import Wire.API.Routes.Public.Cannon +import Wire.API.Routes.Version.Wai type CombinedAPI = PublicAPI :<|> InternalAPI @@ -74,6 +75,7 @@ run o = do servantPrometheusMiddleware (Proxy @CombinedAPI) . Gzip.gzip Gzip.def . catchErrors g [Right m] + . versionMiddleware app :: Application app = middleware (serve (Proxy @CombinedAPI) server) server :: Servant.Server CombinedAPI diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs index 245a41f5557..f6a5201d93c 100644 --- a/services/cargohold/src/CargoHold/Run.hs +++ b/services/cargohold/src/CargoHold/Run.hs @@ -46,6 +46,7 @@ import Servant.Server hiding (Handler, runHandler) import Util.Options import Wire.API.Routes.Internal.Cargohold import Wire.API.Routes.Public.Cargohold +import Wire.API.Routes.Version.Wai type CombinedAPI = FederationAPI :<|> ServantAPI :<|> InternalAPI @@ -72,6 +73,7 @@ mkApp o = Codensity $ \k -> servantPrometheusMiddleware (Proxy @CombinedAPI) . GZip.gzip GZip.def . catchErrors (e ^. appLogger) [Right $ e ^. metrics] + . versionMiddleware servantApp e0 r = let e = set requestId (maybe def RequestId (lookupRequestId r)) e0 in Servant.serveWithContext diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 71bc3c454b9..92262039a9e 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -56,6 +56,7 @@ import Servant hiding (route) import qualified System.Logger as Log import Util.Options import qualified Wire.API.Routes.Public.Galley as GalleyAPI +import Wire.API.Routes.Version.Wai run :: Opts -> IO () run o = do @@ -92,6 +93,7 @@ mkApp o = do . GZip.gunzip . GZip.gzip GZip.def . catchErrors l [Right m] + . versionMiddleware return (middlewares $ servantApp e, e, finalizer) where rtree = compile API.sitemap diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 02251b6d3fb..8c02e5a9db7 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -39,6 +39,7 @@ import Network.Wai.Utilities.Server hiding (serverPort) import qualified System.Logger as Log import qualified UnliftIO.Async as Async import Util.Options +import Wire.API.Routes.Version.Wai run :: Opts -> IO () run o = do @@ -64,6 +65,7 @@ run o = do . GZip.gunzip . GZip.gzip GZip.def . catchErrors (e ^. applog) [Right $ e ^. monitor] + . versionMiddleware app :: Env -> Wai.Application app e r k = runGundeck e r (route routes r k) routes = compile sitemap diff --git a/services/proxy/package.yaml b/services/proxy/package.yaml index 1ab643b678d..2bb1686209e 100644 --- a/services/proxy/package.yaml +++ b/services/proxy/package.yaml @@ -39,6 +39,7 @@ library: - wai-routing >=0.12 - wai-utilities >=0.14.3 - warp >=3.0 + - wire-api - unliftio-core executables: proxy: diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 0aa5d2d426a..55ac7910011 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4b0eeea49373b98eff5aa94f2c7ec6e198b9db932ceeb3ff4311ffc25ab44b86 +-- hash: c31f9c4911b4326363bf2d4063f32f056fd40c97d528cbbec21cbe97ccdf1833 name: proxy version: 0.9.0 @@ -103,6 +103,7 @@ library , wai-routing >=0.12 , wai-utilities >=0.14.3 , warp >=3.0 + , wire-api default-language: Haskell2010 executable proxy diff --git a/services/proxy/src/Proxy/Run.hs b/services/proxy/src/Proxy/Run.hs index 7bd39b4fcc1..dab3700d5ba 100644 --- a/services/proxy/src/Proxy/Run.hs +++ b/services/proxy/src/Proxy/Run.hs @@ -31,6 +31,7 @@ import Proxy.API (sitemap) import Proxy.Env import Proxy.Options import Proxy.Proxy +import Wire.API.Routes.Version.Wai run :: Opts -> IO () run o = do @@ -42,4 +43,5 @@ run o = do let middleware = waiPrometheusMiddleware (sitemap e) . catchErrors (e ^. applog) [Right m] + . versionMiddleware runSettings s (middleware app) `finally` destroyEnv e diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 3e956b73bfb..a1c2807c3d4 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -55,6 +55,7 @@ import Spar.Sem.Logger.TinyLog (toLevel) import System.Logger.Class (Logger) import qualified System.Logger.Extended as Log import Util.Options (casEndpoint, casFilterNodesByDatacentre, casKeyspace, epHost, epPort) +import Wire.API.Routes.Version.Wai import Wire.API.User.Saml as Types ---------------------------------------------------------------------- @@ -124,6 +125,7 @@ mkApp sparCtxOpts = do -- still here for errors outside the power of the 'Application', like network -- outages. . SAML.setHttpCachePolicy + . versionMiddleware . lookupRequestIdMiddleware $ \sparCtxRequestId -> app Env {..} heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) From 3d8c12d42a851c1f322e66e49a1ea0e7f9071e2f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Feb 2022 11:03:21 +0100 Subject: [PATCH 46/58] Add route for `/api-version` to nginz chart (#2134) --- charts/nginz/values.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/charts/nginz/values.yaml b/charts/nginz/values.yaml index 9b56a17d632..877b63c11f6 100644 --- a/charts/nginz/values.yaml +++ b/charts/nginz/values.yaml @@ -87,6 +87,10 @@ nginx_conf: max_body_size: "0" disable_request_buffering: true brig: + - path: /api-version + envs: + - all + disable_zauth: true - path: /users envs: - all From 0a7f61c64e7e6c72d34369a078104c1cbc0341d9 Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 16 Feb 2022 11:44:08 +0100 Subject: [PATCH 47/58] Remove duplicated docs. (#2072) --- docs/reference/provisioning/scim-via-curl.md | 199 +------------------ 1 file changed, 1 insertion(+), 198 deletions(-) diff --git a/docs/reference/provisioning/scim-via-curl.md b/docs/reference/provisioning/scim-via-curl.md index c39fd9ec6ae..aaa2a9eea56 100644 --- a/docs/reference/provisioning/scim-via-curl.md +++ b/docs/reference/provisioning/scim-via-curl.md @@ -1,198 +1 @@ -# Using the SCIM API with curl {#RefScimViaCurl} - -_Author: Matthias Fischmann_ - ---- - -This page shows you how to communicate with the wire backend through -the [SCIM API](http://www.simplecloud.info/) by example. All examples -are [curl](https://curl.haxx.se/) (in bash syntax). - -We support setting the handle and user name in wire (the thing with -`@` and the longer thing without `@`). There is also support for -setting rich-info. Group provisioning is planned, but the release -date hasn't been fixed yet. - -If you want to dive into the backend code, start [reading here in our -backend](https://github.com/wireapp/wire-server/blob/develop/services/spar/src/Spar/Scim.hs) -and [our hscim library](https://github.com/wireapp/hscim). - - -## Creating an SCIM token - -First, we need a little shell environment: - -```bash -export WIRE_BACKEND=https://prod-nginz-https.wire.com -export WIRE_ADMIN=... -export WIRE_PASSWD=... -``` - -SCIM currently supports a variant of HTTP basic auth. In order to -create a token in your team, you need to authenticate using your team -admin credentials. The way this works behind the scenes in your -browser or cell phone, and in plain sight if you want to use curl, is -you need to get a wire token. - -```bash -export BEARER=$(curl -X POST \ - --header 'Content-Type: application/json' \ - --header 'Accept: application/json' \ - -d '{"email":"'"$WIRE_ADMIN"'","password":"'"$WIRE_PASSWD"'"}' \ - $WIRE_BACKEND/login'?persist=false' | jq -r .access_token) -``` - -This token will be good for 15 minutes; after that, just repeat. -(Note that SCIM requests are authenticated with a SCIM token, see -below. SCIM tokens do not expire, but need to be deleted explicitly.) - -If you don't want to install [jq](https://stedolan.github.io/jq/), you -can just call the `curl` command and copy the access token into the -shell variable manually. - -A quick test that you're logged in: - -```bash -curl -X GET --header "Authorization: Bearer $BEARER" \ - $WIRE_BACKEND/self -``` - -Now you are ready to create a SCIM token: - -```bash -export SCIM_TOKEN_FULL=$(curl -X POST \ - --header "Authorization: Bearer $BEARER" \ - --header 'Content-Type: application/json;charset=utf-8' \ - -d '{ "description": "test '"`date`"'", "password": "'"$WIRE_PASSWD"'" }' \ - $WIRE_BACKEND/scim/auth-tokens) -export SCIM_TOKEN=$(echo $SCIM_TOKEN_FULL | jq -r .token) -export SCIM_TOKEN_ID=$(echo $SCIM_TOKEN_FULL | jq -r .info.id) -``` - -... and look it up again: - -```bash -curl -X GET --header "Authorization: Bearer $BEARER" \ - $WIRE_BACKEND/scim/auth-tokens -``` - -... and delete it: - -```bash -curl -X DELETE --header "Authorization: Bearer $BEARER" \ - $WIRE_BACKEND/scim/auth-tokens?id=$SCIM_TOKEN_ID -``` - -## CRUD - -### JSON encoding of SCIM Users - -A minimal definition of a user looks like this: - -```bash -export SCIM_USER='{ - "schemas" : ["urn:ietf:params:scim:schemas:core:2.0:User"], - "externalId" : "nick@example.com", - "userName" : "nick", - "displayName" : "The Nick" -}' -``` - -The `externalId` is used to construct a saml identity. Two cases are -currently supported: - -1. `externalId` contains a valid email address. The SAML `NameID` has -the form `me@example.com`. -2. `externalId` contains anything that is *not* an email address. The -SAML `NameID` has the form `...`. - -*NOTE: It is important to configure your SAML provider to use -`nameid-format:emailAddress` or `nameid-format:unspecified`. Other -nameid formats are not supported at this moment*. -See also: https://github.com/wireapp/wire-server/blob/c507ed64a7d4f0af2bffe2f9c3eb4b5f89a477c0/services/spar/src/Spar/Scim/User.hs#L149-L158 - -We also support custom fields that are used in rich profiles in this -form [see {#RefRichInfo}](../user/rich-info.md): - -```bash -export SCIM_USER='{ - "schemas" : ["urn:ietf:params:scim:schemas:core:2.0:User", "urn:wire:scim:schemas:profile:1.0"], - "externalId" : "rnick@example.com", - "userName" : "rnick", - "displayName" : "The Rich Nick", - "urn:wire:scim:schemas:profile:1.0": { - "richInfo": [ - { - "type": "Department", - "value": "Sales & Marketing" - }, - { - "type": "Favorite color", - "value": "Blue" - } - ] - } -}' -``` - -### create user - -```bash -export STORED_USER=$(curl -X POST \ - --header "Authorization: Bearer $SCIM_TOKEN" \ - --header 'Content-Type: application/json;charset=utf-8' \ - -d "$SCIM_USER" \ - $WIRE_BACKEND/scim/v2/Users) -export STORED_USER_ID=$(echo $STORED_USER | jq -r .id) -``` - -### get specific user - -```bash -curl -X GET \ - --header "Authorization: Bearer $SCIM_TOKEN" \ - --header 'Content-Type: application/json;charset=utf-8' \ - $WIRE_BACKEND/scim/v2/Users/$STORED_USER_ID -``` - -### get all users - -There is a way to do this in the SCIM protocol, but it's not -implemented in wire for performance reasons. If you need a complete -list of your team members, try the CSV download button in the team -management app. - -### update user - -For each put request, you need to provide the full json object. All -omitted fields will be set to `null`. (If you do not have an -up-to-date user present, just `GET` one right before the `PUT`.) - -```bash -export SCIM_USER='{ - "schemas" : ["urn:ietf:params:scim:schemas:core:2.0:User"], - "externalId" : "rnick@example.com", - "userName" : "newnick", - "displayName" : "The New Nick" -}' - -curl -X PUT \ - --header "Authorization: Bearer $SCIM_TOKEN" \ - --header 'Content-Type: application/json;charset=utf-8' \ - -d "$SCIM_USER" \ - $WIRE_BACKEND/scim/v2/Users/$STORED_USER_ID -``` - -### delete user - -``` -curl -X DELETE \ - --header "Authorization: Bearer $SCIM_TOKEN" \ - $WIRE_BACKEND/scim/v2/Users/$STORED_USER_ID -``` - -### groups - -**Not implemented yet.** +# This page [has gone here](https://docs.wire.com/understand/single-sign-on/main.html#using-scim-via-curl). From d029f9fd26d3a94b536a187fef16b99fe925195d Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 16 Feb 2022 13:37:55 +0100 Subject: [PATCH 48/58] Sqservices 1157 2 mf for generating SCIM token errors and renaming (#2135) * failure responses added * renamed code to verification_code * added roundtrip and golden tests --- .../wire-api/src/Wire/API/ErrorDescription.hs | 4 ++ .../src/Wire/API/Routes/Public/Spar.hs | 6 ++- libs/wire-api/src/Wire/API/User/Scim.hs | 10 ++-- .../golden/Test/Wire/API/Golden/Manual.hs | 10 +++- .../Wire/API/Golden/Manual/CreateScimToken.hs | 52 +++++++++++++++++++ .../golden/testObject_CreateScimToken_1.json | 5 ++ .../golden/testObject_CreateScimToken_2.json | 5 ++ .../golden/testObject_CreateScimToken_3.json | 5 ++ .../golden/testObject_CreateScimToken_4.json | 5 ++ .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 2 + libs/wire-api/wire-api.cabal | 1 + services/spar/test/Arbitrary.hs | 3 -- 12 files changed, 99 insertions(+), 9 deletions(-) create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/CreateScimToken.hs create mode 100644 libs/wire-api/test/golden/testObject_CreateScimToken_1.json create mode 100644 libs/wire-api/test/golden/testObject_CreateScimToken_2.json create mode 100644 libs/wire-api/test/golden/testObject_CreateScimToken_3.json create mode 100644 libs/wire-api/test/golden/testObject_CreateScimToken_4.json diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index ba54332ca98..ef4d77d4b6e 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -372,3 +372,7 @@ type BroadcastLimitExceeded = "Too many users to fan out the broadcast event to." type InvalidAction = ErrorDescription 403 "invalid-actions" "The specified actions are invalid." + +type PasswordAuthenticationFailed = ErrorDescription 403 "password-authentication-failed" "Password authentication failed." + +type CodeAuthenticationFailed = ErrorDescription 403 "code-authentication-failed" "Code authentication failed." diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs index f2a2d5eb4cd..ecf42e21d24 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -33,6 +33,7 @@ import Web.Scim.Capabilities.MetaSchema as Scim.Meta import Web.Scim.Class.Auth as Scim.Auth import Web.Scim.Class.User as Scim.User import Wire.API.Cookie +import Wire.API.ErrorDescription (CanThrow, CodeAuthenticationFailed, PasswordAuthenticationFailed) import Wire.API.Routes.Public import Wire.API.User.IdentityProvider import Wire.API.User.Saml @@ -203,7 +204,10 @@ sparResponseURI (Just tid) = type APIScim = OmitDocs :> "v2" :> ScimSiteAPI SparTag - :<|> "auth-tokens" :> APIScimToken + :<|> "auth-tokens" + :> CanThrow PasswordAuthenticationFailed + :> CanThrow CodeAuthenticationFailed + :> APIScimToken type ScimSiteAPI tag = ToServantApi (ScimSite tag) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index a96a61ed070..45b3597f31d 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -83,6 +83,7 @@ import Web.Scim.Schema.Schema (Schema (CustomSchema)) import qualified Web.Scim.Schema.Schema as Scim import qualified Web.Scim.Schema.User as Scim import qualified Web.Scim.Schema.User as Scim.User +import Wire.API.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.API.User.Activation import Wire.API.User.Identity (Email) import Wire.API.User.Profile as BT @@ -370,13 +371,14 @@ data CreateScimToken = CreateScimToken -- | User code (sent by email), for 2nd factor to 'createScimTokenPassword' createScimTokenCode :: !(Maybe ActivationCode) } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform CreateScimToken) instance A.FromJSON CreateScimToken where parseJSON = A.withObject "CreateScimToken" $ \o -> do createScimTokenDescr <- o A..: "description" createScimTokenPassword <- o A..:? "password" - createScimTokenCode <- o A..:? "code" + createScimTokenCode <- o A..:? "verification_code" pure CreateScimToken {..} -- Used for integration tests @@ -385,7 +387,7 @@ instance A.ToJSON CreateScimToken where A.object [ "description" A..= createScimTokenDescr, "password" A..= createScimTokenPassword, - "code" A..= createScimTokenCode + "verification_code" A..= createScimTokenCode ] -- | Type used for the response of 'APIScimTokenCreate'. @@ -469,7 +471,7 @@ instance ToSchema CreateScimToken where & properties .~ [ ("description", textSchema), ("password", textSchema), - ("code", textSchema) + ("verification_code", textSchema) ] & required .~ ["description"] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index f1bff97d4d5..177d4dd065c 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -25,6 +25,7 @@ import Test.Wire.API.Golden.Manual.ConvIdsPage import Test.Wire.API.Golden.Manual.ConversationCoverView import Test.Wire.API.Golden.Manual.ConversationPagingState import Test.Wire.API.Golden.Manual.ConversationsResponse +import Test.Wire.API.Golden.Manual.CreateScimToken import Test.Wire.API.Golden.Manual.FeatureConfigEvent import Test.Wire.API.Golden.Manual.GetPaginatedConversationIds import Test.Wire.API.Golden.Manual.ListConversations @@ -100,5 +101,12 @@ tests = testObjects [(testObject_ListConversations_1, "testObject_ListConversations_1.json")], testGroup "ConversationsResponse" $ - testObjects [(testObject_ConversationsResponse_1, "testObject_ConversationsResponse_1.json")] + testObjects [(testObject_ConversationsResponse_1, "testObject_ConversationsResponse_1.json")], + testGroup "CreateScimToken" $ + testObjects + [ (testObject_CreateScimToken_1, "testObject_CreateScimToken_1.json"), + (testObject_CreateScimToken_2, "testObject_CreateScimToken_2.json"), + (testObject_CreateScimToken_3, "testObject_CreateScimToken_3.json"), + (testObject_CreateScimToken_4, "testObject_CreateScimToken_4.json") + ] ] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/CreateScimToken.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/CreateScimToken.hs new file mode 100644 index 00000000000..ea00bdf7fa2 --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/CreateScimToken.hs @@ -0,0 +1,52 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Manual.CreateScimToken where + +import Data.Misc (PlainTextPassword (PlainTextPassword)) +import Data.Text.Ascii (AsciiChars (validate)) +import Imports +import Wire.API.User.Activation (ActivationCode (ActivationCode, fromActivationCode)) +import Wire.API.User.Scim (CreateScimToken (..)) + +testObject_CreateScimToken_1 :: CreateScimToken +testObject_CreateScimToken_1 = + CreateScimToken + "description" + (Just (PlainTextPassword "very-geheim")) + (Just ((ActivationCode {fromActivationCode = fromRight undefined (validate "123456")}))) + +testObject_CreateScimToken_2 :: CreateScimToken +testObject_CreateScimToken_2 = + CreateScimToken + "description2" + (Just (PlainTextPassword "secret")) + Nothing + +testObject_CreateScimToken_3 :: CreateScimToken +testObject_CreateScimToken_3 = + CreateScimToken + "description3" + Nothing + (Just ((ActivationCode {fromActivationCode = fromRight undefined (validate "654321")}))) + +testObject_CreateScimToken_4 :: CreateScimToken +testObject_CreateScimToken_4 = + CreateScimToken + "description4" + Nothing + Nothing diff --git a/libs/wire-api/test/golden/testObject_CreateScimToken_1.json b/libs/wire-api/test/golden/testObject_CreateScimToken_1.json new file mode 100644 index 00000000000..3c3d1cbff10 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_CreateScimToken_1.json @@ -0,0 +1,5 @@ +{ + "description": "description", + "password": "very-geheim", + "verification_code": "123456" +} diff --git a/libs/wire-api/test/golden/testObject_CreateScimToken_2.json b/libs/wire-api/test/golden/testObject_CreateScimToken_2.json new file mode 100644 index 00000000000..8364d591e30 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_CreateScimToken_2.json @@ -0,0 +1,5 @@ +{ + "description": "description2", + "password": "secret", + "verification_code": null +} diff --git a/libs/wire-api/test/golden/testObject_CreateScimToken_3.json b/libs/wire-api/test/golden/testObject_CreateScimToken_3.json new file mode 100644 index 00000000000..9b35f1245fc --- /dev/null +++ b/libs/wire-api/test/golden/testObject_CreateScimToken_3.json @@ -0,0 +1,5 @@ +{ + "description": "description3", + "password": null, + "verification_code": "654321" +} diff --git a/libs/wire-api/test/golden/testObject_CreateScimToken_4.json b/libs/wire-api/test/golden/testObject_CreateScimToken_4.json new file mode 100644 index 00000000000..a79a8f35565 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_CreateScimToken_4.json @@ -0,0 +1,5 @@ +{ + "description": "description4", + "password": null, + "verification_code": null +} 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 91364575360..339aeda0da1 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 @@ -66,6 +66,7 @@ import qualified Wire.API.User.Identity as User.Identity import qualified Wire.API.User.Password as User.Password import qualified Wire.API.User.Profile as User.Profile import qualified Wire.API.User.RichInfo as User.RichInfo +import qualified Wire.API.User.Scim as Scim import qualified Wire.API.User.Search as User.Search import qualified Wire.API.Wrapped as Wrapped @@ -181,6 +182,7 @@ tests = testRoundTrip @Push.Token.AppName, testRoundTrip @Push.Token.PushToken, testRoundTrip @Push.Token.PushTokenList, + testRoundTrip @Scim.CreateScimToken, testRoundTrip @Team.BindingNewTeam, testRoundTrip @Team.TeamBinding, testRoundTrip @Team.Team, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 0a7751a8d9c..d59489be994 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -467,6 +467,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList + Test.Wire.API.Golden.Manual.CreateScimToken Test.Wire.API.Golden.Protobuf Test.Wire.API.Golden.Runner Paths_wire_api diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index 71e9133934e..6737abeb2da 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -60,9 +60,6 @@ instance Arbitrary ScimTokenInfo where <*> arbitrary <*> arbitrary -instance Arbitrary CreateScimToken where - arbitrary = CreateScimToken <$> arbitrary <*> arbitrary <*> arbitrary - instance Arbitrary CreateScimTokenResponse where arbitrary = CreateScimTokenResponse <$> arbitrary <*> arbitrary From 5c0e36271c09862cd5a6eae2db11974b93467432 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 16 Feb 2022 16:45:26 +0100 Subject: [PATCH 49/58] correct order of modules (#2136) --- libs/wire-api/wire-api.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index d59489be994..cca067eaaaa 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -390,7 +390,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.Scheme_user Test.Wire.API.Golden.Generated.SearchResult_20Contact_user Test.Wire.API.Golden.Generated.SearchResult_20TeamContact_user - Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user Test.Wire.API.Golden.Generated.SelfProfile_user Test.Wire.API.Golden.Generated.SendActivationCode_user Test.Wire.API.Golden.Generated.SendLoginCode_user @@ -407,6 +406,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.SFTServer_user Test.Wire.API.Golden.Generated.SimpleMember_user Test.Wire.API.Golden.Generated.SimpleMembers_user + Test.Wire.API.Golden.Generated.SndFactorPasswordChallengeAction_user Test.Wire.API.Golden.Generated.Team_team Test.Wire.API.Golden.Generated.TeamBinding_team Test.Wire.API.Golden.Generated.TeamContact_user @@ -461,13 +461,13 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.ConversationPagingState Test.Wire.API.Golden.Manual.ConversationsResponse Test.Wire.API.Golden.Manual.ConvIdsPage + Test.Wire.API.Golden.Manual.CreateScimToken Test.Wire.API.Golden.Manual.FeatureConfigEvent Test.Wire.API.Golden.Manual.GetPaginatedConversationIds Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap Test.Wire.API.Golden.Manual.UserClientPrekeyMap Test.Wire.API.Golden.Manual.UserIdList - Test.Wire.API.Golden.Manual.CreateScimToken Test.Wire.API.Golden.Protobuf Test.Wire.API.Golden.Runner Paths_wire_api From 6972e3d32f59cccc5e27c65e9cd290005f0cbe0d Mon Sep 17 00:00:00 2001 From: Sebastian Willenborg Date: Wed, 16 Feb 2022 17:44:22 +0100 Subject: [PATCH 50/58] FS-444: Limit TLS ciphers to TR-02102-2 compatible ciphers (#2112) Co-authored-by: jschaul --- changelog.d/0-release-notes/TR-02102-2 | 1 + charts/nginx-ingress-controller/values.yaml | 12 ++++++++---- services/federator/src/Federator/Remote.hs | 14 ++++++++------ 3 files changed, 17 insertions(+), 10 deletions(-) create mode 100644 changelog.d/0-release-notes/TR-02102-2 diff --git a/changelog.d/0-release-notes/TR-02102-2 b/changelog.d/0-release-notes/TR-02102-2 new file mode 100644 index 00000000000..5693a4acf0f --- /dev/null +++ b/changelog.d/0-release-notes/TR-02102-2 @@ -0,0 +1 @@ +Change the default set of TLS ciphers (both for the client and the federation APIs) to be compliant to the recommendations of [TR-02102-2](https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html). diff --git a/charts/nginx-ingress-controller/values.yaml b/charts/nginx-ingress-controller/values.yaml index a785cd545a3..1c455d2fb6f 100644 --- a/charts/nginx-ingress-controller/values.yaml +++ b/charts/nginx-ingress-controller/values.yaml @@ -3,8 +3,12 @@ nginx-ingress: controller: config: - # NOTE: These are some sane defaults, you may want to overrride them on your own installation - ssl-ciphers: "ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256" + # NOTE: These are some sane defaults (compliant to TR-02102-2), you may want to overrride them on your own installation + # For TR-02102-2 see https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html + # As a Wire employee, for Wire-internal discussions and context see + # * https://wearezeta.atlassian.net/browse/FS-33 + # * https://wearezeta.atlassian.net/browse/FS-444 + ssl-ciphers: "ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256" http2-max-field-size: 16k http2-max-header-size: 32k proxy-buffer-size: 16k @@ -28,11 +32,11 @@ nginx-ingress: # redirect them to the correct service, whilst maintaining the source ip # address. The ingress controller is sort of taking over the role of what # kube-proxy was doing before. -# More information: +# More information: # https://kubernetes.io/docs/tutorials/services/source-ip/#source-ip-for-services-with-typenodeport # https://kubernetes.github.io/ingress-nginx/deploy/baremetal/ # -# There are also downsides to setting externalTrafficPolicy: Local +# There are also downsides to setting externalTrafficPolicy: Local # Please look at the following blog post, which very clearly explains the upsides and # downsides of this setting # https://www.asykim.com/blog/deep-dive-into-kubernetes-external-traffic-policies diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 9d0222617ae..d831563e7d0 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -161,20 +161,22 @@ mkTLSConfig settings hostname port = TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} } --- FUTUREWORK: get review on blessed ciphers --- (https://wearezeta.atlassian.net/browse/SQCORE-910) +-- Context and possible future work see +-- https://wearezeta.atlassian.net/browse/FS-33 +-- https://wearezeta.atlassian.net/browse/FS-444 +-- https://wearezeta.atlassian.net/browse/FS-443 +-- +-- The current list is compliant to TR-02102-2 +-- https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html blessedCiphers :: [Cipher] blessedCiphers = [ TLS.cipher_TLS13_AES128CCM8_SHA256, TLS.cipher_TLS13_AES128CCM_SHA256, TLS.cipher_TLS13_AES128GCM_SHA256, TLS.cipher_TLS13_AES256GCM_SHA384, - TLS.cipher_TLS13_CHACHA20POLY1305_SHA256, -- For TLS 1.2 (copied from default nginx ingress config): TLS.cipher_ECDHE_ECDSA_AES256GCM_SHA384, TLS.cipher_ECDHE_RSA_AES256GCM_SHA384, - TLS.cipher_ECDHE_RSA_AES128GCM_SHA256, TLS.cipher_ECDHE_ECDSA_AES128GCM_SHA256, - TLS.cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256, - TLS.cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 + TLS.cipher_ECDHE_RSA_AES128GCM_SHA256 ] From 4a52cf07421ede1c59de20208a1a2a003cef858d Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 16 Feb 2022 18:36:20 +0100 Subject: [PATCH 51/58] brig: Add setSftListAllServers config flag (#2139) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Add setSftListAllServers config flag Co-authored-by: Marko Dimjašević --- changelog.d/6-federation/pr-2139 | 1 + charts/brig/templates/configmap.yaml | 3 ++ docs/reference/config-options.md | 29 +++++++++++++++++ services/brig/src/Brig/Calling/API.hs | 16 ++++++---- services/brig/src/Brig/Options.hs | 25 +++++++++++++-- services/brig/test/integration/API/Calling.hs | 2 +- services/brig/test/unit/Test/Brig/Calling.hs | 31 ++++++++++++++----- 7 files changed, 91 insertions(+), 16 deletions(-) create mode 100644 changelog.d/6-federation/pr-2139 diff --git a/changelog.d/6-federation/pr-2139 b/changelog.d/6-federation/pr-2139 new file mode 100644 index 00000000000..f3324ee9f48 --- /dev/null +++ b/changelog.d/6-federation/pr-2139 @@ -0,0 +1 @@ +Add `setSftListAllServers` config flag to brig diff --git a/charts/brig/templates/configmap.yaml b/charts/brig/templates/configmap.yaml index 2a1e2402c31..9f19a4056df 100644 --- a/charts/brig/templates/configmap.yaml +++ b/charts/brig/templates/configmap.yaml @@ -228,5 +228,8 @@ data: {{- if .setSftStaticUrl }} setSftStaticUrl: {{ .setSftStaticUrl }} {{- end }} + {{- if .setSftListAllServers }} + setSftListAllServers: {{ .setSftListAllServers }} + {{- end }} {{- end }} {{- end }} diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index 4dbe4865584..dc6665b1738 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -347,6 +347,35 @@ When a `null` value is encountered, it is assumed to be (Introduced in https://github.com/wireapp/wire-server/pull/1811.) +### SFT configuration + +Configuring SFT load balancing can be done in two (mutually exclusive) settings: + +1) Configuring a SRV DNS record based load balancing setting + +``` +# [brig.yaml] +sft: + sftBaseDomain: sft.wire.example.yourcloud.comk + sftSRVServiceName: sft + sftDiscoveryIntervalSeconds: 10 + sftListLength: 20 +``` + +or + +2) Configuring a HTTP-based load balancing setting + +``` +# [brig.yaml] +settings: + setSftStaticUrl: https://sftd.wire.yourcloud.com +``` + +This setting assumes that the sft load balancer has been deployed witht hte `sftd` helm chart. + +Additionally if `setSftListAllServers` is set to `enabled` (disabled by default) then the `/calls/config/v2` endpoint will include a list of all servers that are load balanced by `setSftStaticUrl` at field `sft_servers_all`. This is required to enable calls between federated instances of Wire. + ### Locale diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 08ef593b8a3..7234760e398 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -32,6 +32,7 @@ import Brig.Calling import qualified Brig.Calling as Calling import Brig.Calling.Internal import Brig.Effects.SFT +import Brig.Options (ListAllSFTServers (..)) import qualified Brig.Options as Opt import Control.Error (hush) import Control.Lens @@ -102,6 +103,7 @@ getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> Handler Public getCallsConfigV2 _ _ limit = do env <- liftIO . readIORef =<< view turnEnvV2 staticUrl <- view $ settings . Opt.sftStaticUrl + sftListAllServers <- fromMaybe Opt.HideAllSFTServers <$> view (settings . Opt.sftListAllServers) sftEnv' <- view sftEnv logger <- view applog manager <- view httpManager @@ -109,7 +111,7 @@ getCallsConfigV2 _ _ limit = do . runM @IO . runTinyLog logger . interpretSFT manager - $ newConfig env staticUrl sftEnv' limit CallsConfigV2 + $ newConfig env staticUrl sftEnv' limit sftListAllServers CallsConfigV2 getCallsConfigH :: JSON ::: UserId ::: ConnId -> Handler Response getCallsConfigH (_ ::: uid ::: connid) = @@ -125,7 +127,7 @@ getCallsConfig _ _ = do . runM @IO . runTinyLog logger . interpretSFT manager - $ newConfig env Nothing Nothing Nothing CallsConfigDeprecated + $ newConfig env Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated where -- In order to avoid being backwards incompatible, remove the `transport` query param from the URIs dropTransport :: Public.RTCConfiguration -> Public.RTCConfiguration @@ -149,9 +151,10 @@ newConfig :: Maybe HttpsUrl -> Maybe SFTEnv -> Maybe (Range 1 10 Int) -> + ListAllSFTServers -> CallsConfigVersion -> Sem r Public.RTCConfiguration -newConfig env sftStaticUrl mSftEnv limit version = do +newConfig env sftStaticUrl mSftEnv limit listAllServers version = do let (sha, secret, tTTL, cTTL, prng) = (env ^. turnSHA512, env ^. turnSecret, env ^. turnTokenTTL, env ^. turnConfigTTL, env ^. turnPrng) -- randomize list of servers (before limiting the list, to ensure not always the same servers are chosen if limit is set) randomizedUris <- liftIO $ randomize (List1.toNonEmpty $ env ^. turnServers) @@ -177,9 +180,10 @@ newConfig env sftStaticUrl mSftEnv limit version = do mSftServersAll :: Maybe [SFTServer] <- case version of CallsConfigDeprecated -> pure Nothing CallsConfigV2 -> - case sftStaticUrl of - Nothing -> pure . Just $ sftServerFromSrvTarget . srvTarget <$> maybe [] toList allSrvEntries - Just url -> hush . unSFTGetResponse <$> sftGetAllServers url + case (listAllServers, sftStaticUrl) of + (HideAllSFTServers, _) -> pure Nothing + (ListAllSFTServers, Nothing) -> pure . Just $ sftServerFromSrvTarget . srvTarget <$> maybe [] toList allSrvEntries + (ListAllSFTServers, Just url) -> hush . unSFTGetResponse <$> sftGetAllServers url let mSftServers = staticSft <|> sftServerFromSrvTarget . srvTarget <$$> srvEntries pure $ Public.rtcConfiguration srvs mSftServers cTTL mSftServersAll diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 17244eeec3b..5c0f617e64f 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -37,6 +37,7 @@ import Data.Id import Data.LanguageCodes (ISO639_1 (EN)) import Data.Misc (HttpsUrl) import Data.Range +import Data.Schema (Schema (Schema), ToSchema (schema), element, enum) import Data.Scientific (toBoundedInteger) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -341,6 +342,20 @@ instance ToJSON EmailVisibility where toJSON EmailVisibleIfOnSameTeam = "visible_if_on_same_team" toJSON EmailVisibleToSelf = "visible_to_self" +data ListAllSFTServers + = ListAllSFTServers + | HideAllSFTServers + deriving (Show, Eq, Ord) + deriving (FromJSON) via Schema ListAllSFTServers + +instance ToSchema ListAllSFTServers where + schema = + enum @Text "ListSFTServers" $ + mconcat + [ element "enabled" ListAllSFTServers, + element "disabled" HideAllSFTServers + ] + -- | Options that are consumed on startup data Opts = Opts -- services @@ -505,7 +520,12 @@ data Settings = Settings -- config will always return this entry. This is useful in Kubernetes -- where SFTs are deployed behind a load-balancer. In the long-run the SRV -- fetching logic can go away completely - setSftStaticUrl :: !(Maybe HttpsUrl) + setSftStaticUrl :: !(Maybe HttpsUrl), + -- | When set the /calls/config/v2 endpoint will include all the + -- loadbalanced servers of `setSftStaticUrl` under the @sft_servers_all@ + -- field. The default setting is to exclude and omit the field from the + -- response. + setSftListAllServers :: Maybe ListAllSFTServers } deriving (Show, Generic) @@ -715,7 +735,8 @@ Lens.makeLensesFor ("setUserMaxPermClients", "userMaxPermClients"), ("setFederationDomain", "federationDomain"), ("setSqsThrottleMillis", "sqsThrottleMillis"), - ("setSftStaticUrl", "sftStaticUrl") + ("setSftStaticUrl", "sftStaticUrl"), + ("setSftListAllServers", "sftListAllServers") ] ''Settings diff --git a/services/brig/test/integration/API/Calling.hs b/services/brig/test/integration/API/Calling.hs index b4d1643e967..85bf7137d7e 100644 --- a/services/brig/test/integration/API/Calling.hs +++ b/services/brig/test/integration/API/Calling.hs @@ -113,7 +113,7 @@ testSFT b opts = do testSFTUnavailble :: Brig -> Opts.Opts -> String -> Http () testSFTUnavailble b opts domain = do uid <- userId <$> randomUser b - withSettingsOverrides (opts {Opts.optSettings = (Opts.optSettings opts) {Opts.setSftStaticUrl = fromByteString (cs domain)}}) $ do + withSettingsOverrides (opts {Opts.optSettings = (Opts.optSettings opts) {Opts.setSftStaticUrl = fromByteString (cs domain), Opts.setSftListAllServers = Just Opts.ListAllSFTServers}}) $ do cfg <- getTurnConfigurationV2 uid b liftIO $ do assertEqual diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index ba2e0152021..83915bcf972 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -114,7 +114,8 @@ tests = [ testCase "deprecated endpoint" testSFTStaticDeprecatedEndpoint, testCase "v2 endpoint, no SFT static URL" testSFTStaticV2NoStaticUrl, testCase "v2 endpoint, SFT static URL without /sft_servers_all.json" testSFTStaticV2StaticUrlError, - testCase "v2 endpoint, SFT static URL with /sft_servers_all.json" testSFTStaticV2StaticUrlList + testCase "v2 endpoint, SFT static URL with /sft_servers_all.json" testSFTStaticV2StaticUrlList, + testCase "v2 endpoint, SFT static URL with with setSftListAllServers \"disabeld\"" testSFTStaticV2ListAllServersDisabled ] ] @@ -284,7 +285,7 @@ testSFTStaticDeprecatedEndpoint = do runM @IO . discardLogs . interpretSFTInMemory mempty - $ newConfig env Nothing Nothing Nothing CallsConfigDeprecated + $ newConfig env Nothing Nothing Nothing HideAllSFTServers CallsConfigDeprecated assertEqual "when SFT static URL is disabled, sft_servers should be empty." Set.empty @@ -308,7 +309,7 @@ testSFTStaticV2NoStaticUrl = do runM @IO . discardLogs . interpretSFTInMemory mempty - $ newConfig env Nothing (Just sftEnv) (Just . unsafeRange $ 2) CallsConfigV2 + $ newConfig env Nothing (Just sftEnv) (Just . unsafeRange $ 2) ListAllSFTServers CallsConfigV2 assertEqual "when SFT static URL is disabled, sft_servers_all should be from SFT environment" (Just . fmap (sftServerFromSrvTarget . srvTarget) . toList $ servers) @@ -323,9 +324,9 @@ testSFTStaticV2StaticUrlError = do . discardLogs . interpretSFTInMemory mempty -- an empty lookup map, meaning there was -- an error - $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 2) CallsConfigV2 + $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 2) ListAllSFTServers CallsConfigV2 assertEqual - "when SFT static URL is enabled, but returns error, sft_servers_all should be omitted" + "when SFT static URL is enabled (and setSftListAllServers is enabled), but returns error, sft_servers_all should be omitted" Nothing (cfg ^. rtcConfSftServersAll) @@ -340,8 +341,24 @@ testSFTStaticV2StaticUrlList = do runM @IO . discardLogs . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse . Right $ servers)) - $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 3) CallsConfigV2 + $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 3) ListAllSFTServers CallsConfigV2 assertEqual - "when SFT static URL is enabled, sft_servers_all should be from /sft_servers_all.json" + "when SFT static URL and setSftListAllServers are enabled, sft_servers_all should be from /sft_servers_all.json" (Just servers) (cfg ^. rtcConfSftServersAll) + +testSFTStaticV2ListAllServersDisabled :: IO () +testSFTStaticV2ListAllServersDisabled = do + (env, staticUrl) <- sftStaticEnv + -- 10 servers compared to the limit of 3 below that should be disregarded + -- for sft_servers_all + servers <- generate $ replicateM 10 arbitrary + cfg <- + runM @IO + . discardLogs + . interpretSFTInMemory (Map.singleton staticUrl (SFTGetResponse . Right $ servers)) + $ newConfig env (Just staticUrl) Nothing (Just . unsafeRange $ 3) HideAllSFTServers CallsConfigV2 + assertEqual + "when SFT static URL is enabled and setSftListAllServers is \"disabled\" then sft_servers_all is missing" + Nothing + (cfg ^. rtcConfSftServersAll) From 8806ffcfec9a951390592dbec40743160682bf21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 16 Feb 2022 22:29:47 +0100 Subject: [PATCH 52/58] WIP: Introduce type variable r to AppT and AppIO --- services/brig/src/Brig/API/Client.hs | 52 ++++---- services/brig/src/Brig/API/Connection.hs | 48 +++---- .../brig/src/Brig/API/Connection/Remote.hs | 6 +- services/brig/src/Brig/API/Connection/Util.hs | 4 +- services/brig/src/Brig/API/Handler.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 12 +- services/brig/src/Brig/API/Properties.hs | 6 +- services/brig/src/Brig/API/Public.hs | 4 +- services/brig/src/Brig/API/User.hs | 122 +++++++++--------- services/brig/src/Brig/API/Util.hs | 8 +- services/brig/src/Brig/AWS/SesNotification.hs | 12 +- services/brig/src/Brig/App.hs | 38 +++--- services/brig/src/Brig/Data/Activation.hs | 10 +- services/brig/src/Brig/Data/Client.hs | 24 ++-- services/brig/src/Brig/Data/Connection.hs | 44 +++---- services/brig/src/Brig/Data/LoginCode.hs | 10 +- services/brig/src/Brig/Data/PasswordReset.hs | 8 +- services/brig/src/Brig/Data/Properties.hs | 12 +- services/brig/src/Brig/Data/User.hs | 72 +++++------ services/brig/src/Brig/Data/UserKey.hs | 14 +- .../src/Brig/Data/UserPendingActivation.hs | 8 +- services/brig/src/Brig/Email.hs | 2 +- services/brig/src/Brig/Federation/Client.hs | 2 +- services/brig/src/Brig/IO/Intra.hs | 102 +++++++-------- services/brig/src/Brig/IO/Journal.hs | 10 +- .../brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/Phone.hs | 22 ++-- services/brig/src/Brig/Provider/API.hs | 8 +- services/brig/src/Brig/Provider/Email.hs | 8 +- services/brig/src/Brig/Provider/RPC.hs | 10 +- services/brig/src/Brig/Queue.hs | 4 +- services/brig/src/Brig/RPC.hs | 8 +- services/brig/src/Brig/Run.hs | 8 +- services/brig/src/Brig/Team/Email.hs | 6 +- services/brig/src/Brig/Team/Util.hs | 4 +- services/brig/src/Brig/User/API/Auth.hs | 4 +- services/brig/src/Brig/User/Auth.hs | 44 +++---- services/brig/src/Brig/User/Auth/Cookie.hs | 22 ++-- services/brig/src/Brig/User/EJPD.hs | 4 +- services/brig/src/Brig/User/Email.hs | 12 +- services/brig/src/Brig/User/Handle.hs | 10 +- services/brig/src/Brig/User/Phone.hs | 12 +- 42 files changed, 410 insertions(+), 410 deletions(-) diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index a265fbc462e..27324a294b9 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -84,18 +84,18 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) -lookupLocalClient :: UserId -> ClientId -> AppIO (Maybe Client) +lookupLocalClient :: UserId -> ClientId -> (AppIO r) (Maybe Client) lookupLocalClient = Data.lookupClient -lookupLocalClients :: UserId -> AppIO [Client] +lookupLocalClients :: UserId -> (AppIO r) [Client] lookupLocalClients = Data.lookupClients -lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe PubClient) +lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe PubClient) lookupPubClient qid cid = do clients <- lookupPubClients qid pure $ find ((== cid) . pubClientId) clients -lookupPubClients :: Qualified UserId -> ExceptT ClientError AppIO [PubClient] +lookupPubClients :: Qualified UserId -> ExceptT ClientError (AppIO r) [PubClient] lookupPubClients qid@(Qualified uid domain) = do getForUser <$> lookupPubClientsBulk [qid] where @@ -104,7 +104,7 @@ lookupPubClients qid@(Qualified uid domain) = do um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap) Set.toList <$> Map.lookup uid um -lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) +lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError (AppIO r) (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do loc <- qualifyLocal () let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids @@ -116,12 +116,12 @@ lookupPubClientsBulk qualifiedUids = do localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) -lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) +lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppIO r) (UserMap (Set PubClient)) lookupLocalPubClientsBulk = Data.lookupPubClientsBulk -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError AppIO Client +addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError (AppIO r) Client addClient u con ip new = do acc <- lift (Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return loc <- maybe (return Nothing) locationOf ip @@ -149,7 +149,7 @@ addClient u con ip new = do where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) -updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError AppIO () +updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError (AppIO r) () updateClient u c r = do client <- lift (Data.lookupClient u c) >>= maybe (throwE ClientNotFound) pure for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just @@ -163,7 +163,7 @@ updateClient u c r = do -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError AppIO () +rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError (AppIO r) () rmClient u con clt pw = maybe (throwE ClientNotFound) fn =<< lift (Data.lookupClient u clt) where @@ -177,14 +177,14 @@ rmClient u con clt pw = _ -> Data.reauthenticate u pw !>> ClientDataError . ClientReAuthError lift $ execDelete u (Just con) client -claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimPrekey protectee u d c = do isLocalDomain <- (d ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekey protectee u c else claimRemotePrekey (Qualified u d) c -claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimLocalPrekey protectee user client = do guardLegalhold protectee (mkUserClients [(user, [client])]) lift $ do @@ -192,27 +192,27 @@ claimLocalPrekey protectee user client = do when (isNothing prekey) (noPrekeys user client) pure prekey -claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimRemotePrekey quser client = fmapLT ClientFederationError $ Federation.claimPrekey quser client -claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError AppIO PrekeyBundle +claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimPrekeyBundle protectee domain uid = do isLocalDomain <- (domain ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekeyBundle protectee uid else claimRemotePrekeyBundle (Qualified uid domain) -claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError AppIO PrekeyBundle +claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimLocalPrekeyBundle protectee u = do clients <- map clientId <$> Data.lookupClients u guardLegalhold protectee (mkUserClients [(u, clients)]) PrekeyBundle u . catMaybes <$> lift (mapM (Data.claimPrekey u) clients) -claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError AppIO PrekeyBundle +claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimRemotePrekeyBundle quser = do Federation.claimPrekeyBundle quser !>> ClientFederationError -claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError AppIO QualifiedUserClientPrekeyMap +claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppIO r) QualifiedUserClientPrekeyMap claimMultiPrekeyBundles protectee quc = do loc <- qualifyLocal () let (locals, remotes) = @@ -232,17 +232,17 @@ claimMultiPrekeyBundles protectee quc = do where claimRemote :: Remote UserClients -> - ExceptT FederationError AppIO (Qualified UserClientPrekeyMap) + ExceptT FederationError (AppIO r) (Qualified UserClientPrekeyMap) claimRemote ruc = qUntagged . qualifyAs ruc <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) - claimLocal :: Local UserClients -> ExceptT ClientError AppIO (Qualified UserClientPrekeyMap) + claimLocal :: Local UserClients -> ExceptT ClientError (AppIO r) (Qualified UserClientPrekeyMap) claimLocal luc = qUntagged . qualifyAs luc <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) -claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap +claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) UserClientPrekeyMap claimLocalMultiPrekeyBundles protectee userClients = do guardLegalhold protectee userClients lift @@ -253,13 +253,13 @@ claimLocalMultiPrekeyBundles protectee userClients = do . Message.userClients $ userClients where - getChunk :: Map UserId (Set ClientId) -> AppIO (Map UserId (Map ClientId (Maybe Prekey))) + getChunk :: Map UserId (Set ClientId) -> (AppIO r) (Map UserId (Map ClientId (Maybe Prekey))) getChunk = runConcurrently . Map.traverseWithKey (\u -> Concurrently . getUserKeys u) - getUserKeys :: UserId -> Set ClientId -> AppIO (Map ClientId (Maybe Prekey)) + getUserKeys :: UserId -> Set ClientId -> (AppIO r) (Map ClientId (Maybe Prekey)) getUserKeys u = sequenceA . Map.fromSet (getClientKeys u) - getClientKeys :: UserId -> ClientId -> AppIO (Maybe Prekey) + getClientKeys :: UserId -> ClientId -> (AppIO r) (Maybe Prekey) getClientKeys u c = do key <- fmap prekeyData <$> Data.claimPrekey u c when (isNothing key) $ noPrekeys u c @@ -268,7 +268,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- Utilities -- | Perform an orderly deletion of an existing client. -execDelete :: UserId -> Maybe ConnId -> Client -> AppIO () +execDelete :: UserId -> Maybe ConnId -> Client -> (AppIO r) () execDelete u con c = do Intra.rmClient u (clientId c) for_ (clientCookie c) $ \l -> Auth.revokeCookies u [] [l] @@ -280,7 +280,7 @@ execDelete u con c = do -- not exist, since there must be no client without prekeys, -- thus repairing any inconsistencies related to distributed -- (and possibly duplicated) client data. -noPrekeys :: UserId -> ClientId -> AppIO () +noPrekeys :: UserId -> ClientId -> (AppIO r) () noPrekeys u c = do Log.info $ field "user" (toByteString u) @@ -301,7 +301,7 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> AppIO () +legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppIO r) () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = Intra.onUserEvent targetUser Nothing lhClientEvent where @@ -312,7 +312,7 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: UserId -> AppIO () +removeLegalHoldClient :: UserId -> (AppIO r) () removeLegalHoldClient uid = do clients <- Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 9495087c814..edd34648904 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -59,7 +59,7 @@ import Wire.API.Connection (RelationWithHistory (..)) import Wire.API.ErrorDescription import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -ensureIsActivated :: Local UserId -> MaybeT AppIO () +ensureIsActivated :: Local UserId -> MaybeT (AppIO r) () ensureIsActivated lusr = do active <- lift $ Data.isActivated (tUnqualified lusr) guard active @@ -109,7 +109,7 @@ createConnectionToLocalUser self conn target = do checkLimit self Created <$> insert Nothing Nothing where - insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection + insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError (AppIO r) UserConnection insert s2o o2s = lift $ do Log.info $ logConnection (tUnqualified self) (qUntagged target) @@ -124,7 +124,7 @@ createConnectionToLocalUser self conn target = do mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' - update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) @@ -139,7 +139,7 @@ createConnectionToLocalUser self conn target = do (_, Pending) -> resend s2o o2s (_, Cancelled) -> resend s2o o2s - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) accept s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -161,7 +161,7 @@ createConnectionToLocalUser self conn target = do lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' - resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) resend s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -171,17 +171,17 @@ createConnectionToLocalUser self conn target = do s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' - change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) change c s = Existed <$> lift (Data.updateConnection c s) -- | Throw error if one user has a LH device and the other status `no_consent` or vice versa. -- -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. -checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError AppIO () +checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError (AppIO r) () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = - -- Does not fit into 'ExceptT', so throw in 'AppIO'. Anyway at the time of writing + -- Does not fit into 'ExceptT', so throw in '(AppIO r)'. Anyway at the time of writing -- this, users are guaranteed to exist when called from 'createConnectionToLocalUser'. maybe (throwM (errorDescriptionTypeToWai @UserNotFound)) return @@ -279,7 +279,7 @@ updateConnectionToLocalUser self other newStatus conn = do in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) accept s2o o2s = do checkLimit self Log.info $ @@ -301,7 +301,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory - block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + block :: UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) block s2o = lift $ do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -309,7 +309,7 @@ updateConnectionToLocalUser self other newStatus conn = do traverse_ (Intra.blockConv self conn) (ucConvId s2o) Just <$> Data.updateConnection s2o BlockedWithHistory - unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) + unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) unblock s2o o2s new = do -- FUTUREWORK: new is always in [Sent, Accepted]. Refactor to total function. when (new `elem` [Sent, Accepted]) $ @@ -330,7 +330,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) cancel s2o o2s = do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -342,7 +342,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled - change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) + change :: UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled lift $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) @@ -350,7 +350,7 @@ updateConnectionToLocalUser self other newStatus conn = do localConnection :: Local UserId -> Local UserId -> - ExceptT ConnectionError AppIO UserConnection + ExceptT ConnectionError (AppIO r) UserConnection localConnection la lb = do lift (Data.lookupConnection la (qUntagged lb)) >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) @@ -375,7 +375,7 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: UpdateConnectionsInternal -> - ExceptT ConnectionError AppIO () + ExceptT ConnectionError (AppIO r) () updateConnectionInternal = \case BlockForMissingLHConsent uid others -> do self <- qualifyLocal uid @@ -391,7 +391,7 @@ updateConnectionInternal = \case other where -- inspired by @block@ in 'updateConnection'. - blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () + blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError (AppIO r) () blockForMissingLegalholdConsent self others = do for_ others $ \(qualifyAs self -> other) -> do Log.info $ @@ -407,7 +407,7 @@ updateConnectionInternal = \case let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing Intra.onConnectionEvent (tUnqualified self) Nothing ev - removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () + removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppIO r) () removeLHBlocksInvolving self = iterateConnections self (toRange (Proxy @500)) $ \conns -> do for_ conns $ \s2o -> @@ -422,10 +422,10 @@ updateConnectionInternal = \case unblockDirected s2o o2s unblockDirected o2s s2o where - iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () + iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError (AppIO r) ()) -> ExceptT ConnectionError (AppIO r) () iterateConnections user pageSize handleConns = go Nothing where - go :: Maybe UserId -> ExceptT ConnectionError (AppT IO) () + go :: Maybe UserId -> ExceptT ConnectionError (AppT r IO) () go mbStart = do page <- lift $ Data.lookupLocalConnections user mbStart pageSize handleConns (resultList page) @@ -436,7 +436,7 @@ updateConnectionInternal = \case else pure () [] -> pure () - unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO () + unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) () unblockDirected uconn uconnRev = do lfrom <- qualifyLocal (ucFrom uconnRev) void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing @@ -451,7 +451,7 @@ updateConnectionInternal = \case } lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent - relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory + relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError (AppIO r) RelationWithHistory relationWithHistory self target = lift (Data.lookupRelationWithHistory self target) >>= tryJust (NotConnected (tUnqualified self) target) @@ -473,18 +473,18 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory -createLocalConnectionUnchecked :: Local UserId -> Local UserId -> AppIO () +createLocalConnectionUnchecked :: Local UserId -> Local UserId -> (AppIO r) () createLocalConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv void $ Data.insertConnection other (qUntagged self) AcceptedWithHistory qcnv -createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> AppIO () +createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> (AppIO r) () createRemoteConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv -lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList +lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) UserConnectionList lookupConnections from start size = do lusr <- qualifyLocal from rs <- Data.lookupLocalConnections lusr start size diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 1e8190f203e..f4a535d9bbf 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -108,7 +108,7 @@ updateOne2OneConv :: Maybe (Qualified ConvId) -> Relation -> Actor -> - AppIO (Qualified ConvId) + (AppIO r) (Qualified ConvId) updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do let request = UpsertOne2OneConversationRequest @@ -181,7 +181,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. -pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () +pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppIO r) () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing Intra.onConnectionEvent (tUnqualified self) mzcon event @@ -238,7 +238,7 @@ performRemoteAction :: Remote UserId -> Maybe UserConnection -> RemoteConnectionAction -> - AppIO (Maybe RemoteConnectionAction) + (AppIO r) (Maybe RemoteConnectionAction) performRemoteAction self other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection let rel1 = transition (RCA action) rel0 diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index b4730b0eaaa..606e98388a4 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -33,11 +33,11 @@ import Data.Qualified (Local, tUnqualified) import Imports import Wire.API.Connection (Relation (..)) -type ConnectionM = ExceptT ConnectionError AppIO +type ConnectionM = ExceptT ConnectionError (AppIO r) -- Helpers -checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () +checkLimit :: Local UserId -> ExceptT ConnectionError (AppIO r) () checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index b88d1efdf80..237ab7430c5 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -64,7 +64,7 @@ import System.Logger.Class (Logger) ------------------------------------------------------------------------------- -- HTTP Handler Monad -type Handler = ExceptT Error AppIO +type Handler = ExceptT Error (AppIO r) runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived runHandler e r h k = do diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 355e5ca1b9d..26cc9ce56e1 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -303,7 +303,7 @@ internalListClientsH :: JSON ::: JsonRequest UserSet -> Handler Response internalListClientsH (_ ::: req) = do json <$> (lift . internalListClients =<< parseJsonBody req) -internalListClients :: UserSet -> AppIO UserClients +internalListClients :: UserSet -> (AppIO r) UserClients internalListClients (UserSet usrs) = do UserClients . Map.fromList <$> API.lookupUsersClientIds (Set.toList usrs) @@ -312,7 +312,7 @@ internalListFullClientsH :: JSON ::: JsonRequest UserSet -> Handler Response internalListFullClientsH (_ ::: req) = json <$> (lift . internalListFullClients =<< parseJsonBody req) -internalListFullClients :: UserSet -> AppIO UserClientsFull +internalListFullClients :: UserSet -> (AppIO r) UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> Data.lookupClientsBulk (Set.toList usrs) @@ -371,7 +371,7 @@ listActivatedAccountsH :: JSON ::: Either (List UserId) (List Handle) ::: Bool - listActivatedAccountsH (_ ::: qry ::: includePendingInvitations) = do json <$> lift (listActivatedAccounts qry includePendingInvitations) -listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> AppIO [UserAccount] +listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> (AppIO r) [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of @@ -380,10 +380,10 @@ listActivatedAccounts elh includePendingInvitations = do us <- mapM (API.lookupHandle) (fromList hs) byIds (catMaybes us) where - byIds :: [UserId] -> AppIO [UserAccount] + byIds :: [UserId] -> (AppIO r) [UserAccount] byIds uids = API.lookupAccounts uids >>= filterM accountValid - accountValid :: UserAccount -> AppIO Bool + accountValid :: UserAccount -> (AppIO r) Bool accountValid account = case userIdentity . accountUser $ account of Nothing -> pure False Just ident -> @@ -426,7 +426,7 @@ getPasswordResetCodeH :: JSON ::: Either Email Phone -> Handler Response getPasswordResetCodeH (_ ::: emailOrPhone) = do maybe (throwStd invalidPwResetKey) (pure . json) =<< lift (getPasswordResetCode emailOrPhone) -getPasswordResetCode :: Either Email Phone -> AppIO (Maybe GetPasswordResetCodeResp) +getPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe GetPasswordResetCodeResp) getPasswordResetCode emailOrPhone = do GetPasswordResetCodeResp <$$> API.lookupPasswordResetCode emailOrPhone diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index d6c3e00cd18..48d5af9e9c1 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -36,17 +36,17 @@ import Control.Error import Data.Id import Imports -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () +setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () setProperty u c k v = do Data.insertProperty u k v lift $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: UserId -> ConnId -> PropertyKey -> AppIO () +deleteProperty :: UserId -> ConnId -> PropertyKey -> (AppIO r) () deleteProperty u c k = do Data.deleteProperty u k Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: UserId -> ConnId -> AppIO () +clearProperties :: UserId -> ConnId -> (AppIO r) () clearProperties u c = do Data.clearProperties u Intra.onPropertyEvent u c (PropertiesCleared u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index f1c7bef947f..b547f10bd1b 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -724,7 +724,7 @@ createUser (Public.NewUserPublic new) = do UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel pure $ CreateUserResponse cok userId (Public.SelfProfile usr) where - sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> AppIO () + sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppIO r) () sendActivationEmail e u p l mTeamUser | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, @@ -733,7 +733,7 @@ createUser (Public.NewUserPublic new) = do | otherwise = sendActivationMail e u p l Nothing - sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> AppIO () + sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppIO r) () -- NOTE: Welcome e-mails for the team creator are not dealt by brig anymore sendWelcomeEmail e (CreateUserTeam t n) newUser l = case newUser of Public.NewTeamCreator _ -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ccbb7df3623..0a28a189e7d 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -163,7 +163,7 @@ data AllowSCIMUpdates ------------------------------------------------------------------------------- -- Create User -verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError AppIO () +verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError (AppIO r) () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk blacklisted <- lift $ Blacklist.exists uk @@ -177,7 +177,7 @@ verifyUniquenessAndCheckBlacklist uk = do DuplicateUserKey k -- docs/reference/user/registration.md {#RefRegistration} -createUser :: NewUser -> ExceptT CreateUserError AppIO CreateUserResult +createUser :: NewUser -> ExceptT CreateUserError (AppIO r) CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -276,7 +276,7 @@ createUser new = do where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT IO) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT r IO) (Maybe Email, Maybe Phone) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> @@ -297,7 +297,7 @@ createUser new = do pure (email, phone) - findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError AppIO (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError (AppIO r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE MissingIdentity findTeamInvitation (Just e) c = lift (Team.lookupInvitationInfo c) >>= \case @@ -311,7 +311,7 @@ createUser new = do _ -> throwE InvalidInvitationCode Nothing -> throwE InvalidInvitationCode - ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError AppIO () + ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError (AppIO r) () ensureMemberCanJoin tid = do maxSize <- fromIntegral . setMaxTeamSize <$> view settings (TeamSize teamSize) <- TeamSize.teamSize tid @@ -330,7 +330,7 @@ createUser new = do Team.InvitationInfo -> UserKey -> UserIdentity -> - ExceptT CreateUserError (AppT IO) () + ExceptT CreateUserError (AppT r IO) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) ok <- lift $ Data.claimKey uk uid @@ -352,7 +352,7 @@ createUser new = do Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError (AppIO r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) added <- lift $ Intra.addTeamMember uid tid (Nothing, Team.defaultRole) @@ -369,7 +369,7 @@ createUser new = do pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT IO) (Maybe Activation) + handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) handleEmailActivation email uid newTeam = do fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do @@ -386,7 +386,7 @@ createUser new = do return Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT IO) (Maybe Activation) + handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) handlePhoneActivation phone uid = do pdata <- fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of Nothing -> do @@ -403,7 +403,7 @@ createUser new = do return Nothing pure pdata -initAccountFeatureConfig :: UserId -> AppIO () +initAccountFeatureConfig :: UserId -> (AppIO r) () initAccountFeatureConfig uid = do mbCciDefNew <- view (settings . getAfcConferenceCallingDefNewMaybe) forM_ mbCciDefNew $ Data.updateFeatureConferenceCalling uid . Just @@ -411,7 +411,7 @@ initAccountFeatureConfig uid = do -- | 'createUser' is becoming hard to maintian, and instead of adding more case distinctions -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. -createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error AppIO UserAccount +createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error (AppIO r) UserAccount createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`catchE` (throwE . Error.newUserError)) $ do email <- either (throwE . InvalidEmail rawEmail) pure (validateEmail rawEmail) let emKey = userEmailKey email @@ -438,7 +438,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. -checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError AppIO () +checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError (AppIO r) () checkRestrictedUserCreation new = do restrictPlease <- lift . asks $ fromMaybe False . setRestrictUserCreation . view settings when @@ -451,7 +451,7 @@ checkRestrictedUserCreation new = do ------------------------------------------------------------------------------- -- Update Profile -updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError AppIO () +updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError (AppIO r) () updateUser uid mconn uu allowScim = do for_ (uupName uu) $ \newName -> do mbUser <- lift $ Data.lookupUser WithPendingInvitations uid @@ -469,7 +469,7 @@ updateUser uid mconn uu allowScim = do ------------------------------------------------------------------------------- -- Update Locale -changeLocale :: UserId -> ConnId -> LocaleUpdate -> AppIO () +changeLocale :: UserId -> ConnId -> LocaleUpdate -> (AppIO r) () changeLocale uid conn (LocaleUpdate loc) = do Data.updateLocale uid loc Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) @@ -477,7 +477,7 @@ changeLocale uid conn (LocaleUpdate loc) = do ------------------------------------------------------------------------------- -- Update ManagedBy -changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> AppIO () +changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> (AppIO r) () changeManagedBy uid conn (ManagedByUpdate mb) = do Data.updateManagedBy uid mb Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) @@ -485,7 +485,7 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do -------------------------------------------------------------------------------- -- Change Handle -changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError AppIO () +changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError (AppIO r) () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid @@ -539,7 +539,7 @@ checkHandle uhandle = do -------------------------------------------------------------------------------- -- Check Handles -checkHandles :: [Handle] -> Word -> AppIO [Handle] +checkHandles :: [Handle] -> Word -> (AppIO r) [Handle] checkHandles check num = reverse <$> collectFree [] check num where collectFree free _ 0 = return free @@ -558,7 +558,7 @@ checkHandles check num = reverse <$> collectFree [] check num -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error AppIO ChangeEmailResponse +changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error (AppIO r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -576,7 +576,7 @@ changeSelfEmail u email allowScim = do (userIdentity usr) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError AppIO ChangeEmailResult +changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError (AppIO r) ChangeEmailResult changeEmail u email allowScim = do em <- either @@ -608,7 +608,7 @@ changeEmail u email allowScim = do ------------------------------------------------------------------------------- -- Change Phone -changePhone :: UserId -> Phone -> ExceptT ChangePhoneError AppIO (Activation, Phone) +changePhone :: UserId -> Phone -> ExceptT ChangePhoneError (AppIO r) (Activation, Phone) changePhone u phone = do canonical <- maybe @@ -633,7 +633,7 @@ changePhone u phone = do ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () +removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () removeEmail uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -647,7 +647,7 @@ removeEmail uid conn = do ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () +removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -665,7 +665,7 @@ removePhone uid conn = do ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity -revokeIdentity :: Either Email Phone -> AppIO () +revokeIdentity :: Either Email Phone -> (AppIO r) () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- Data.lookupKey uk @@ -697,7 +697,7 @@ revokeIdentity key = do ------------------------------------------------------------------------------- -- Change Account Status -changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError AppIO () +changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError (AppIO r) () changeAccountStatus usrs status = do e <- ask ev <- case status of @@ -708,12 +708,12 @@ changeAccountStatus usrs status = do PendingInvitation -> throwE InvalidAccountStatus liftIO $ mapConcurrently_ (runAppT e . (update ev)) usrs where - update :: (UserId -> UserEvent) -> UserId -> AppIO () + update :: (UserId -> UserEvent) -> UserId -> (AppIO r) () update ev u = do Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) -suspendAccount :: HasCallStack => List1 UserId -> AppIO () +suspendAccount :: HasCallStack => List1 UserId -> (AppIO r) () suspendAccount usrs = runExceptT (changeAccountStatus usrs Suspended) >>= \case Right _ -> pure () @@ -727,7 +727,7 @@ activate :: ActivationCode -> -- | The user for whom to activate the key. Maybe UserId -> - ExceptT ActivationError AppIO ActivationResult + ExceptT ActivationError (AppIO r) ActivationResult activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: @@ -738,7 +738,7 @@ activateWithCurrency :: -- | Potential currency update. -- ^ TODO: to be removed once billing supports currency changes after team creation Maybe Currency.Alpha -> - ExceptT ActivationError AppIO ActivationResult + ExceptT ActivationError (AppIO r) ActivationResult activateWithCurrency tgt code usr cur = do key <- mkActivationKey tgt Log.info $ @@ -759,12 +759,12 @@ activateWithCurrency tgt code usr cur = do tid <- Intra.getTeamId uid for_ tid $ \t -> Intra.changeTeamStatus t Team.Active cur -preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError AppIO () +preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError (AppIO r) () preverify tgt code = do key <- mkActivationKey tgt void $ Data.verifyCode key code -onActivated :: ActivationEvent -> AppIO (UserId, Maybe UserIdentity, Bool) +onActivated :: ActivationEvent -> (AppIO r) (UserId, Maybe UserIdentity, Bool) onActivated (AccountActivated account) = do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") @@ -779,7 +779,7 @@ onActivated (PhoneActivated uid phone) = do return (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} -sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError AppIO () +sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppIO r) () sendActivationCode emailOrPhone loc call = case emailOrPhone of Left email -> do ek <- @@ -861,7 +861,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of _otherwise -> sendActivationMail em name p loc' ident -mkActivationKey :: ActivationTarget -> ExceptT ActivationError AppIO ActivationKey +mkActivationKey :: ActivationTarget -> ExceptT ActivationError (AppIO r) ActivationKey mkActivationKey (ActivateKey k) = return k mkActivationKey (ActivateEmail e) = do ek <- @@ -881,7 +881,7 @@ mkActivationKey (ActivatePhone p) = do ------------------------------------------------------------------------------- -- Password Management -changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError AppIO () +changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError (AppIO r) () changePassword uid cp = do activated <- lift $ Data.isActivated uid unless activated $ @@ -898,7 +898,7 @@ changePassword uid cp = do throwE ChangePasswordMustDiffer lift $ Data.updatePassword uid newpw >> revokeAllCookies uid -beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError AppIO (UserId, PasswordResetPair) +beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError (AppIO r) (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target user <- lift (Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) return @@ -911,7 +911,7 @@ beginPasswordReset target = do throwE (PasswordResetInProgress Nothing) (user,) <$> lift (Data.createPasswordResetCode user target) -completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError AppIO () +completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () completePasswordReset ident code pw = do key <- mkPasswordResetKey ident muid :: Maybe UserId <- lift $ Data.verifyPasswordResetCode (key, code) @@ -927,14 +927,14 @@ completePasswordReset ident code pw = do -- | Pull the current password of a user and compare it against the one about to be installed. -- If the two are the same, throw an error. If no current password can be found, do nothing. -checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError AppIO () +checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () checkNewIsDifferent uid pw = do mcurrpw <- lift $ Data.lookupPassword uid case mcurrpw of Just currpw | verifyPassword pw currpw -> throwE ResetPasswordMustDiffer _ -> pure () -mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError AppIO PasswordResetKey +mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError (AppIO r) PasswordResetKey mkPasswordResetKey ident = case ident of PasswordResetIdentityKey k -> return k PasswordResetEmailIdentity e -> user (userEmailKey e) >>= liftIO . Data.mkPasswordResetKey @@ -953,7 +953,7 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. -deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError AppIO (Maybe Timeout) +deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppIO r) (Maybe Timeout) deleteUser uid pwd = do account <- lift $ Data.lookupAccount uid case account of @@ -965,7 +965,7 @@ deleteUser uid pwd = do Ephemeral -> go a PendingInvitation -> go a where - ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT IO) () + ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT r IO) () ensureNotOwner acc = do case userTeam $ accountUser acc of Nothing -> pure () @@ -1026,7 +1026,7 @@ deleteUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. -verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError AppIO () +verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError (AppIO r) () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d @@ -1040,7 +1040,7 @@ verifyDeleteUser d = do -- via deleting self. -- Team owners can be deleted if the team is not orphaned, i.e. there is at least one -- other owner left. -deleteAccount :: UserAccount -> AppIO () +deleteAccount :: UserAccount -> (AppIO r) () deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") @@ -1081,14 +1081,14 @@ deleteAccount account@(accountUser -> user) = do ------------------------------------------------------------------------------- -- Lookups -lookupActivationCode :: Either Email Phone -> AppIO (Maybe ActivationPair) +lookupActivationCode :: Either Email Phone -> (AppIO r) (Maybe ActivationPair) lookupActivationCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone k <- liftIO $ Data.mkActivationKey uk c <- fmap snd <$> Data.lookupActivationCode uk return $ (k,) <$> c -lookupPasswordResetCode :: Either Email Phone -> AppIO (Maybe PasswordResetPair) +lookupPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe PasswordResetPair) lookupPasswordResetCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone usr <- Data.lookupKey uk @@ -1099,12 +1099,12 @@ lookupPasswordResetCode emailOrPhone = do c <- Data.lookupPasswordResetCode u return $ (k,) <$> c -deleteUserNoVerify :: UserId -> AppIO () +deleteUserNoVerify :: UserId -> (AppIO r) () deleteUserNoVerify uid = do queue <- view internalEvents Queue.enqueue queue (Internal.DeleteUser uid) -deleteUsersNoVerify :: [UserId] -> AppIO () +deleteUsersNoVerify :: [UserId] -> (AppIO r) () deleteUsersNoVerify uids = do for_ uids deleteUserNoVerify m <- view metrics @@ -1113,7 +1113,7 @@ deleteUsersNoVerify uids = do -- | Garbage collect users if they're ephemeral and they have expired. -- Always returns the user (deletion itself is delayed) -userGC :: User -> AppIO User +userGC :: User -> (AppIO r) User userGC u = case (userExpire u) of Nothing -> return u (Just (fromUTCTimeMillis -> e)) -> do @@ -1123,7 +1123,7 @@ userGC u = case (userExpire u) of deleteUserNoVerify (userId u) return u -lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) +lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError (AppIO r) (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfilesFromDomain @@ -1140,7 +1140,7 @@ lookupProfiles :: Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> - ExceptT FederationError AppIO [UserProfile] + ExceptT FederationError (AppIO r) [UserProfile] lookupProfiles self others = fmap concat $ traverseConcurrentlyWithErrors @@ -1148,14 +1148,14 @@ lookupProfiles self others = (bucketQualified others) lookupProfilesFromDomain :: - Local UserId -> Qualified [UserId] -> ExceptT FederationError AppIO [UserProfile] + Local UserId -> Qualified [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] lookupProfilesFromDomain self = foldQualified self (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) lookupRemoteProfiles -lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] lookupRemoteProfiles (qUntagged -> Qualified uids domain) = Federation.getUsersByIds domain uids @@ -1167,7 +1167,7 @@ lookupLocalProfiles :: Maybe UserId -> -- | The users ('others') for which to obtain the profiles. [UserId] -> - AppIO [UserProfile] + (AppIO r) [UserProfile] lookupLocalProfiles requestingUser others = do users <- Data.lookupUsers NoPendingInvitations others >>= mapM userGC css <- case requestingUser of @@ -1186,7 +1186,7 @@ lookupLocalProfiles requestingUser others = do toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - getSelfInfo :: UserId -> AppIO (Maybe (TeamId, Team.TeamMember)) + getSelfInfo :: UserId -> (AppIO r) (Maybe (TeamId, Team.TeamMember)) getSelfInfo selfId = do -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') -- to return 'Nothing'. we could throw errors here if that happens, rather than just @@ -1206,10 +1206,10 @@ lookupLocalProfiles requestingUser others = do else publicProfile u userLegalHold in baseProfile {profileEmail = profileEmail'} -getLegalHoldStatus :: UserId -> AppIO (Maybe UserLegalHoldStatus) +getLegalHoldStatus :: UserId -> (AppIO r) (Maybe UserLegalHoldStatus) getLegalHoldStatus uid = traverse (getLegalHoldStatus' . accountUser) =<< lookupAccount uid -getLegalHoldStatus' :: User -> AppIO UserLegalHoldStatus +getLegalHoldStatus' :: User -> (AppIO r) UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus @@ -1241,7 +1241,7 @@ getEmailForProfile _ EmailVisibleToSelf' = Nothing -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> AppIO [UserAccount] +lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppIO r) [UserAccount] lookupAccountsByIdentity emailOrPhone includePendingInvitations = do let uk = either userEmailKey userPhoneKey emailOrPhone activeUid <- Data.lookupKey uk @@ -1251,26 +1251,26 @@ lookupAccountsByIdentity emailOrPhone includePendingInvitations = do then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result -isBlacklisted :: Either Email Phone -> AppIO Bool +isBlacklisted :: Either Email Phone -> (AppIO r) Bool isBlacklisted emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.exists uk -blacklistInsert :: Either Email Phone -> AppIO () +blacklistInsert :: Either Email Phone -> (AppIO r) () blacklistInsert emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.insert uk -blacklistDelete :: Either Email Phone -> AppIO () +blacklistDelete :: Either Email Phone -> (AppIO r) () blacklistDelete emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.delete uk -phonePrefixGet :: PhonePrefix -> AppIO [ExcludedPrefix] +phonePrefixGet :: PhonePrefix -> (AppIO r) [ExcludedPrefix] phonePrefixGet prefix = Blacklist.getAllPrefixes prefix -phonePrefixDelete :: PhonePrefix -> AppIO () +phonePrefixDelete :: PhonePrefix -> (AppIO r) () phonePrefixDelete = Blacklist.deletePrefix -phonePrefixInsert :: ExcludedPrefix -> AppIO () +phonePrefixInsert :: ExcludedPrefix -> (AppIO r) () phonePrefixInsert = Blacklist.insertPrefix diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 58d90d80c28..4f5ecbcb9c9 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -57,7 +57,7 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> AppIO (Maybe UserIdentity) +fetchUserIdentity :: UserId -> (AppIO r) (Maybe UserIdentity) fetchUserIdentity uid = lookupSelfProfile uid >>= maybe @@ -65,7 +65,7 @@ fetchUserIdentity uid = (return . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) +lookupSelfProfile :: UserId -> (AppIO r) (Maybe SelfProfile) lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount where mk a = SelfProfile (accountUser a) @@ -83,9 +83,9 @@ logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCod -- | Traverse concurrently and fail on first error. traverseConcurrentlyWithErrors :: (Traversable t, Exception e) => - (a -> ExceptT e AppIO b) -> + (a -> ExceptT e (AppIO r) b) -> t a -> - ExceptT e AppIO (t b) + ExceptT e (AppIO r) (t b) traverseConcurrentlyWithErrors f = ExceptT . try . (traverse (either throwIO pure) =<<) . pooledMapConcurrentlyN 8 (runExceptT . f) diff --git a/services/brig/src/Brig/AWS/SesNotification.hs b/services/brig/src/Brig/AWS/SesNotification.hs index 1bcdccfc829..f4b10a0180f 100644 --- a/services/brig/src/Brig/AWS/SesNotification.hs +++ b/services/brig/src/Brig/AWS/SesNotification.hs @@ -29,27 +29,27 @@ import Imports import System.Logger.Class (field, msg, (~~)) import qualified System.Logger.Class as Log -onEvent :: SESNotification -> AppIO () +onEvent :: SESNotification -> (AppIO r) () onEvent (MailBounce BouncePermanent es) = onPermanentBounce es onEvent (MailBounce BounceTransient es) = onTransientBounce es onEvent (MailBounce BounceUndetermined es) = onUndeterminedBounce es onEvent (MailComplaint es) = onComplaint es -onPermanentBounce :: [Email] -> AppIO () +onPermanentBounce :: [Email] -> (AppIO r) () onPermanentBounce = mapM_ $ \e -> do logEmailEvent "Permanent bounce" e Blacklist.insert (userEmailKey e) -onTransientBounce :: [Email] -> AppIO () +onTransientBounce :: [Email] -> (AppIO r) () onTransientBounce = mapM_ (logEmailEvent "Transient bounce") -onUndeterminedBounce :: [Email] -> AppIO () +onUndeterminedBounce :: [Email] -> (AppIO r) () onUndeterminedBounce = mapM_ (logEmailEvent "Undetermined bounce") -onComplaint :: [Email] -> AppIO () +onComplaint :: [Email] -> (AppIO r) () onComplaint = mapM_ $ \e -> do logEmailEvent "Complaint" e Blacklist.insert (userEmailKey e) -logEmailEvent :: Text -> Email -> AppIO () +logEmailEvent :: Text -> Email -> (AppIO r) () logEmailEvent t e = Log.info $ field "email" (fromEmail e) ~~ msg t diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index dc4c9ecc3e2..cb48e47c77f 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -419,13 +419,13 @@ initCredentials secretFile = do dat <- loadSecret secretFile return $ either (\e -> error $ "Could not load secrets from " ++ show secretFile ++ ": " ++ e) id dat -userTemplates :: Monad m => Maybe Locale -> AppT m (Locale, UserTemplates) +userTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, UserTemplates) userTemplates l = forLocale l <$> view usrTemplates -providerTemplates :: Monad m => Maybe Locale -> AppT m (Locale, ProviderTemplates) +providerTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, ProviderTemplates) providerTemplates l = forLocale l <$> view provTemplates -teamTemplates :: Monad m => Maybe Locale -> AppT m (Locale, TeamTemplates) +teamTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, TeamTemplates) teamTemplates l = forLocale l <$> view tmTemplates closeEnv :: Env -> IO () @@ -437,7 +437,7 @@ closeEnv e = do ------------------------------------------------------------------------------- -- App Monad -newtype AppT m a = AppT +newtype AppT r m a = AppT { unAppT :: ReaderT Env m a } deriving newtype @@ -454,58 +454,58 @@ newtype AppT m a = AppT ( Semigroup, Monoid ) - via (Ap (AppT m) a) + via (Ap (AppT r m) a) -type AppIO = AppT IO +type AppIO r = AppT r IO -instance MonadIO m => MonadLogger (AppT m) where +instance MonadIO m => MonadLogger (AppT r m) where log l m = do g <- view applog r <- view requestId Log.log g l $ field "request" (unRequestId r) ~~ m -instance MonadIO m => MonadLogger (ExceptT err (AppT m)) where +instance MonadIO m => MonadLogger (ExceptT err (AppT r m)) where log l m = lift (LC.log l m) -instance (Monad m, MonadIO m) => MonadHttp (AppT m) where +instance (Monad m, MonadIO m) => MonadHttp (AppT r m) where handleRequestWithCont req handler = do manager <- view httpManager liftIO $ withResponse req manager handler -instance MonadIO m => MonadZAuth (AppT m) where +instance MonadIO m => MonadZAuth (AppT r m) where liftZAuth za = view zauthEnv >>= \e -> runZAuth e za -instance MonadIO m => MonadZAuth (ExceptT err (AppT m)) where +instance MonadIO m => MonadZAuth (ExceptT err (AppT r m)) where liftZAuth = lift . liftZAuth -instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT m) where +instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT r m) where liftClient m = view casClient >>= \c -> runClient c m localState f = local (over casClient f) -instance MonadIndexIO AppIO where +instance MonadIndexIO (AppIO r) where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance (MonadIndexIO (AppT m), Monad m) => MonadIndexIO (ExceptT err (AppT m)) where +instance (MonadIndexIO (AppT r m), Monad m) => MonadIndexIO (ExceptT err (AppT r m)) where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance Monad m => HasRequestId (AppT m) where +instance Monad m => HasRequestId (AppT r m) where getRequestId = view requestId -instance MonadUnliftIO m => MonadUnliftIO (AppT m) where +instance MonadUnliftIO m => MonadUnliftIO (AppT r m) where withRunInIO inner = AppT . ReaderT $ \r -> withRunInIO $ \run -> inner (run . flip runReaderT r . unAppT) -runAppT :: Env -> AppT m a -> m a +runAppT :: Env -> AppT r m a -> m a runAppT e (AppT ma) = runReaderT ma e -runAppResourceT :: ResourceT AppIO a -> AppIO a +runAppResourceT :: ResourceT (AppIO r) a -> (AppIO r) a runAppResourceT ma = do e <- ask liftIO . runResourceT $ transResourceT (runAppT e) ma -forkAppIO :: Maybe UserId -> AppIO a -> AppIO () +forkAppIO :: Maybe UserId -> (AppIO r) a -> (AppIO r) () forkAppIO u ma = do a <- ask g <- view applog diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 1f3b394214c..919f93df768 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -78,7 +78,7 @@ activateKey :: ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError AppIO (Maybe ActivationEvent) + ExceptT ActivationError (AppIO r) (Maybe ActivationEvent) activateKey k c u = verifyCode k c >>= pickUser >>= activate where pickUser (uk, u') = maybe (throwE invalidUser) (return . (uk,)) (u <|> u') @@ -129,7 +129,7 @@ newActivation :: Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> - AppIO Activation + (AppIO r) Activation newActivation uk timeout u = do (typ, key, code) <- liftIO $ @@ -148,7 +148,7 @@ newActivation uk timeout u = do <$> randIntegerZeroToNMinusOne 1000000 -- | Lookup an activation code and it's associated owner (if any) for a 'UserKey'. -lookupActivationCode :: UserKey -> AppIO (Maybe (Maybe UserId, ActivationCode)) +lookupActivationCode :: UserKey -> (AppIO r) (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity @@ -157,7 +157,7 @@ lookupActivationCode k = verifyCode :: ActivationKey -> ActivationCode -> - ExceptT ActivationError AppIO (UserKey, Maybe UserId) + ExceptT ActivationError (AppIO r) (UserKey, Maybe UserId) verifyCode key code = do s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of @@ -185,7 +185,7 @@ mkActivationKey k = do let bs = digestBS d' (T.encodeUtf8 $ keyText k) return . ActivationKey $ Ascii.encodeBase64Url bs -deleteActivationPair :: ActivationKey -> AppIO () +deleteActivationPair :: ActivationKey -> (AppIO r) () deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index b6178a0a8d5..4289470dd0d 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -94,7 +94,7 @@ addClient :: Int -> Maybe Location -> Maybe (Imports.Set ClientCapability) -> - ExceptT ClientDataError AppIO (Client, [Client], Word) + ExceptT ClientDataError (AppIO r) (Client, [Client], Word) addClient u newId c maxPermClients loc cps = do clients <- lookupClients u let typed = filter ((== newClientType c) . clientType) clients @@ -120,7 +120,7 @@ addClient u newId c maxPermClients loc cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: ExceptT ClientDataError AppIO Client + insert :: ExceptT ClientDataError (AppIO r) Client insert = do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) @@ -184,7 +184,7 @@ lookupPrekeyIds u c = hasClient :: MonadClient m => UserId -> ClientId -> m Bool hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) -rmClient :: UserId -> ClientId -> AppIO () +rmClient :: UserId -> ClientId -> (AppIO r) () rmClient u c = do retry x5 $ write removeClient (params LocalQuorum (u, c)) retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) @@ -212,7 +212,7 @@ updatePrekeys u c pks = do Success n -> return (CryptoBox.prekeyId n == keyId (prekeyId a)) _ -> return False -claimPrekey :: UserId -> ClientId -> AppIO (Maybe ClientPrekey) +claimPrekey :: UserId -> ClientId -> (AppIO r) (Maybe ClientPrekey) claimPrekey u c = view randomPrekeyLocalLock >>= \case -- Use random prekey selection strategy @@ -225,7 +225,7 @@ claimPrekey u c = prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) removeAndReturnPreKey prekey where - removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> AppIO (Maybe ClientPrekey) + removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> (AppIO r) (Maybe ClientPrekey) removeAndReturnPreKey (Just (i, k)) = do if i /= lastPrekeyId then retry x1 $ write removePrekey (params LocalQuorum (u, c, i)) @@ -237,7 +237,7 @@ claimPrekey u c = return $ Just (ClientPrekey c (Prekey i k)) removeAndReturnPreKey Nothing = return Nothing - pickRandomPrekey :: [(PrekeyId, Text)] -> AppIO (Maybe (PrekeyId, Text)) + pickRandomPrekey :: [(PrekeyId, Text)] -> (AppIO r) (Maybe (PrekeyId, Text)) pickRandomPrekey [] = return Nothing -- unless we only have one key left pickRandomPrekey [pk] = return $ Just pk @@ -330,13 +330,13 @@ ddbKey u c = AWS.attributeValue & AWS.avS ?~ UUID.toText (toUUID u) <> "." <> cl key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue key u c = HashMap.singleton ddbClient (ddbKey u c) -deleteOptLock :: UserId -> ClientId -> AppIO () +deleteOptLock :: UserId -> ClientId -> (AppIO r) () deleteOptLock u c = do t <- view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) void $ exec e (AWS.deleteItem t & AWS.diKey .~ (key u c)) -withOptLock :: UserId -> ClientId -> AppIO a -> AppIO a +withOptLock :: UserId -> ClientId -> (AppIO r) a -> (AppIO r) a withOptLock u c ma = go (10 :: Int) where go !n = do @@ -372,17 +372,17 @@ withOptLock u c ma = go (10 :: Int) key u c toAttributeValue :: Word32 -> AWS.AttributeValue toAttributeValue w = AWS.attributeValue & AWS.avN ?~ AWS.toText (fromIntegral w :: Int) - reportAttemptFailure :: AppIO () + reportAttemptFailure :: (AppIO r) () reportAttemptFailure = Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_grab_attempt_failed") =<< view metrics - reportFailureAndLogError :: AppIO () + reportFailureAndLogError :: (AppIO r) () reportFailureAndLogError = do Log.err $ Log.field "user" (toByteString' u) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics - execDyn :: (AWS.AWSRequest r) => (AWS.Rs r -> Maybe a) -> (Text -> r) -> AppIO (Maybe a) + execDyn :: (AWS.AWSRequest r) => (AWS.Rs r -> Maybe a) -> (Text -> r) -> (AppIO r) (Maybe a) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) @@ -406,6 +406,6 @@ withOptLock u c ma = go (10 :: Int) return Nothing handleErr _ = return Nothing -withLocalLock :: MVar () -> AppIO a -> AppIO a +withLocalLock :: MVar () -> (AppIO r) a -> (AppIO r) a withLocalLock l ma = do (takeMVar l *> ma) `finally` putMVar l () diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 949a458f57e..fe43894b4f4 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -73,7 +73,7 @@ insertConnection :: Qualified UserId -> RelationWithHistory -> Qualified ConvId -> - AppIO UserConnection + (AppIO r) UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -92,7 +92,7 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do ucConvId = Just qcnv } -updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection +updateConnection :: UserConnection -> RelationWithHistory -> (AppIO r) UserConnection updateConnection c status = do self <- qualifyLocal (ucFrom c) now <- updateConnectionStatus self (ucTo c) status @@ -102,7 +102,7 @@ updateConnection c status = do ucLastUpdate = now } -updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis +updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> (AppIO r) UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -115,7 +115,7 @@ updateConnectionStatus self target status = do pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) +lookupConnection :: Local UserId -> Qualified UserId -> (AppIO r) (Maybe UserConnection) lookupConnection self target = runMaybeT $ do let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- @@ -143,7 +143,7 @@ lookupRelationWithHistory :: Local UserId -> -- | User 'B' Qualified UserId -> - AppIO (Maybe RelationWithHistory) + (AppIO r) (Maybe RelationWithHistory) lookupRelationWithHistory self target = do let local (tUnqualified -> ltarget) = query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) @@ -151,14 +151,14 @@ lookupRelationWithHistory self target = do query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) -lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation +lookupRelation :: Local UserId -> Qualified UserId -> (AppIO r) Relation lookupRelation self target = lookupRelationWithHistory self target <&> \case Nothing -> Cancelled Just relh -> (relationDropHistory relh) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) +lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) (ResultPage UserConnection) lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> @@ -196,48 +196,48 @@ lookupRemoteConnectionsPage self pagingState size = (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] +lookupConnectionStatus :: [UserId] -> [UserId] -> (AppIO r) [ConnectionStatus] lookupConnectionStatus from to = map toConnectionStatus <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus' :: [UserId] -> AppIO [ConnectionStatus] +lookupConnectionStatus' :: [UserId] -> (AppIO r) [ConnectionStatus] lookupConnectionStatus' from = map toConnectionStatus <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) -lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] +lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> (AppIO r) [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) -lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] +lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> (AppIO r) [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) -lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] +lookupAllStatuses :: Local [UserId] -> (AppIO r) [ConnectionStatusV2] lookupAllStatuses lfroms = do let froms = tUnqualified lfroms concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms where - lookupAndCombine :: UserId -> AppIO [ConnectionStatusV2] + lookupAndCombine :: UserId -> (AppIO r) [ConnectionStatusV2] lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u - lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupLocalStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupLocalStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) - lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupRemoteStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupRemoteStatuses from = map (\(d, u, r) -> toConnectionStatusV2 from d u r) <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) @@ -248,20 +248,20 @@ lookupRemoteConnectedUsersC u maxResults = .| C.map (map (uncurry toRemoteUnsafe)) -- | See 'lookupContactListWithRelation'. -lookupContactList :: UserId -> AppIO [UserId] +lookupContactList :: UserId -> (AppIO r) [UserId] lookupContactList u = fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) -- | For a given user 'A', lookup the list of users that form his contact list, -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). -lookupContactListWithRelation :: UserId -> AppIO [(UserId, RelationWithHistory)] +lookupContactListWithRelation :: UserId -> (AppIO r) [(UserId, RelationWithHistory)] lookupContactListWithRelation 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.) -- Note: The count is eventually consistent. -countConnections :: Local UserId -> [Relation] -> AppIO Int64 +countConnections :: Local UserId -> [Relation] -> (AppIO r) Int64 countConnections u r = do rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) @@ -277,7 +277,7 @@ countConnections u r = do count n (Identity s) | (relationDropHistory s) `elem` r = n + 1 count n _ = n -deleteConnections :: UserId -> AppIO () +deleteConnections :: UserId -> (AppIO r) () deleteConnections u = do runConduit $ paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 @@ -287,7 +287,7 @@ deleteConnections u = do where delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) -deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () +deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> (AppIO r) () deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = pooledForConcurrentlyN_ 16 locals $ \u -> write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index c4665d92324..d5627e7e81b 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 600 -createLoginCode :: UserId -> AppIO PendingLoginCode +createLoginCode :: UserId -> (AppIO r) PendingLoginCode createLoginCode u = do now <- liftIO =<< view currentTime code <- liftIO genCode @@ -57,7 +57,7 @@ createLoginCode u = do where genCode = LoginCode . T.pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -verifyLoginCode :: UserId -> LoginCode -> AppIO Bool +verifyLoginCode :: UserId -> LoginCode -> (AppIO r) Bool verifyLoginCode u c = do code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime @@ -67,7 +67,7 @@ verifyLoginCode u c = do Just (_, _, _) -> deleteLoginCode u >> return False Nothing -> return False -lookupLoginCode :: UserId -> AppIO (Maybe PendingLoginCode) +lookupLoginCode :: UserId -> (AppIO r) (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) @@ -77,10 +77,10 @@ lookupLoginCode u = do pending c now t = PendingLoginCode c (timeout now t) timeout now t = Timeout (t `diffUTCTime` now) -deleteLoginCode :: UserId -> AppIO () +deleteLoginCode :: UserId -> (AppIO r) () deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) -insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> AppIO () +insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> (AppIO r) () 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 98295204b17..942d14f4065 100644 --- a/services/brig/src/Brig/Data/PasswordReset.hs +++ b/services/brig/src/Brig/Data/PasswordReset.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 3600 -- 60 minutes -createPasswordResetCode :: UserId -> Either Email Phone -> AppIO PasswordResetPair +createPasswordResetCode :: UserId -> Either Email Phone -> (AppIO r) PasswordResetPair createPasswordResetCode u target = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -61,7 +61,7 @@ createPasswordResetCode u target = do PasswordResetCode . Ascii.unsafeFromText . pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -lookupPasswordResetCode :: UserId -> AppIO (Maybe PasswordResetCode) +lookupPasswordResetCode :: UserId -> (AppIO r) (Maybe PasswordResetCode) lookupPasswordResetCode u = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -70,7 +70,7 @@ lookupPasswordResetCode u = do validate now (Just (c, _, _, Just t)) | t > now = return $ Just c validate _ _ = return Nothing -verifyPasswordResetCode :: PasswordResetPair -> AppIO (Maybe UserId) +verifyPasswordResetCode :: PasswordResetPair -> (AppIO r) (Maybe UserId) verifyPasswordResetCode (k, c) = do now <- liftIO =<< view currentTime code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity k))) @@ -84,7 +84,7 @@ verifyPasswordResetCode (k, c) = do where countdown = retry x5 . write codeInsert . params LocalQuorum -deletePasswordResetCode :: PasswordResetKey -> AppIO () +deletePasswordResetCode :: PasswordResetKey -> (AppIO r) () deletePasswordResetCode k = retry x5 . write codeDelete $ params LocalQuorum (Identity k) mkPasswordResetKey :: (MonadIO m) => UserId -> m PasswordResetKey diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index 822df183aa2..5ec00292621 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -40,30 +40,30 @@ maxProperties = 16 data PropertiesDataError = TooManyProperties -insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () +insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () insertProperty u k v = do 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 LocalQuorum (u, k, v)) -deleteProperty :: UserId -> PropertyKey -> AppIO () +deleteProperty :: UserId -> PropertyKey -> (AppIO r) () deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) -clearProperties :: UserId -> AppIO () +clearProperties :: UserId -> (AppIO r) () clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) -lookupProperty :: UserId -> PropertyKey -> AppIO (Maybe PropertyValue) +lookupProperty :: UserId -> PropertyKey -> (AppIO r) (Maybe PropertyValue) lookupProperty u k = fmap runIdentity <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) -lookupPropertyKeys :: UserId -> AppIO [PropertyKey] +lookupPropertyKeys :: UserId -> (AppIO r) [PropertyKey] lookupPropertyKeys u = map runIdentity <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) -lookupPropertyKeysAndValues :: UserId -> AppIO PropertyKeysAndValues +lookupPropertyKeysAndValues :: UserId -> (AppIO r) PropertyKeysAndValues lookupPropertyKeysAndValues u = PropertyKeysAndValues <$> retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 55e4c7fd00e..3959dfc3fb0 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -116,7 +116,7 @@ data ReAuthError -- Condition (2.) is essential for maintaining handle uniqueness. It is guaranteed by the -- fact that we're setting getting @mbHandle@ from table @"user"@, and when/if it was added -- there, it was claimed properly. -newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> AppIO (UserAccount, Maybe Password) +newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> (AppIO r) (UserAccount, Maybe Password) newAccount u inv tid mbHandle = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -152,7 +152,7 @@ newAccount u inv tid mbHandle = do managedBy = fromMaybe defaultManagedBy (newUserManagedBy u) user uid domain l e = User uid (Qualified uid domain) ident name pict assets colour False l Nothing mbHandle e tid managedBy -newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> AppIO UserAccount +newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> (AppIO r) UserAccount newAccountInviteViaScim uid tid locale name email = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -176,7 +176,7 @@ newAccountInviteViaScim uid tid locale name email = do ManagedByScim -- | Mandatory password authentication. -authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError AppIO () +authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError (AppIO r) () authenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE AuthInvalidUser @@ -217,7 +217,7 @@ insertAccount :: Maybe Password -> -- | Whether the user is activated Bool -> - AppIO () + (AppIO r) () insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -260,10 +260,10 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc "INSERT INTO service_team (provider, service, user, conv, team) \ \VALUES (?, ?, ?, ?, ?)" -updateLocale :: UserId -> Locale -> AppIO () +updateLocale :: UserId -> Locale -> (AppIO r) () updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) -updateUser :: UserId -> UserUpdate -> AppIO () +updateUser :: UserId -> UserUpdate -> (AppIO r) () updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -272,13 +272,13 @@ updateUser u UserUpdate {..} = retry x5 . batch $ do for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) -updateEmail :: UserId -> Email -> AppIO () +updateEmail :: UserId -> Email -> (AppIO r) () updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) -updatePhone :: UserId -> Phone -> AppIO () +updatePhone :: UserId -> Phone -> (AppIO r) () updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) -updateSSOId :: UserId -> Maybe UserSSOId -> AppIO Bool +updateSSOId :: UserId -> Maybe UserSSOId -> (AppIO r) Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of @@ -287,21 +287,21 @@ updateSSOId u ssoid = do pure True Nothing -> pure False -updateManagedBy :: UserId -> ManagedBy -> AppIO () +updateManagedBy :: UserId -> ManagedBy -> (AppIO r) () updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) -updateHandle :: UserId -> Handle -> AppIO () +updateHandle :: UserId -> Handle -> (AppIO r) () updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) -updatePassword :: UserId -> PlainTextPassword -> AppIO () +updatePassword :: UserId -> PlainTextPassword -> (AppIO r) () updatePassword u t = do p <- liftIO $ mkSafePassword t retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) -updateRichInfo :: UserId -> RichInfoAssocList -> AppIO () +updateRichInfo :: UserId -> RichInfoAssocList -> (AppIO r) () updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) -updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> AppIO (Maybe ApiFt.TeamFeatureStatusNoConfig) +updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> (AppIO r) (Maybe ApiFt.TeamFeatureStatusNoConfig) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.tfwoStatus <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) @@ -310,13 +310,13 @@ updateFeatureConferenceCalling uid mbStatus = do update :: PrepQuery W (Maybe ApiFt.TeamFeatureStatusValue, UserId) () update = fromString $ "update user set feature_conference_calling = ? where id = ?" -deleteEmail :: UserId -> AppIO () +deleteEmail :: UserId -> (AppIO r) () deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) -deletePhone :: UserId -> AppIO () +deletePhone :: UserId -> (AppIO r) () deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) -deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () +deleteServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) () deleteServiceUser pid sid bid = do lookupServiceUser pid sid bid >>= \case Nothing -> pure () @@ -336,17 +336,17 @@ deleteServiceUser pid sid bid = do "DELETE FROM service_team \ \WHERE provider = ? AND service = ? AND team = ? AND user = ?" -updateStatus :: UserId -> AccountStatus -> AppIO () +updateStatus :: UserId -> AccountStatus -> (AppIO r) () 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 :: UserId -> (AppIO r) Bool isActivated u = (== Just (Identity True)) <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) -filterActive :: [UserId] -> AppIO [UserId] +filterActive :: [UserId] -> (AppIO r) [UserId] filterActive us = map (view _1) . filter isActiveUser <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) @@ -355,46 +355,46 @@ filterActive us = isActiveUser (_, True, Just Active) = True isActiveUser _ = False -lookupUser :: HavePendingInvitations -> UserId -> AppIO (Maybe User) +lookupUser :: HavePendingInvitations -> UserId -> (AppIO r) (Maybe User) lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] -activateUser :: UserId -> UserIdentity -> AppIO () +activateUser :: UserId -> UserIdentity -> (AppIO r) () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) -deactivateUser :: UserId -> AppIO () +deactivateUser :: UserId -> (AppIO r) () deactivateUser u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) -lookupLocale :: UserId -> AppIO (Maybe Locale) +lookupLocale :: UserId -> (AppIO r) (Maybe Locale) lookupLocale u = do defLoc <- setDefaultUserLocale <$> view settings fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) -lookupName :: UserId -> AppIO (Maybe Name) +lookupName :: UserId -> (AppIO r) (Maybe Name) lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) -lookupPassword :: UserId -> AppIO (Maybe Password) +lookupPassword :: UserId -> (AppIO r) (Maybe Password) lookupPassword u = join . fmap runIdentity <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) -lookupStatus :: UserId -> AppIO (Maybe AccountStatus) +lookupStatus :: UserId -> (AppIO r) (Maybe AccountStatus) lookupStatus u = join . fmap runIdentity <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) -lookupRichInfo :: UserId -> AppIO (Maybe RichInfoAssocList) +lookupRichInfo :: UserId -> (AppIO r) (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users -lookupRichInfoMultiUsers :: [UserId] -> AppIO [(UserId, RichInfo)] +lookupRichInfoMultiUsers :: [UserId] -> (AppIO r) [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) @@ -402,7 +402,7 @@ lookupRichInfoMultiUsers users = do -- | 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* -- successful login. -lookupUserTeam :: UserId -> AppIO (Maybe TeamId) +lookupUserTeam :: UserId -> (AppIO r) (Maybe TeamId) lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) @@ -415,22 +415,22 @@ lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Ident -- | Return users with given IDs. -- -- Skips nonexistent users. /Does not/ skip users who have been deleted. -lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] +lookupUsers :: HavePendingInvitations -> [UserId] -> (AppIO r) [User] lookupUsers hpi usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) -lookupAccount :: UserId -> AppIO (Maybe UserAccount) +lookupAccount :: UserId -> (AppIO r) (Maybe UserAccount) lookupAccount u = listToMaybe <$> lookupAccounts [u] -lookupAccounts :: [UserId] -> AppIO [UserAccount] +lookupAccounts :: [UserId] -> (AppIO r) [UserAccount] lookupAccounts usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) -lookupServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO (Maybe (ConvId, Maybe TeamId)) +lookupServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) @@ -442,7 +442,7 @@ lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, s lookupServiceUsers :: ProviderId -> ServiceId -> - ConduitM () [(BotId, ConvId, Maybe TeamId)] AppIO () + ConduitM () [(BotId, ConvId, Maybe TeamId)] (AppIO r) () lookupServiceUsers pid sid = paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 where @@ -455,7 +455,7 @@ lookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> - ConduitM () [(BotId, ConvId)] AppIO () + ConduitM () [(BotId, ConvId)] (AppIO r) () lookupServiceUsersForTeam pid sid tid = paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index c8e08659216..f4483c09b9b 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -124,7 +124,7 @@ claimKey :: UserKey -> -- | The user claiming the key. UserId -> - AppIO Bool + (AppIO r) Bool claimKey k u = do free <- keyAvailable k (Just u) when free (insertKey u k) @@ -138,7 +138,7 @@ keyAvailable :: UserKey -> -- | The user looking to claim the key, if any. Maybe UserId -> - AppIO Bool + (AppIO r) Bool keyAvailable k u = do o <- lookupKey k case (o, u) of @@ -146,32 +146,32 @@ keyAvailable k u = do (Just x, Just y) | x == y -> return True (Just x, _) -> not <$> User.isActivated x -lookupKey :: UserKey -> AppIO (Maybe UserId) +lookupKey :: UserKey -> (AppIO r) (Maybe UserId) lookupKey k = fmap runIdentity <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) -insertKey :: UserId -> UserKey -> AppIO () +insertKey :: UserId -> UserKey -> (AppIO r) () insertKey u k = do hk <- hashKey k let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) -deleteKey :: UserKey -> AppIO () +deleteKey :: UserKey -> (AppIO r) () deleteKey k = do hk <- hashKey k retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) -hashKey :: UserKey -> AppIO UserKeyHash +hashKey :: UserKey -> (AppIO r) UserKeyHash hashKey uk = do d <- view digestSHA256 let d' = digestBS d $ T.encodeUtf8 (keyText uk) return . UserKeyHash $ MH.MultihashDigest MH.SHA256 (B.length d') d' -lookupPhoneHashes :: [ByteString] -> AppIO [(ByteString, UserId)] +lookupPhoneHashes :: [ByteString] -> (AppIO r) [(ByteString, UserId)] lookupPhoneHashes hp = mapMaybe mk <$> retry x1 (query selectHashed (params One (Identity hashed))) where diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 4a11f83c1d6..2f1222194d7 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -38,14 +38,14 @@ data UserPendingActivation = UserPendingActivation } deriving stock (Eq, Show, Ord) -usersPendingActivationAdd :: UserPendingActivation -> AppIO () +usersPendingActivationAdd :: UserPendingActivation -> (AppIO r) () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do 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 :: (AppIO r) (Page UserPendingActivation) usersPendingActivationList = do uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where @@ -53,10 +53,10 @@ usersPendingActivationList = do selectExpired = "SELECT user, expires_at FROM users_pending_activation" -usersPendingActivationRemove :: UserId -> AppIO () +usersPendingActivationRemove :: UserId -> (AppIO r) () usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] -usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () +usersPendingActivationRemoveMultiple :: [UserId] -> (AppIO r) () usersPendingActivationRemoveMultiple uids = retry x5 . write deleteExpired . params LocalQuorum $ (Identity uids) where diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index fa6253c1eb6..a411875b493 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -49,7 +49,7 @@ import Imports import Network.Mail.Mime ------------------------------------------------------------------------------- -sendMail :: Mail -> AppIO () +sendMail :: Mail -> (AppIO r) () sendMail m = view smtpEnv >>= \case Just smtp -> SMTP.sendMail smtp m diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 73cec62b241..92784ffd2f2 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -50,7 +50,7 @@ import Wire.API.User.Client (UserClientPrekeyMap) import Wire.API.User.Client.Prekey (ClientPrekey) import Wire.API.UserMap (UserMap) -type FederationAppIO = ExceptT FederationError AppIO +type FederationAppIO = ExceptT FederationError (AppIO r) getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) getUserHandleInfo (qUntagged -> Qualified handle domain) = do diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 5568bb9171a..2aa0c9cdd88 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -127,7 +127,7 @@ import qualified Wire.API.Team.Member as Member ----------------------------------------------------------------------------- -- Event Handlers -onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> AppIO () +onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () onUserEvent orig conn e = updateSearchIndex orig e *> dispatchNotifications orig conn e @@ -140,7 +140,7 @@ onConnectionEvent :: Maybe ConnId -> -- | The event. ConnectionEvent -> - AppIO () + (AppIO r) () onConnectionEvent orig conn evt = do let from = ucFrom (ucConn evt) notify @@ -156,7 +156,7 @@ onPropertyEvent :: -- | Client connection ID. ConnId -> PropertyEvent -> - AppIO () + (AppIO r) () onPropertyEvent orig conn e = notify (singleton $ PropertyEvent e) @@ -172,7 +172,7 @@ onClientEvent :: Maybe ConnId -> -- | The event. ClientEvent -> - AppIO () + (AppIO r) () onClientEvent orig conn e = do let events = singleton (ClientEvent e) let rcps = list1 orig [] @@ -181,7 +181,7 @@ onClientEvent orig conn e = do -- in the stream. push events rcps orig Push.RouteAny conn -updateSearchIndex :: UserId -> UserEvent -> AppIO () +updateSearchIndex :: UserId -> UserEvent -> (AppIO r) () updateSearchIndex orig e = case e of -- no-ops UserCreated {} -> return () @@ -206,7 +206,7 @@ updateSearchIndex orig e = case e of ] when interesting $ Search.reindex orig -journalEvent :: UserId -> UserEvent -> AppIO () +journalEvent :: UserId -> UserEvent -> (AppIO r) () journalEvent orig e = case e of UserActivated acc -> Journal.userActivate acc @@ -229,7 +229,7 @@ journalEvent orig e = case e of -- | Notify the origin user's contact list (first-level contacts), -- as well as his other clients about a change to his user account -- or profile. -dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> AppIO () +dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () dispatchNotifications orig conn e = case e of UserCreated {} -> return () UserSuspended {} -> return () @@ -252,21 +252,21 @@ dispatchNotifications orig conn e = case e of where event = singleton $ UserEvent e -notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> AppIO () +notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> (AppIO r) () notifyUserDeletionLocals deleted conn event = do recipients <- list1 deleted <$> lookupContactList deleted notify event deleted Push.RouteDirect conn (pure recipients) -notifyUserDeletionRemotes :: UserId -> AppIO () +notifyUserDeletionRemotes :: UserId -> (AppIO r) () notifyUserDeletionRemotes deleted = do runConduit $ Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) .| C.mapM_ fanoutNotifications where - fanoutNotifications :: [Remote UserId] -> AppIO () + fanoutNotifications :: [Remote UserId] -> (AppIO r) () fanoutNotifications = mapM_ notifyBackend . bucketRemote - notifyBackend :: Remote [UserId] -> AppIO () + notifyBackend :: Remote [UserId] -> (AppIO r) () notifyBackend uids = do case tUnqualified (checked <$> uids) of Nothing -> @@ -279,7 +279,7 @@ notifyUserDeletionRemotes deleted = do whenLeft eitherFErr $ logFederationError (tDomain uids) - logFederationError :: Domain -> FederationError -> AppT IO () + logFederationError :: Domain -> FederationError -> AppT r IO () logFederationError domain fErr = Log.err $ Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) @@ -299,7 +299,7 @@ push :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - AppIO () + (AppIO r) () push (toList -> events) usrs orig route conn = case mapMaybe toPushData events of [] -> pure () @@ -323,7 +323,7 @@ rawPush :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - AppIO () + (AppIO r) () -- TODO: if we decide to have service whitelist events in Brig instead of -- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. rawPush (toList -> events) usrs orig route conn = do @@ -368,7 +368,7 @@ notify :: Maybe ConnId -> -- | Users to notify. IO (List1 UserId) -> - AppIO () + (AppIO r) () notify events orig route conn recipients = forkAppIO (Just orig) $ do rs <- liftIO recipients push events rs orig route conn @@ -381,7 +381,7 @@ notifySelf :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - AppIO () + (AppIO r) () notifySelf events orig route conn = notify events orig route conn (pure (singleton orig)) @@ -393,19 +393,19 @@ notifyContacts :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - AppIO () + (AppIO r) () notifyContacts events orig route conn = do env <- ask notify events orig route conn $ runAppT env $ list1 orig <$> liftA2 (++) contacts teamContacts where - contacts :: AppIO [UserId] + contacts :: (AppIO r) [UserId] contacts = lookupContactList orig - teamContacts :: AppIO [UserId] + teamContacts :: (AppIO r) [UserId] teamContacts = screenMemberList =<< getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts - screenMemberList :: Maybe Team.TeamMemberList -> AppIO [UserId] + screenMemberList :: Maybe Team.TeamMemberList -> (AppIO r) [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = return $ fmap (view Team.userId) (mems ^. Team.teamMembers) @@ -572,7 +572,7 @@ toApsData _ = Nothing -- Conversation Management -- | Calls 'Galley.API.createSelfConversationH'. -createSelfConv :: UserId -> AppIO () +createSelfConv :: UserId -> (AppIO r) () createSelfConv u = do debug $ remote "galley" @@ -590,7 +590,7 @@ createLocalConnectConv :: Local UserId -> Maybe Text -> Maybe ConnId -> - AppIO ConvId + (AppIO r) ConvId createLocalConnectConv from to cname conn = do debug $ logConnection (tUnqualified from) (qUntagged to) @@ -613,20 +613,20 @@ createConnectConv :: Qualified UserId -> Maybe Text -> Maybe ConnId -> - AppIO (Qualified ConvId) + (AppIO r) (Qualified ConvId) createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to qUntagged . qualifyAs lfrom <$> createLocalConnectConv lfrom lto cname conn where - ensureLocal :: Qualified a -> AppIO (Local a) + ensureLocal :: Qualified a -> (AppIO r) (Local a) ensureLocal x = do loc <- qualifyLocal () foldQualified loc pure (\_ -> throwM federationNotImplemented) x -- | Calls 'Galley.API.acceptConvH'. -acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation acceptLocalConnectConv from conn cnv = do debug $ remote "galley" @@ -640,7 +640,7 @@ acceptLocalConnectConv from conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation acceptConnectConv from conn = foldQualified from @@ -648,7 +648,7 @@ acceptConnectConv from conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. -blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO () +blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) () blockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -662,7 +662,7 @@ blockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () +blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) () blockConv lusr conn = foldQualified lusr @@ -670,7 +670,7 @@ blockConv lusr conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. -unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation unblockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -684,7 +684,7 @@ unblockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation unblockConv luid conn = foldQualified luid @@ -692,7 +692,7 @@ unblockConv luid conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.getConversationH'. -getConv :: UserId -> ConvId -> AppIO (Maybe Conversation) +getConv :: UserId -> ConvId -> (AppIO r) (Maybe Conversation) getConv usr cnv = do debug $ remote "galley" @@ -708,7 +708,7 @@ getConv usr cnv = do . zUser usr . expect [status200, status404] -upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> AppIO UpsertOne2OneConversationResponse +upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> (AppIO r) UpsertOne2OneConversationResponse upsertOne2OneConversation urequest = do response <- galleyRequest POST req case Bilge.statusCode response of @@ -721,7 +721,7 @@ upsertOne2OneConversation urequest = do . lbytes (encode urequest) -- | Calls 'Galley.API.getTeamConversationH'. -getTeamConv :: UserId -> TeamId -> ConvId -> AppIO (Maybe Team.TeamConversation) +getTeamConv :: UserId -> TeamId -> ConvId -> (AppIO r) (Maybe Team.TeamConversation) getTeamConv usr tid cnv = do debug $ remote "galley" @@ -741,7 +741,7 @@ getTeamConv usr tid cnv = do -- User management -- | Calls 'Galley.API.rmUserH', as well as gundeck and cargohold. -rmUser :: UserId -> [Asset] -> AppIO () +rmUser :: UserId -> [Asset] -> (AppIO r) () rmUser usr asts = do debug $ remote "gundeck" @@ -767,7 +767,7 @@ rmUser usr asts = do -- Client management -- | Calls 'Galley.API.addClientH'. -newClient :: UserId -> ClientId -> AppIO () +newClient :: UserId -> ClientId -> (AppIO r) () newClient u c = do debug $ remote "galley" @@ -778,7 +778,7 @@ newClient u c = do void $ galleyRequest POST (p . zUser u . expect2xx) -- | Calls 'Galley.API.rmClientH', as well as gundeck. -rmClient :: UserId -> ClientId -> AppIO () +rmClient :: UserId -> ClientId -> (AppIO r) () rmClient u c = do let cid = toByteString' c debug $ @@ -808,7 +808,7 @@ rmClient u c = do where expected = [status200, status204, status404] -lookupPushToken :: UserId -> AppIO [Push.PushToken] +lookupPushToken :: UserId -> (AppIO r) [Push.PushToken] lookupPushToken uid = do g <- view gundeck rsp <- @@ -826,7 +826,7 @@ lookupPushToken uid = do -- Team Management -- | Calls 'Galley.API.canUserJoinTeamH'. -checkUserCanJoinTeam :: TeamId -> AppIO (Maybe Wai.Error) +checkUserCanJoinTeam :: TeamId -> (AppIO r) (Maybe Wai.Error) checkUserCanJoinTeam tid = do debug $ remote "galley" @@ -843,7 +843,7 @@ checkUserCanJoinTeam tid = do . header "Content-Type" "application/json" -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. -addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> AppIO Bool +addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> (AppIO r) Bool addTeamMember u tid (minvmeta, role) = do debug $ remote "galley" @@ -863,7 +863,7 @@ addTeamMember u tid (minvmeta, role) = do . lbytes (encode bdy) -- | Calls 'Galley.API.createBindingTeamH'. -createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> AppIO CreateUserTeam +createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> (AppIO r) CreateUserTeam createTeam u t@(Team.BindingNewTeam bt) teamid = do debug $ remote "galley" @@ -883,7 +883,7 @@ createTeam u t@(Team.BindingNewTeam bt) teamid = do . lbytes (encode t) -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. -getTeamMember :: UserId -> TeamId -> AppIO (Maybe Team.TeamMember) +getTeamMember :: UserId -> TeamId -> (AppIO r) (Maybe Team.TeamMember) getTeamMember u tid = do debug $ remote "galley" @@ -903,7 +903,7 @@ getTeamMember u tid = do -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will -- be suspended, and the rest will remain active. -getTeamMembers :: TeamId -> AppIO Team.TeamMemberList +getTeamMembers :: TeamId -> (AppIO r) Team.TeamMemberList getTeamMembers tid = do debug $ remote "galley" . msg (val "Get team members") galleyRequest GET req >>= decodeBody "galley" @@ -912,7 +912,7 @@ getTeamMembers tid = do paths ["i", "teams", toByteString' tid, "members"] . expect2xx -memberIsTeamOwner :: TeamId -> UserId -> AppIO Bool +memberIsTeamOwner :: TeamId -> UserId -> (AppIO r) Bool memberIsTeamOwner tid uid = do r <- galleyRequest GET $ @@ -922,7 +922,7 @@ memberIsTeamOwner tid uid = do -- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. -- -- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: UserId -> AppIO (Maybe Team.TeamMemberList) +getTeamContacts :: UserId -> (AppIO r) (Maybe Team.TeamMemberList) getTeamContacts u = do debug $ remote "galley" . msg (val "Get team contacts") rs <- galleyRequest GET req @@ -935,7 +935,7 @@ getTeamContacts u = do . expect [status200, status404] -- | Calls 'Galley.API.getBindingTeamIdH'. -getTeamId :: UserId -> AppIO (Maybe TeamId) +getTeamId :: UserId -> (AppIO r) (Maybe TeamId) getTeamId u = do debug $ remote "galley" . msg (val "Get team from user") rs <- galleyRequest GET req @@ -948,7 +948,7 @@ getTeamId u = do . expect [status200, status404] -- | Calls 'Galley.API.getTeamInternalH'. -getTeam :: TeamId -> AppIO Team.TeamData +getTeam :: TeamId -> (AppIO r) Team.TeamData getTeam tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -958,7 +958,7 @@ getTeam tid = do . expect2xx -- | Calls 'Galley.API.getTeamInternalH'. -getTeamName :: TeamId -> AppIO Team.TeamName +getTeamName :: TeamId -> (AppIO r) Team.TeamName getTeamName tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -968,7 +968,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> (AppIO r) (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" @@ -978,7 +978,7 @@ getTeamLegalHoldStatus tid = do . expect2xx -- | Calls 'Galley.API.getSearchVisibilityInternalH'. -getTeamSearchVisibility :: TeamId -> AppIO Team.TeamSearchVisibility +getTeamSearchVisibility :: TeamId -> (AppIO r) Team.TeamSearchVisibility getTeamSearchVisibility tid = coerce @Team.TeamSearchVisibilityView @Team.TeamSearchVisibility <$> do debug $ remote "galley" . msg (val "Get search visibility settings") @@ -989,7 +989,7 @@ getTeamSearchVisibility tid = . expect2xx -- | Calls 'Galley.API.updateTeamStatusH'. -changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> AppIO () +changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> (AppIO r) () changeTeamStatus tid s cur = do debug $ remote "galley" . msg (val "Change Team status") void $ galleyRequest PUT req @@ -1000,7 +1000,7 @@ changeTeamStatus tid s cur = do . expect2xx . lbytes (encode $ Team.TeamStatusUpdate s cur) -guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO () +guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) () guardLegalhold protectee userClients = do res <- lift $ galleyRequest PUT req case Bilge.statusCode res of diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index 3a2aaf1d37b..7703eb03e36 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -47,19 +47,19 @@ import qualified Proto.UserEvents_Fields as U -- User journal operations to SQS are a no-op when the service is started -- without journaling arguments for user updates -userActivate :: User -> AppIO () +userActivate :: User -> (AppIO r) () userActivate u@User {..} = journalEvent UserEvent'USER_ACTIVATE userId (userEmail u) (Just userLocale) userTeam (Just userDisplayName) -userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> AppIO () +userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> (AppIO r) () userUpdate uid em loc nm = journalEvent UserEvent'USER_UPDATE uid em loc Nothing nm -userEmailRemove :: UserId -> Email -> AppIO () +userEmailRemove :: UserId -> Email -> (AppIO r) () userEmailRemove uid em = journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing -userDelete :: UserId -> AppIO () +userDelete :: UserId -> (AppIO r) () userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing -journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> AppIO () +journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> (AppIO r) () journalEvent typ uid em loc tid nm = view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do ts <- now diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index c2b3b8109e6..60b3b8d92f1 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -36,7 +36,7 @@ import UnliftIO (timeout) -- | Handle an internal event. -- -- Has a one-minute timeout that should be enough for anything that it does. -onEvent :: InternalNotification -> AppIO () +onEvent :: InternalNotification -> (AppIO r) () onEvent n = handleTimeout $ case n of DeleteUser uid -> do Log.info $ diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index c3de7fe9508..cacf9321044 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -73,7 +73,7 @@ data PhoneException instance Exception PhoneException -sendCall :: Nexmo.Call -> AppIO () +sendCall :: Nexmo.Call -> (AppIO r) () sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do m <- view httpManager cred <- view nexmoCreds @@ -99,9 +99,9 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do Nexmo.CallInternal -> True _ -> False ] - unreachable :: Nexmo.CallErrorResponse -> AppT IO () + unreachable :: Nexmo.CallErrorResponse -> AppT r IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Nexmo.CallErrorResponse -> AppT IO () + barred :: Nexmo.CallErrorResponse -> AppT r IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -109,7 +109,7 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do ~~ field "error" (show ex) ~~ field "phone" (Nexmo.callTo call) -sendSms :: Locale -> SMSMessage -> AppIO () +sendSms :: Locale -> SMSMessage -> (AppIO r) () sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do m <- view httpManager withSmsBudget smsTo $ do @@ -132,7 +132,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do _ -> throwM ex' Right () -> return () where - sendNexmoSms :: Manager -> AppIO () + sendNexmoSms :: Manager -> (AppIO r) () sendNexmoSms mgr = do crd <- view nexmoCreds void . liftIO . recovering x3 nexmoHandlers $ @@ -149,7 +149,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do ES -> Nexmo.UCS2 ZH -> Nexmo.UCS2 _ -> Nexmo.GSM7 - sendTwilioSms :: Manager -> AppIO () + sendTwilioSms :: Manager -> (AppIO r) () sendTwilioSms mgr = do crd <- view twilioCreds void . liftIO . recovering x3 twilioHandlers $ @@ -179,9 +179,9 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do 20503 -> True -- Temporarily Unavailable _ -> False ] - unreachable :: Twilio.ErrorResponse -> AppT IO () + unreachable :: Twilio.ErrorResponse -> AppT r IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Twilio.ErrorResponse -> AppT IO () + barred :: Twilio.ErrorResponse -> AppT r IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -194,7 +194,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do -- | Validate a phone number. Returns the canonical -- E.164 format of the given phone number on success. -validatePhone :: Phone -> AppIO (Maybe Phone) +validatePhone :: Phone -> (AppIO r) (Maybe Phone) validatePhone (Phone p) | isTestPhone p = return (Just (Phone p)) | otherwise = do @@ -223,7 +223,7 @@ smsBudget = budgetValue = 5 -- # of SMS within timeout } -withSmsBudget :: Text -> AppIO a -> AppIO a +withSmsBudget :: Text -> (AppIO r) a -> (AppIO r) a withSmsBudget phone go = do let k = BudgetKey ("sms#" <> phone) r <- withBudget k smsBudget go @@ -251,7 +251,7 @@ callBudget = budgetValue = 2 -- # of voice calls within timeout } -withCallBudget :: Text -> AppIO a -> AppIO a +withCallBudget :: Text -> (AppIO r) a -> (AppIO r) a withCallBudget phone go = do let k = BudgetKey ("call#" <> phone) r <- withBudget k callBudget go diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 774532db7f7..717b53c98ac 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -643,7 +643,7 @@ deleteService pid sid del = do queue <- view internalEvents lift $ Queue.enqueue queue (Internal.DeleteService pid sid) -finishDeleteService :: ProviderId -> ServiceId -> AppIO () +finishDeleteService :: ProviderId -> ServiceId -> (AppIO r) () finishDeleteService pid sid = do mbSvc <- DB.lookupService pid sid for_ mbSvc $ \svc -> do @@ -909,7 +909,7 @@ botGetClientH :: BotId -> Handler Response botGetClientH bot = do maybe (throwErrorDescriptionType @ClientNotFound) (pure . json) =<< lift (botGetClient bot) -botGetClient :: BotId -> AppIO (Maybe Public.Client) +botGetClient :: BotId -> (AppIO r) (Maybe Public.Client) botGetClient bot = do listToMaybe <$> User.lookupClients (botUserId bot) @@ -961,7 +961,7 @@ botGetUserClientsH :: UserId -> Handler Response botGetUserClientsH uid = do json <$> lift (botGetUserClients uid) -botGetUserClients :: UserId -> AppIO [Public.PubClient] +botGetUserClients :: UserId -> (AppIO r) [Public.PubClient] botGetUserClients uid = do pubClient <$$> User.lookupClients uid where @@ -992,7 +992,7 @@ activate pid old new = do throwStd emailExists DB.insertKey pid (mkEmailKey <$> old) emailKey -deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> AppIO (Maybe Public.Event) +deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> (AppIO r) (Maybe Public.Event) deleteBot zusr zcon bid cid = do -- Remove the bot from the conversation ev <- RPC.removeBotMember zusr zcon cid bid diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index f0b88831a8d..b0d5f76b44f 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -44,7 +44,7 @@ import Imports ------------------------------------------------------------------------------- -- Activation Email -sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> AppIO () +sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> (AppIO r) () sendActivationMail name email key code update = do tpl <- selectTemplate update . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -96,7 +96,7 @@ renderActivationUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Request Email -sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> AppIO () +sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppIO r) () sendApprovalRequestMail name email url descr key val = do tpl <- approvalRequestEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -147,7 +147,7 @@ renderApprovalUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Confirmation Email -sendApprovalConfirmMail :: Name -> Email -> AppIO () +sendApprovalConfirmMail :: Name -> Email -> (AppIO r) () sendApprovalConfirmMail name email = do tpl <- approvalConfirmEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -183,7 +183,7 @@ renderApprovalConfirmMail ApprovalConfirmEmail {..} ApprovalConfirmEmailTemplate -------------------------------------------------------------------------------- -- Password Reset Email -sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> AppIO () +sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> (AppIO r) () sendPasswordResetMail to key code = do tpl <- passwordResetEmail . snd <$> providerTemplates Nothing branding <- view templateBranding diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 03ce6c2f9a6..d2dca30b6c2 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -65,7 +65,7 @@ data ServiceError -- -- If the external service is unavailable, returns a specific error -- or the response body cannot be parsed, a 'ServiceError' is returned. -createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError AppIO NewBotResponse +createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppIO r) NewBotResponse createBot scon new = do let fprs = toList (sconFingerprints scon) (man, verifyFingerprints) <- view extGetManager @@ -130,7 +130,7 @@ extLogError scon e = -- Internal RPC -- | Set service connection information in galley. -setServiceConn :: ServiceConn -> AppIO () +setServiceConn :: ServiceConn -> (AppIO r) () setServiceConn scon = do Log.debug $ remote "galley" @@ -155,7 +155,7 @@ setServiceConn scon = do & set Galley.serviceEnabled (sconEnabled scon) -- | Remove service connection information from galley. -removeServiceConn :: ProviderId -> ServiceId -> AppIO () +removeServiceConn :: ProviderId -> ServiceId -> (AppIO r) () removeServiceConn pid sid = do Log.debug $ remote "galley" @@ -179,7 +179,7 @@ addBotMember :: ClientId -> ProviderId -> ServiceId -> - AppIO Event + (AppIO r) Event addBotMember zusr zcon conv bot clt pid sid = do Log.debug $ remote "galley" @@ -205,7 +205,7 @@ removeBotMember :: Maybe ConnId -> ConvId -> BotId -> - AppIO (Maybe Event) + (AppIO r) (Maybe Event) removeBotMember zusr zcon conv bot = do Log.debug $ remote "galley" diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index 9e03c45cf65..c4c811853e3 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -63,7 +63,7 @@ import System.Logger.Class as Log hiding (settings) -- | Enqueue a message. -- -- Throws an error in case of failure. -enqueue :: ToJSON a => Queue -> a -> AppIO () +enqueue :: ToJSON a => Queue -> a -> (AppIO r) () enqueue (StompQueue queue) message = view stompEnv >>= \case Just env -> Stomp.enqueue (Stomp.broker env) queue message @@ -93,7 +93,7 @@ enqueue (SqsQueue queue) message = -- -- See documentation of underlying functions (e.g. 'Stomp.listen') for -- extra details. -listen :: (Show a, FromJSON a) => Queue -> (a -> AppIO ()) -> AppIO () +listen :: (Show a, FromJSON a) => Queue -> (a -> (AppIO r) ()) -> (AppIO r) () listen (StompQueue queue) callback = view stompEnv >>= \case Just env -> Stomp.listen (Stomp.broker env) queue callback diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 645abc530ed..a9268ca9b9f 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -62,19 +62,19 @@ expect ss rq = rq {checkResponse = check} cargoholdRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) cargoholdRequest = serviceRequest "cargohold" cargohold galleyRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) galleyRequest = serviceRequest "galley" galley gundeckRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) gundeckRequest = serviceRequest "gundeck" gundeck serviceRequest :: @@ -82,7 +82,7 @@ serviceRequest :: Control.Lens.Getting Request Env Request -> StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) serviceRequest nm svc m r = do service <- view svc recovering x3 rpcHandlers $ diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index dce7a876161..a2d283a5e68 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -169,7 +169,7 @@ bodyParserErrorFormatter _ _ errMsg = Servant.errHeaders = [(HTTP.hContentType, HTTPMedia.renderHeader (Servant.contentType (Proxy @Servant.JSON)))] } -pendingActivationCleanup :: AppIO () +pendingActivationCleanup :: (AppIO r) () pendingActivationCleanup = do safeForever "pendingActivationCleanup" $ do now <- liftIO =<< view currentTime @@ -206,17 +206,17 @@ pendingActivationCleanup = do -- pause to keep worst-case noise in logs manageable threadDelay 60_000_000 - forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () + forExpirationsPaged :: ([UserPendingActivation] -> (AppIO r) ()) -> (AppIO r) () forExpirationsPaged f = do go =<< usersPendingActivationList where - go :: (Page UserPendingActivation) -> AppIO () + go :: (Page UserPendingActivation) -> (AppIO r) () go (Page hasMore result nextPage) = do f result when hasMore $ go =<< liftClient nextPage - threadDelayRandom :: AppIO () + threadDelayRandom :: (AppIO r) () threadDelayRandom = do cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings let d = realToFrac cleanupTimeout diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 6b44547527a..20189b98fab 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -42,21 +42,21 @@ import Imports ------------------------------------------------------------------------------- -- Invitation Email -sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> AppIO () +sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> (AppIO r) () sendInvitationMail to tid from code loc = do tpl <- invitationEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = InvitationEmail to tid code from Email.sendMail $ renderInvitationEmail mail tpl branding -sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () +sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () sendCreatorWelcomeMail to tid teamName loc = do tpl <- creatorWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = CreatorWelcomeEmail to tid teamName Email.sendMail $ renderCreatorWelcomeMail mail tpl branding -sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () +sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 64279ec00c5..bd530c489c4 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -27,7 +27,7 @@ import qualified Data.Set as Set import Galley.Types.Teams import Imports -ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error AppIO () +ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error (AppIO r) () ensurePermissions u t perms = do m <- lift $ Intra.getTeamMember u t unless (check m) $ @@ -40,7 +40,7 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error AppIO () +ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error (AppIO r) () ensurePermissionToAddUser u t inviteePerms = do minviter <- lift $ Intra.getTeamMember u t unless (check minviter) $ diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index e25ae0a82ae..38a068ffe05 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -308,7 +308,7 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do listCookiesH :: UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> Handler Response listCookiesH (u ::: ll ::: _) = json <$> lift (listCookies u ll) -listCookies :: UserId -> Maybe (List Public.CookieLabel) -> AppIO Public.CookieList +listCookies :: UserId -> Maybe (List Public.CookieLabel) -> (AppIO r) Public.CookieList listCookies u ll = do Public.CookieList <$> Auth.listCookies u (maybe [] fromList ll) @@ -406,7 +406,7 @@ tokenRequest = opt (userToken ||| legalHoldUserToken) .&. opt (accessToken ||| l ) Just t -> return t -tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> AppIO Response +tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> (AppIO r) Response tokenResponse (Auth.Access t Nothing) = pure $ json t tokenResponse (Auth.Access t (Just c)) = Auth.setResponseCookie c (json t) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index e11fb2cf127..739a535df60 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -78,7 +78,7 @@ data Access u = Access accessCookie :: !(Maybe (Cookie (ZAuth.Token u))) } -sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError AppIO PendingLoginCode +sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError (AppIO r) PendingLoginCode sendLoginCode phone call force = do pk <- maybe @@ -102,7 +102,7 @@ sendLoginCode phone call force = do else sendLoginSms ph (pendingLoginCode c) l return c -lookupLoginCode :: Phone -> AppIO (Maybe PendingLoginCode) +lookupLoginCode :: Phone -> (AppIO r) (Maybe PendingLoginCode) lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case Nothing -> return Nothing @@ -110,7 +110,7 @@ lookupLoginCode phone = Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") Data.lookupLoginCode u -login :: Login -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) +login :: Login -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) login (PasswordLogin li pw label _) typ = do case TeamFeatureSndFPasswordChallengeNotImplemented of -- mark this place to implement handling verification codes later @@ -135,19 +135,19 @@ login (SmsLogin phone code label) typ = do loginFailed uid newAccess @ZAuth.User @ZAuth.Access uid typ label -loginFailed :: UserId -> ExceptT LoginError AppIO () +loginFailed :: UserId -> ExceptT LoginError (AppIO r) () loginFailed uid = decrRetryLimit uid >> throwE LoginFailed -decrRetryLimit :: UserId -> ExceptT LoginError AppIO () +decrRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () decrRetryLimit = withRetryLimit (\k b -> withBudget k b $ pure ()) -checkRetryLimit :: UserId -> ExceptT LoginError AppIO () +checkRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () checkRetryLimit = withRetryLimit checkBudget withRetryLimit :: - (BudgetKey -> Budget -> ExceptT LoginError AppIO (Budgeted ())) -> + (BudgetKey -> Budget -> ExceptT LoginError (AppIO r) (Budgeted ())) -> UserId -> - ExceptT LoginError AppIO () + ExceptT LoginError (AppIO r) () withRetryLimit action uid = do mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) forM_ mLimitFailedLogins $ \opts -> do @@ -161,7 +161,7 @@ withRetryLimit action uid = do BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl BudgetedValue () _ -> pure () -logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure AppIO () +logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure (AppIO r) () logout uts at = do (u, ck) <- validateTokens uts (Just at) lift $ revokeCookies u [cookieId ck] [] @@ -170,7 +170,7 @@ renewAccess :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (Access u) + ExceptT ZAuth.Failure (AppIO r) (Access u) renewAccess uts at = do (uid, ck) <- validateTokens uts at Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.renewAccess") @@ -184,7 +184,7 @@ revokeAccess :: PlainTextPassword -> [CookieId] -> [CookieLabel] -> - ExceptT AuthError AppIO () + ExceptT AuthError (AppIO r) () revokeAccess u pw cc ll = do Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") Data.authenticate u pw @@ -193,7 +193,7 @@ revokeAccess u pw cc ll = do -------------------------------------------------------------------------------- -- Internal -catchSuspendInactiveUser :: UserId -> e -> ExceptT e AppIO () +catchSuspendInactiveUser :: UserId -> e -> ExceptT e (AppIO r) () catchSuspendInactiveUser uid errval = do mustsuspend <- lift $ mustSuspendInactiveUser uid when mustsuspend $ do @@ -204,7 +204,7 @@ catchSuspendInactiveUser uid errval = do lift $ suspendAccount (List1.singleton uid) throwE errval -newAccess :: forall u a. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError AppIO (Access u) +newAccess :: forall u a. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError (AppIO r) (Access u) newAccess uid ct cl = do catchSuspendInactiveUser uid LoginSuspended r <- lift $ newCookieLimited uid ct cl @@ -214,7 +214,7 @@ newAccess uid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing return $ Access t (Just ck) -resolveLoginId :: LoginId -> ExceptT LoginError AppIO UserId +resolveLoginId :: LoginId -> ExceptT LoginError (AppIO r) UserId resolveLoginId li = do usr <- validateLoginId li >>= lift . either lookupKey lookupHandle case usr of @@ -226,7 +226,7 @@ resolveLoginId li = do else LoginFailed Just uid -> return uid -validateLoginId :: LoginId -> ExceptT LoginError AppIO (Either UserKey Handle) +validateLoginId :: LoginId -> ExceptT LoginError (AppIO r) (Either UserKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) @@ -240,7 +240,7 @@ validateLoginId (LoginByPhone phone) = validateLoginId (LoginByHandle h) = return (Right h) -isPendingActivation :: LoginId -> AppIO Bool +isPendingActivation :: LoginId -> (AppIO r) Bool isPendingActivation ident = case ident of (LoginByHandle _) -> return False (LoginByEmail e) -> checkKey (userEmailKey e) @@ -274,13 +274,13 @@ validateTokens :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) validateTokens uts at = do tokens <- forM uts $ \ut -> lift $ runExceptT (validateToken ut at) getFirstSuccessOrFirstFail tokens where -- FUTUREWORK: There is surely a better way to do this - getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) getFirstSuccessOrFirstFail tks = case (lefts $ NE.toList $ List1.toNonEmpty tks, rights $ NE.toList $ List1.toNonEmpty tks) of (_, (suc : _)) -> return suc ((e : _), _) -> throwE e @@ -290,7 +290,7 @@ validateToken :: ZAuth.TokenPair u a => ZAuth.Token u -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) validateToken ut at = do unless (maybe True ((ZAuth.userTokenOf ut ==) . ZAuth.accessTokenOf) at) $ throwE ZAuth.Invalid @@ -303,7 +303,7 @@ validateToken ut at = do return (ZAuth.userTokenOf ut, ck) -- | Allow to login as any user without having the credentials. -ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) +ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) ssoLogin (SsoLogin uid label) typ = do Data.reauthenticate uid Nothing `catchE` \case ReAuthMissingPassword -> pure () @@ -316,7 +316,7 @@ ssoLogin (SsoLogin uid label) typ = do newAccess @ZAuth.User @ZAuth.Access uid typ label -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. -legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError AppIO (Access ZAuth.LegalHoldUser) +legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError (AppIO r) (Access ZAuth.LegalHoldUser) legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do Data.reauthenticate uid plainTextPassword !>> LegalHoldReAuthError -- legalhold login is only possible if @@ -330,7 +330,7 @@ legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid typ label !>> LegalHoldLoginError -assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError AppIO () +assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError (AppIO r) () assertLegalHoldEnabled tid = do stat <- lift $ Intra.getTeamLegalHoldStatus tid case tfwoStatus stat of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 1bb09328eaf..28023f58636 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -68,7 +68,7 @@ newCookie :: UserId -> CookieType -> Maybe CookieLabel -> - AppIO (Cookie (ZAuth.Token u)) + (AppIO r) (Cookie (ZAuth.Token u)) newCookie uid typ label = do now <- liftIO =<< view currentTime tok <- @@ -90,7 +90,7 @@ newCookie uid typ label = do -- | Renew the given cookie with a fresh token, if its age -- exceeds the configured minimum threshold. -nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Maybe (Cookie (ZAuth.Token u))) +nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) nextCookie c = do s <- view settings now <- liftIO =<< view currentTime @@ -116,7 +116,7 @@ nextCookie c = do return c' {cookieValue = t} -- | Renew the given cookie with a fresh token. -renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Cookie (ZAuth.Token u)) +renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Cookie (ZAuth.Token u)) renewCookie old = do let t = cookieValue old let uid = ZAuth.userTokenOf t @@ -134,7 +134,7 @@ renewCookie old = do -- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', -- 'newCookieLimited' if there is a chance that the user should be suspended (we don't do it -- implicitly because of cyclical dependencies). -mustSuspendInactiveUser :: UserId -> AppIO Bool +mustSuspendInactiveUser :: UserId -> (AppIO r) Bool mustSuspendInactiveUser uid = view (settings . to setSuspendInactiveUsers) >>= \case Nothing -> pure False @@ -151,7 +151,7 @@ mustSuspendInactiveUser uid = | otherwise = True pure mustSuspend -newAccessToken :: forall u a. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> AppIO AccessToken +newAccessToken :: forall u a r. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> (AppIO r) AccessToken newAccessToken c mt = do t' <- case mt of Nothing -> ZAuth.newAccessToken (cookieValue c) @@ -166,7 +166,7 @@ newAccessToken c mt = do -- | Lookup the stored cookie associated with a user token, -- if one exists. -lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> AppIO (Maybe (Cookie (ZAuth.Token u))) +lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) lookupCookie t = do let user = ZAuth.userTokenOf t let rand = ZAuth.userTokenRand t @@ -175,16 +175,16 @@ lookupCookie t = do where setToken c = c {cookieValue = t} -listCookies :: UserId -> [CookieLabel] -> AppIO [Cookie ()] +listCookies :: UserId -> [CookieLabel] -> (AppIO r) [Cookie ()] listCookies u [] = DB.listCookies u listCookies u ll = filter byLabel <$> DB.listCookies u where byLabel c = maybe False (`elem` ll) (cookieLabel c) -revokeAllCookies :: UserId -> AppIO () +revokeAllCookies :: UserId -> (AppIO r) () revokeAllCookies u = revokeCookies u [] [] -revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> AppIO () +revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> (AppIO r) () revokeCookies u [] [] = DB.deleteAllCookies u revokeCookies u ids labels = do cc <- filter matching <$> DB.listCookies u @@ -202,7 +202,7 @@ newCookieLimited :: UserId -> CookieType -> Maybe CookieLabel -> - AppIO (Either RetryAfter (Cookie (ZAuth.Token t))) + (AppIO r) (Either RetryAfter (Cookie (ZAuth.Token t))) newCookieLimited u typ label = do cs <- filter ((typ ==) . cookieType) <$> DB.listCookies u now <- liftIO =<< view currentTime @@ -246,7 +246,7 @@ setResponseCookie c r = do -------------------------------------------------------------------------------- -- Tracking -trackSuperseded :: UserId -> CookieId -> AppIO () +trackSuperseded :: UserId -> CookieId -> (AppIO r) () trackSuperseded u c = do m <- view metrics Metrics.counterIncr (Metrics.path "user.auth.cookie.superseded") m diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 1a089b56da7..a5c366d22c2 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -45,14 +45,14 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where -- find uid given handle - go1 :: Bool -> Handle -> AppIO (Maybe EJPDResponseItem) + go1 :: Bool -> Handle -> (AppIO r) (Maybe EJPDResponseItem) go1 includeContacts' handle = do mbUid <- lookupHandle handle mbUsr <- maybe (pure Nothing) (lookupUser NoPendingInvitations) mbUid maybe (pure Nothing) (fmap Just . go2 includeContacts') mbUsr -- construct response item given uid - go2 :: Bool -> User -> AppIO EJPDResponseItem + go2 :: Bool -> User -> (AppIO r) EJPDResponseItem go2 includeContacts' target = do let uid = userId target diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs index 1a58f57285e..b1c3e11c6a0 100644 --- a/services/brig/src/Brig/User/Email.hs +++ b/services/brig/src/Brig/User/Email.hs @@ -45,14 +45,14 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Lazy (toStrict) import Imports -sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> AppIO () +sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> (AppIO r) () sendVerificationMail to pair loc = do tpl <- verificationEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = VerificationEmail to pair Email.sendMail $ renderVerificationMail mail tpl branding -sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> AppIO () +sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> (AppIO r) () sendActivationMail to name pair loc ident = do tpl <- selectTemplate . snd <$> userTemplates loc branding <- view templateBranding @@ -64,26 +64,26 @@ sendActivationMail to name pair loc ident = do then activationEmail else activationEmailUpdate -sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> AppIO () +sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> (AppIO r) () sendPasswordResetMail to pair loc = do tpl <- passwordResetEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = PasswordResetEmail to pair Email.sendMail $ renderPwResetMail mail tpl branding -sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> AppIO () +sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> (AppIO r) () sendDeletionEmail name email key code locale = do tpl <- deletionEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderDeletionEmail tpl (DeletionEmail email name key code) branding -sendNewClientEmail :: Name -> Email -> Client -> Locale -> AppIO () +sendNewClientEmail :: Name -> Email -> Client -> Locale -> (AppIO r) () sendNewClientEmail name email client locale = do tpl <- newClientEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderNewClientEmail tpl (NewClientEmail locale email name client) branding -sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> AppIO () +sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> (AppIO r) () sendTeamActivationMail to name pair loc team = do tpl <- teamActivationEmail . snd <$> userTemplates loc let mail = TeamActivationEmail to name team pair diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 1f53d68492d..5616c5efb85 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -34,7 +34,7 @@ import Data.Id import Imports -- | Claim a new handle for an existing 'User'. -claimHandle :: UserId -> Maybe Handle -> Handle -> AppIO Bool +claimHandle :: UserId -> Maybe Handle -> Handle -> (AppIO r) Bool claimHandle uid oldHandle newHandle = isJust <$> do owner <- lookupHandle newHandle @@ -56,19 +56,19 @@ claimHandle uid oldHandle newHandle = return result -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: UserId -> Handle -> AppIO () +freeHandle :: UserId -> Handle -> (AppIO r) () freeHandle uid h = do 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 :: Handle -> (AppIO r) (Maybe UserId) lookupHandle = lookupHandleWithPolicy LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. -glimpseHandle :: Handle -> AppIO (Maybe UserId) +glimpseHandle :: Handle -> (AppIO r) (Maybe UserId) glimpseHandle = lookupHandleWithPolicy One {-# INLINE lookupHandleWithPolicy #-} @@ -78,7 +78,7 @@ glimpseHandle = lookupHandleWithPolicy One -- -- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' -- and only allowing it to be parsed. -lookupHandleWithPolicy :: Consistency -> Handle -> AppIO (Maybe UserId) +lookupHandleWithPolicy :: Consistency -> Handle -> (AppIO r) (Maybe UserId) lookupHandleWithPolicy policy h = do join . fmap runIdentity <$> retry x1 (query1 handleSelect (params policy (Identity h))) diff --git a/services/brig/src/Brig/User/Phone.hs b/services/brig/src/Brig/User/Phone.hs index 31ab888f2ac..a172780d083 100644 --- a/services/brig/src/Brig/User/Phone.hs +++ b/services/brig/src/Brig/User/Phone.hs @@ -52,37 +52,37 @@ import Data.Text.Lazy (toStrict) import Imports import qualified Ropes.Nexmo as Nexmo -sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> AppIO () +sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () sendActivationSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) branding -sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> AppIO () +sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> (AppIO r) () sendPasswordResetSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) branding -sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> AppIO () +sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () sendLoginSms to code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) branding -sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> AppIO () +sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> (AppIO r) () sendDeletionSms to key code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates (Just loc) sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) branding -sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> AppIO () +sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () sendActivationCall to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' branding -sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> AppIO () +sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () sendLoginCall to c loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc From 757a8fa6ef196c3e13d086b9d34634869754cda1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 16 Feb 2022 22:31:22 +0100 Subject: [PATCH 53/58] Revert "WIP: Introduce type variable r to AppT and AppIO" This reverts commit 8806ffcfec9a951390592dbec40743160682bf21. --- services/brig/src/Brig/API/Client.hs | 52 ++++---- services/brig/src/Brig/API/Connection.hs | 48 +++---- .../brig/src/Brig/API/Connection/Remote.hs | 6 +- services/brig/src/Brig/API/Connection/Util.hs | 4 +- services/brig/src/Brig/API/Handler.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 12 +- services/brig/src/Brig/API/Properties.hs | 6 +- services/brig/src/Brig/API/Public.hs | 4 +- services/brig/src/Brig/API/User.hs | 122 +++++++++--------- services/brig/src/Brig/API/Util.hs | 8 +- services/brig/src/Brig/AWS/SesNotification.hs | 12 +- services/brig/src/Brig/App.hs | 38 +++--- services/brig/src/Brig/Data/Activation.hs | 10 +- services/brig/src/Brig/Data/Client.hs | 24 ++-- services/brig/src/Brig/Data/Connection.hs | 44 +++---- services/brig/src/Brig/Data/LoginCode.hs | 10 +- services/brig/src/Brig/Data/PasswordReset.hs | 8 +- services/brig/src/Brig/Data/Properties.hs | 12 +- services/brig/src/Brig/Data/User.hs | 72 +++++------ services/brig/src/Brig/Data/UserKey.hs | 14 +- .../src/Brig/Data/UserPendingActivation.hs | 8 +- services/brig/src/Brig/Email.hs | 2 +- services/brig/src/Brig/Federation/Client.hs | 2 +- services/brig/src/Brig/IO/Intra.hs | 102 +++++++-------- services/brig/src/Brig/IO/Journal.hs | 10 +- .../brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/Phone.hs | 22 ++-- services/brig/src/Brig/Provider/API.hs | 8 +- services/brig/src/Brig/Provider/Email.hs | 8 +- services/brig/src/Brig/Provider/RPC.hs | 10 +- services/brig/src/Brig/Queue.hs | 4 +- services/brig/src/Brig/RPC.hs | 8 +- services/brig/src/Brig/Run.hs | 8 +- services/brig/src/Brig/Team/Email.hs | 6 +- services/brig/src/Brig/Team/Util.hs | 4 +- services/brig/src/Brig/User/API/Auth.hs | 4 +- services/brig/src/Brig/User/Auth.hs | 44 +++---- services/brig/src/Brig/User/Auth/Cookie.hs | 22 ++-- services/brig/src/Brig/User/EJPD.hs | 4 +- services/brig/src/Brig/User/Email.hs | 12 +- services/brig/src/Brig/User/Handle.hs | 10 +- services/brig/src/Brig/User/Phone.hs | 12 +- 42 files changed, 410 insertions(+), 410 deletions(-) diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 27324a294b9..a265fbc462e 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -84,18 +84,18 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) -lookupLocalClient :: UserId -> ClientId -> (AppIO r) (Maybe Client) +lookupLocalClient :: UserId -> ClientId -> AppIO (Maybe Client) lookupLocalClient = Data.lookupClient -lookupLocalClients :: UserId -> (AppIO r) [Client] +lookupLocalClients :: UserId -> AppIO [Client] lookupLocalClients = Data.lookupClients -lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe PubClient) +lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe PubClient) lookupPubClient qid cid = do clients <- lookupPubClients qid pure $ find ((== cid) . pubClientId) clients -lookupPubClients :: Qualified UserId -> ExceptT ClientError (AppIO r) [PubClient] +lookupPubClients :: Qualified UserId -> ExceptT ClientError AppIO [PubClient] lookupPubClients qid@(Qualified uid domain) = do getForUser <$> lookupPubClientsBulk [qid] where @@ -104,7 +104,7 @@ lookupPubClients qid@(Qualified uid domain) = do um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap) Set.toList <$> Map.lookup uid um -lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError (AppIO r) (QualifiedUserMap (Set PubClient)) +lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do loc <- qualifyLocal () let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids @@ -116,12 +116,12 @@ lookupPubClientsBulk qualifiedUids = do localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) -lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppIO r) (UserMap (Set PubClient)) +lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) lookupLocalPubClientsBulk = Data.lookupPubClientsBulk -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError (AppIO r) Client +addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError AppIO Client addClient u con ip new = do acc <- lift (Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return loc <- maybe (return Nothing) locationOf ip @@ -149,7 +149,7 @@ addClient u con ip new = do where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) -updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError (AppIO r) () +updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError AppIO () updateClient u c r = do client <- lift (Data.lookupClient u c) >>= maybe (throwE ClientNotFound) pure for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just @@ -163,7 +163,7 @@ updateClient u c r = do -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError (AppIO r) () +rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError AppIO () rmClient u con clt pw = maybe (throwE ClientNotFound) fn =<< lift (Data.lookupClient u clt) where @@ -177,14 +177,14 @@ rmClient u con clt pw = _ -> Data.reauthenticate u pw !>> ClientDataError . ClientReAuthError lift $ execDelete u (Just con) client -claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) +claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) claimPrekey protectee u d c = do isLocalDomain <- (d ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekey protectee u c else claimRemotePrekey (Qualified u d) c -claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) +claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) claimLocalPrekey protectee user client = do guardLegalhold protectee (mkUserClients [(user, [client])]) lift $ do @@ -192,27 +192,27 @@ claimLocalPrekey protectee user client = do when (isNothing prekey) (noPrekeys user client) pure prekey -claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) +claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) claimRemotePrekey quser client = fmapLT ClientFederationError $ Federation.claimPrekey quser client -claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle +claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError AppIO PrekeyBundle claimPrekeyBundle protectee domain uid = do isLocalDomain <- (domain ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekeyBundle protectee uid else claimRemotePrekeyBundle (Qualified uid domain) -claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle +claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError AppIO PrekeyBundle claimLocalPrekeyBundle protectee u = do clients <- map clientId <$> Data.lookupClients u guardLegalhold protectee (mkUserClients [(u, clients)]) PrekeyBundle u . catMaybes <$> lift (mapM (Data.claimPrekey u) clients) -claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppIO r) PrekeyBundle +claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError AppIO PrekeyBundle claimRemotePrekeyBundle quser = do Federation.claimPrekeyBundle quser !>> ClientFederationError -claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppIO r) QualifiedUserClientPrekeyMap +claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError AppIO QualifiedUserClientPrekeyMap claimMultiPrekeyBundles protectee quc = do loc <- qualifyLocal () let (locals, remotes) = @@ -232,17 +232,17 @@ claimMultiPrekeyBundles protectee quc = do where claimRemote :: Remote UserClients -> - ExceptT FederationError (AppIO r) (Qualified UserClientPrekeyMap) + ExceptT FederationError AppIO (Qualified UserClientPrekeyMap) claimRemote ruc = qUntagged . qualifyAs ruc <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) - claimLocal :: Local UserClients -> ExceptT ClientError (AppIO r) (Qualified UserClientPrekeyMap) + claimLocal :: Local UserClients -> ExceptT ClientError AppIO (Qualified UserClientPrekeyMap) claimLocal luc = qUntagged . qualifyAs luc <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) -claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) UserClientPrekeyMap +claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap claimLocalMultiPrekeyBundles protectee userClients = do guardLegalhold protectee userClients lift @@ -253,13 +253,13 @@ claimLocalMultiPrekeyBundles protectee userClients = do . Message.userClients $ userClients where - getChunk :: Map UserId (Set ClientId) -> (AppIO r) (Map UserId (Map ClientId (Maybe Prekey))) + getChunk :: Map UserId (Set ClientId) -> AppIO (Map UserId (Map ClientId (Maybe Prekey))) getChunk = runConcurrently . Map.traverseWithKey (\u -> Concurrently . getUserKeys u) - getUserKeys :: UserId -> Set ClientId -> (AppIO r) (Map ClientId (Maybe Prekey)) + getUserKeys :: UserId -> Set ClientId -> AppIO (Map ClientId (Maybe Prekey)) getUserKeys u = sequenceA . Map.fromSet (getClientKeys u) - getClientKeys :: UserId -> ClientId -> (AppIO r) (Maybe Prekey) + getClientKeys :: UserId -> ClientId -> AppIO (Maybe Prekey) getClientKeys u c = do key <- fmap prekeyData <$> Data.claimPrekey u c when (isNothing key) $ noPrekeys u c @@ -268,7 +268,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- Utilities -- | Perform an orderly deletion of an existing client. -execDelete :: UserId -> Maybe ConnId -> Client -> (AppIO r) () +execDelete :: UserId -> Maybe ConnId -> Client -> AppIO () execDelete u con c = do Intra.rmClient u (clientId c) for_ (clientCookie c) $ \l -> Auth.revokeCookies u [] [l] @@ -280,7 +280,7 @@ execDelete u con c = do -- not exist, since there must be no client without prekeys, -- thus repairing any inconsistencies related to distributed -- (and possibly duplicated) client data. -noPrekeys :: UserId -> ClientId -> (AppIO r) () +noPrekeys :: UserId -> ClientId -> AppIO () noPrekeys u c = do Log.info $ field "user" (toByteString u) @@ -301,7 +301,7 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppIO r) () +legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> AppIO () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = Intra.onUserEvent targetUser Nothing lhClientEvent where @@ -312,7 +312,7 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: UserId -> (AppIO r) () +removeLegalHoldClient :: UserId -> AppIO () removeLegalHoldClient uid = do clients <- Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index edd34648904..9495087c814 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -59,7 +59,7 @@ import Wire.API.Connection (RelationWithHistory (..)) import Wire.API.ErrorDescription import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -ensureIsActivated :: Local UserId -> MaybeT (AppIO r) () +ensureIsActivated :: Local UserId -> MaybeT AppIO () ensureIsActivated lusr = do active <- lift $ Data.isActivated (tUnqualified lusr) guard active @@ -109,7 +109,7 @@ createConnectionToLocalUser self conn target = do checkLimit self Created <$> insert Nothing Nothing where - insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError (AppIO r) UserConnection + insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection insert s2o o2s = lift $ do Log.info $ logConnection (tUnqualified self) (qUntagged target) @@ -124,7 +124,7 @@ createConnectionToLocalUser self conn target = do mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' - update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) + update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) @@ -139,7 +139,7 @@ createConnectionToLocalUser self conn target = do (_, Pending) -> resend s2o o2s (_, Cancelled) -> resend s2o o2s - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) accept s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -161,7 +161,7 @@ createConnectionToLocalUser self conn target = do lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' - resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) + resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) resend s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -171,17 +171,17 @@ createConnectionToLocalUser self conn target = do s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' - change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) + change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) change c s = Existed <$> lift (Data.updateConnection c s) -- | Throw error if one user has a LH device and the other status `no_consent` or vice versa. -- -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. -checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError (AppIO r) () +checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError AppIO () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = - -- Does not fit into 'ExceptT', so throw in '(AppIO r)'. Anyway at the time of writing + -- Does not fit into 'ExceptT', so throw in 'AppIO'. Anyway at the time of writing -- this, users are guaranteed to exist when called from 'createConnectionToLocalUser'. maybe (throwM (errorDescriptionTypeToWai @UserNotFound)) return @@ -279,7 +279,7 @@ updateConnectionToLocalUser self other newStatus conn = do in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) accept s2o o2s = do checkLimit self Log.info $ @@ -301,7 +301,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory - block :: UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) + block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) block s2o = lift $ do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -309,7 +309,7 @@ updateConnectionToLocalUser self other newStatus conn = do traverse_ (Intra.blockConv self conn) (ucConvId s2o) Just <$> Data.updateConnection s2o BlockedWithHistory - unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) + unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) unblock s2o o2s new = do -- FUTUREWORK: new is always in [Sent, Accepted]. Refactor to total function. when (new `elem` [Sent, Accepted]) $ @@ -330,7 +330,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) + cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) cancel s2o o2s = do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -342,7 +342,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled - change :: UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) + change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled lift $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) @@ -350,7 +350,7 @@ updateConnectionToLocalUser self other newStatus conn = do localConnection :: Local UserId -> Local UserId -> - ExceptT ConnectionError (AppIO r) UserConnection + ExceptT ConnectionError AppIO UserConnection localConnection la lb = do lift (Data.lookupConnection la (qUntagged lb)) >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) @@ -375,7 +375,7 @@ mkRelationWithHistory oldRel = \case updateConnectionInternal :: UpdateConnectionsInternal -> - ExceptT ConnectionError (AppIO r) () + ExceptT ConnectionError AppIO () updateConnectionInternal = \case BlockForMissingLHConsent uid others -> do self <- qualifyLocal uid @@ -391,7 +391,7 @@ updateConnectionInternal = \case other where -- inspired by @block@ in 'updateConnection'. - blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError (AppIO r) () + blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () blockForMissingLegalholdConsent self others = do for_ others $ \(qualifyAs self -> other) -> do Log.info $ @@ -407,7 +407,7 @@ updateConnectionInternal = \case let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing Intra.onConnectionEvent (tUnqualified self) Nothing ev - removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppIO r) () + removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () removeLHBlocksInvolving self = iterateConnections self (toRange (Proxy @500)) $ \conns -> do for_ conns $ \s2o -> @@ -422,10 +422,10 @@ updateConnectionInternal = \case unblockDirected s2o o2s unblockDirected o2s s2o where - iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError (AppIO r) ()) -> ExceptT ConnectionError (AppIO r) () + iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () iterateConnections user pageSize handleConns = go Nothing where - go :: Maybe UserId -> ExceptT ConnectionError (AppT r IO) () + go :: Maybe UserId -> ExceptT ConnectionError (AppT IO) () go mbStart = do page <- lift $ Data.lookupLocalConnections user mbStart pageSize handleConns (resultList page) @@ -436,7 +436,7 @@ updateConnectionInternal = \case else pure () [] -> pure () - unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) () + unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO () unblockDirected uconn uconnRev = do lfrom <- qualifyLocal (ucFrom uconnRev) void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing @@ -451,7 +451,7 @@ updateConnectionInternal = \case } lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent - relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError (AppIO r) RelationWithHistory + relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory relationWithHistory self target = lift (Data.lookupRelationWithHistory self target) >>= tryJust (NotConnected (tUnqualified self) target) @@ -473,18 +473,18 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory -createLocalConnectionUnchecked :: Local UserId -> Local UserId -> (AppIO r) () +createLocalConnectionUnchecked :: Local UserId -> Local UserId -> AppIO () createLocalConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv void $ Data.insertConnection other (qUntagged self) AcceptedWithHistory qcnv -createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> (AppIO r) () +createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> AppIO () createRemoteConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv -lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) UserConnectionList +lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList lookupConnections from start size = do lusr <- qualifyLocal from rs <- Data.lookupLocalConnections lusr start size diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index f4a535d9bbf..1e8190f203e 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -108,7 +108,7 @@ updateOne2OneConv :: Maybe (Qualified ConvId) -> Relation -> Actor -> - (AppIO r) (Qualified ConvId) + AppIO (Qualified ConvId) updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do let request = UpsertOne2OneConversationRequest @@ -181,7 +181,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. -pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppIO r) () +pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing Intra.onConnectionEvent (tUnqualified self) mzcon event @@ -238,7 +238,7 @@ performRemoteAction :: Remote UserId -> Maybe UserConnection -> RemoteConnectionAction -> - (AppIO r) (Maybe RemoteConnectionAction) + AppIO (Maybe RemoteConnectionAction) performRemoteAction self other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection let rel1 = transition (RCA action) rel0 diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index 606e98388a4..b4730b0eaaa 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -33,11 +33,11 @@ import Data.Qualified (Local, tUnqualified) import Imports import Wire.API.Connection (Relation (..)) -type ConnectionM = ExceptT ConnectionError (AppIO r) +type ConnectionM = ExceptT ConnectionError AppIO -- Helpers -checkLimit :: Local UserId -> ExceptT ConnectionError (AppIO r) () +checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 237ab7430c5..b88d1efdf80 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -64,7 +64,7 @@ import System.Logger.Class (Logger) ------------------------------------------------------------------------------- -- HTTP Handler Monad -type Handler = ExceptT Error (AppIO r) +type Handler = ExceptT Error AppIO runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived runHandler e r h k = do diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 26cc9ce56e1..355e5ca1b9d 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -303,7 +303,7 @@ internalListClientsH :: JSON ::: JsonRequest UserSet -> Handler Response internalListClientsH (_ ::: req) = do json <$> (lift . internalListClients =<< parseJsonBody req) -internalListClients :: UserSet -> (AppIO r) UserClients +internalListClients :: UserSet -> AppIO UserClients internalListClients (UserSet usrs) = do UserClients . Map.fromList <$> API.lookupUsersClientIds (Set.toList usrs) @@ -312,7 +312,7 @@ internalListFullClientsH :: JSON ::: JsonRequest UserSet -> Handler Response internalListFullClientsH (_ ::: req) = json <$> (lift . internalListFullClients =<< parseJsonBody req) -internalListFullClients :: UserSet -> (AppIO r) UserClientsFull +internalListFullClients :: UserSet -> AppIO UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> Data.lookupClientsBulk (Set.toList usrs) @@ -371,7 +371,7 @@ listActivatedAccountsH :: JSON ::: Either (List UserId) (List Handle) ::: Bool - listActivatedAccountsH (_ ::: qry ::: includePendingInvitations) = do json <$> lift (listActivatedAccounts qry includePendingInvitations) -listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> (AppIO r) [UserAccount] +listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> AppIO [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of @@ -380,10 +380,10 @@ listActivatedAccounts elh includePendingInvitations = do us <- mapM (API.lookupHandle) (fromList hs) byIds (catMaybes us) where - byIds :: [UserId] -> (AppIO r) [UserAccount] + byIds :: [UserId] -> AppIO [UserAccount] byIds uids = API.lookupAccounts uids >>= filterM accountValid - accountValid :: UserAccount -> (AppIO r) Bool + accountValid :: UserAccount -> AppIO Bool accountValid account = case userIdentity . accountUser $ account of Nothing -> pure False Just ident -> @@ -426,7 +426,7 @@ getPasswordResetCodeH :: JSON ::: Either Email Phone -> Handler Response getPasswordResetCodeH (_ ::: emailOrPhone) = do maybe (throwStd invalidPwResetKey) (pure . json) =<< lift (getPasswordResetCode emailOrPhone) -getPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe GetPasswordResetCodeResp) +getPasswordResetCode :: Either Email Phone -> AppIO (Maybe GetPasswordResetCodeResp) getPasswordResetCode emailOrPhone = do GetPasswordResetCodeResp <$$> API.lookupPasswordResetCode emailOrPhone diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index 48d5af9e9c1..d6c3e00cd18 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -36,17 +36,17 @@ import Control.Error import Data.Id import Imports -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () +setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () setProperty u c k v = do Data.insertProperty u k v lift $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: UserId -> ConnId -> PropertyKey -> (AppIO r) () +deleteProperty :: UserId -> ConnId -> PropertyKey -> AppIO () deleteProperty u c k = do Data.deleteProperty u k Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: UserId -> ConnId -> (AppIO r) () +clearProperties :: UserId -> ConnId -> AppIO () clearProperties u c = do Data.clearProperties u Intra.onPropertyEvent u c (PropertiesCleared u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index b547f10bd1b..f1c7bef947f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -724,7 +724,7 @@ createUser (Public.NewUserPublic new) = do UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel pure $ CreateUserResponse cok userId (Public.SelfProfile usr) where - sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppIO r) () + sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> AppIO () sendActivationEmail e u p l mTeamUser | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, @@ -733,7 +733,7 @@ createUser (Public.NewUserPublic new) = do | otherwise = sendActivationMail e u p l Nothing - sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppIO r) () + sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> AppIO () -- NOTE: Welcome e-mails for the team creator are not dealt by brig anymore sendWelcomeEmail e (CreateUserTeam t n) newUser l = case newUser of Public.NewTeamCreator _ -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 0a28a189e7d..ccbb7df3623 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -163,7 +163,7 @@ data AllowSCIMUpdates ------------------------------------------------------------------------------- -- Create User -verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError (AppIO r) () +verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError AppIO () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk blacklisted <- lift $ Blacklist.exists uk @@ -177,7 +177,7 @@ verifyUniquenessAndCheckBlacklist uk = do DuplicateUserKey k -- docs/reference/user/registration.md {#RefRegistration} -createUser :: NewUser -> ExceptT CreateUserError (AppIO r) CreateUserResult +createUser :: NewUser -> ExceptT CreateUserError AppIO CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -276,7 +276,7 @@ createUser new = do where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT r IO) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT IO) (Maybe Email, Maybe Phone) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> @@ -297,7 +297,7 @@ createUser new = do pure (email, phone) - findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError (AppIO r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError AppIO (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE MissingIdentity findTeamInvitation (Just e) c = lift (Team.lookupInvitationInfo c) >>= \case @@ -311,7 +311,7 @@ createUser new = do _ -> throwE InvalidInvitationCode Nothing -> throwE InvalidInvitationCode - ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError (AppIO r) () + ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError AppIO () ensureMemberCanJoin tid = do maxSize <- fromIntegral . setMaxTeamSize <$> view settings (TeamSize teamSize) <- TeamSize.teamSize tid @@ -330,7 +330,7 @@ createUser new = do Team.InvitationInfo -> UserKey -> UserIdentity -> - ExceptT CreateUserError (AppT r IO) () + ExceptT CreateUserError (AppT IO) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) ok <- lift $ Data.claimKey uk uid @@ -352,7 +352,7 @@ createUser new = do Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError (AppIO r) CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) added <- lift $ Intra.addTeamMember uid tid (Nothing, Team.defaultRole) @@ -369,7 +369,7 @@ createUser new = do pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) + handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT IO) (Maybe Activation) handleEmailActivation email uid newTeam = do fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do @@ -386,7 +386,7 @@ createUser new = do return Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) + handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT IO) (Maybe Activation) handlePhoneActivation phone uid = do pdata <- fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of Nothing -> do @@ -403,7 +403,7 @@ createUser new = do return Nothing pure pdata -initAccountFeatureConfig :: UserId -> (AppIO r) () +initAccountFeatureConfig :: UserId -> AppIO () initAccountFeatureConfig uid = do mbCciDefNew <- view (settings . getAfcConferenceCallingDefNewMaybe) forM_ mbCciDefNew $ Data.updateFeatureConferenceCalling uid . Just @@ -411,7 +411,7 @@ initAccountFeatureConfig uid = do -- | 'createUser' is becoming hard to maintian, and instead of adding more case distinctions -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. -createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error (AppIO r) UserAccount +createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error AppIO UserAccount createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`catchE` (throwE . Error.newUserError)) $ do email <- either (throwE . InvalidEmail rawEmail) pure (validateEmail rawEmail) let emKey = userEmailKey email @@ -438,7 +438,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. -checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError (AppIO r) () +checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError AppIO () checkRestrictedUserCreation new = do restrictPlease <- lift . asks $ fromMaybe False . setRestrictUserCreation . view settings when @@ -451,7 +451,7 @@ checkRestrictedUserCreation new = do ------------------------------------------------------------------------------- -- Update Profile -updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError (AppIO r) () +updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError AppIO () updateUser uid mconn uu allowScim = do for_ (uupName uu) $ \newName -> do mbUser <- lift $ Data.lookupUser WithPendingInvitations uid @@ -469,7 +469,7 @@ updateUser uid mconn uu allowScim = do ------------------------------------------------------------------------------- -- Update Locale -changeLocale :: UserId -> ConnId -> LocaleUpdate -> (AppIO r) () +changeLocale :: UserId -> ConnId -> LocaleUpdate -> AppIO () changeLocale uid conn (LocaleUpdate loc) = do Data.updateLocale uid loc Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) @@ -477,7 +477,7 @@ changeLocale uid conn (LocaleUpdate loc) = do ------------------------------------------------------------------------------- -- Update ManagedBy -changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> (AppIO r) () +changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> AppIO () changeManagedBy uid conn (ManagedByUpdate mb) = do Data.updateManagedBy uid mb Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) @@ -485,7 +485,7 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do -------------------------------------------------------------------------------- -- Change Handle -changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError (AppIO r) () +changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError AppIO () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid @@ -539,7 +539,7 @@ checkHandle uhandle = do -------------------------------------------------------------------------------- -- Check Handles -checkHandles :: [Handle] -> Word -> (AppIO r) [Handle] +checkHandles :: [Handle] -> Word -> AppIO [Handle] checkHandles check num = reverse <$> collectFree [] check num where collectFree free _ 0 = return free @@ -558,7 +558,7 @@ checkHandles check num = reverse <$> collectFree [] check num -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error (AppIO r) ChangeEmailResponse +changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error AppIO ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -576,7 +576,7 @@ changeSelfEmail u email allowScim = do (userIdentity usr) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError (AppIO r) ChangeEmailResult +changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError AppIO ChangeEmailResult changeEmail u email allowScim = do em <- either @@ -608,7 +608,7 @@ changeEmail u email allowScim = do ------------------------------------------------------------------------------- -- Change Phone -changePhone :: UserId -> Phone -> ExceptT ChangePhoneError (AppIO r) (Activation, Phone) +changePhone :: UserId -> Phone -> ExceptT ChangePhoneError AppIO (Activation, Phone) changePhone u phone = do canonical <- maybe @@ -633,7 +633,7 @@ changePhone u phone = do ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () +removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () removeEmail uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -647,7 +647,7 @@ removeEmail uid conn = do ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () +removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -665,7 +665,7 @@ removePhone uid conn = do ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity -revokeIdentity :: Either Email Phone -> (AppIO r) () +revokeIdentity :: Either Email Phone -> AppIO () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- Data.lookupKey uk @@ -697,7 +697,7 @@ revokeIdentity key = do ------------------------------------------------------------------------------- -- Change Account Status -changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError (AppIO r) () +changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError AppIO () changeAccountStatus usrs status = do e <- ask ev <- case status of @@ -708,12 +708,12 @@ changeAccountStatus usrs status = do PendingInvitation -> throwE InvalidAccountStatus liftIO $ mapConcurrently_ (runAppT e . (update ev)) usrs where - update :: (UserId -> UserEvent) -> UserId -> (AppIO r) () + update :: (UserId -> UserEvent) -> UserId -> AppIO () update ev u = do Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) -suspendAccount :: HasCallStack => List1 UserId -> (AppIO r) () +suspendAccount :: HasCallStack => List1 UserId -> AppIO () suspendAccount usrs = runExceptT (changeAccountStatus usrs Suspended) >>= \case Right _ -> pure () @@ -727,7 +727,7 @@ activate :: ActivationCode -> -- | The user for whom to activate the key. Maybe UserId -> - ExceptT ActivationError (AppIO r) ActivationResult + ExceptT ActivationError AppIO ActivationResult activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: @@ -738,7 +738,7 @@ activateWithCurrency :: -- | Potential currency update. -- ^ TODO: to be removed once billing supports currency changes after team creation Maybe Currency.Alpha -> - ExceptT ActivationError (AppIO r) ActivationResult + ExceptT ActivationError AppIO ActivationResult activateWithCurrency tgt code usr cur = do key <- mkActivationKey tgt Log.info $ @@ -759,12 +759,12 @@ activateWithCurrency tgt code usr cur = do tid <- Intra.getTeamId uid for_ tid $ \t -> Intra.changeTeamStatus t Team.Active cur -preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError (AppIO r) () +preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError AppIO () preverify tgt code = do key <- mkActivationKey tgt void $ Data.verifyCode key code -onActivated :: ActivationEvent -> (AppIO r) (UserId, Maybe UserIdentity, Bool) +onActivated :: ActivationEvent -> AppIO (UserId, Maybe UserIdentity, Bool) onActivated (AccountActivated account) = do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") @@ -779,7 +779,7 @@ onActivated (PhoneActivated uid phone) = do return (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} -sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppIO r) () +sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError AppIO () sendActivationCode emailOrPhone loc call = case emailOrPhone of Left email -> do ek <- @@ -861,7 +861,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of _otherwise -> sendActivationMail em name p loc' ident -mkActivationKey :: ActivationTarget -> ExceptT ActivationError (AppIO r) ActivationKey +mkActivationKey :: ActivationTarget -> ExceptT ActivationError AppIO ActivationKey mkActivationKey (ActivateKey k) = return k mkActivationKey (ActivateEmail e) = do ek <- @@ -881,7 +881,7 @@ mkActivationKey (ActivatePhone p) = do ------------------------------------------------------------------------------- -- Password Management -changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError (AppIO r) () +changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError AppIO () changePassword uid cp = do activated <- lift $ Data.isActivated uid unless activated $ @@ -898,7 +898,7 @@ changePassword uid cp = do throwE ChangePasswordMustDiffer lift $ Data.updatePassword uid newpw >> revokeAllCookies uid -beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError (AppIO r) (UserId, PasswordResetPair) +beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError AppIO (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target user <- lift (Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) return @@ -911,7 +911,7 @@ beginPasswordReset target = do throwE (PasswordResetInProgress Nothing) (user,) <$> lift (Data.createPasswordResetCode user target) -completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () +completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError AppIO () completePasswordReset ident code pw = do key <- mkPasswordResetKey ident muid :: Maybe UserId <- lift $ Data.verifyPasswordResetCode (key, code) @@ -927,14 +927,14 @@ completePasswordReset ident code pw = do -- | Pull the current password of a user and compare it against the one about to be installed. -- If the two are the same, throw an error. If no current password can be found, do nothing. -checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () +checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError AppIO () checkNewIsDifferent uid pw = do mcurrpw <- lift $ Data.lookupPassword uid case mcurrpw of Just currpw | verifyPassword pw currpw -> throwE ResetPasswordMustDiffer _ -> pure () -mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError (AppIO r) PasswordResetKey +mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError AppIO PasswordResetKey mkPasswordResetKey ident = case ident of PasswordResetIdentityKey k -> return k PasswordResetEmailIdentity e -> user (userEmailKey e) >>= liftIO . Data.mkPasswordResetKey @@ -953,7 +953,7 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. -deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppIO r) (Maybe Timeout) +deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError AppIO (Maybe Timeout) deleteUser uid pwd = do account <- lift $ Data.lookupAccount uid case account of @@ -965,7 +965,7 @@ deleteUser uid pwd = do Ephemeral -> go a PendingInvitation -> go a where - ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT r IO) () + ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT IO) () ensureNotOwner acc = do case userTeam $ accountUser acc of Nothing -> pure () @@ -1026,7 +1026,7 @@ deleteUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. -verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError (AppIO r) () +verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError AppIO () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d @@ -1040,7 +1040,7 @@ verifyDeleteUser d = do -- via deleting self. -- Team owners can be deleted if the team is not orphaned, i.e. there is at least one -- other owner left. -deleteAccount :: UserAccount -> (AppIO r) () +deleteAccount :: UserAccount -> AppIO () deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") @@ -1081,14 +1081,14 @@ deleteAccount account@(accountUser -> user) = do ------------------------------------------------------------------------------- -- Lookups -lookupActivationCode :: Either Email Phone -> (AppIO r) (Maybe ActivationPair) +lookupActivationCode :: Either Email Phone -> AppIO (Maybe ActivationPair) lookupActivationCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone k <- liftIO $ Data.mkActivationKey uk c <- fmap snd <$> Data.lookupActivationCode uk return $ (k,) <$> c -lookupPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe PasswordResetPair) +lookupPasswordResetCode :: Either Email Phone -> AppIO (Maybe PasswordResetPair) lookupPasswordResetCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone usr <- Data.lookupKey uk @@ -1099,12 +1099,12 @@ lookupPasswordResetCode emailOrPhone = do c <- Data.lookupPasswordResetCode u return $ (k,) <$> c -deleteUserNoVerify :: UserId -> (AppIO r) () +deleteUserNoVerify :: UserId -> AppIO () deleteUserNoVerify uid = do queue <- view internalEvents Queue.enqueue queue (Internal.DeleteUser uid) -deleteUsersNoVerify :: [UserId] -> (AppIO r) () +deleteUsersNoVerify :: [UserId] -> AppIO () deleteUsersNoVerify uids = do for_ uids deleteUserNoVerify m <- view metrics @@ -1113,7 +1113,7 @@ deleteUsersNoVerify uids = do -- | Garbage collect users if they're ephemeral and they have expired. -- Always returns the user (deletion itself is delayed) -userGC :: User -> (AppIO r) User +userGC :: User -> AppIO User userGC u = case (userExpire u) of Nothing -> return u (Just (fromUTCTimeMillis -> e)) -> do @@ -1123,7 +1123,7 @@ userGC u = case (userExpire u) of deleteUserNoVerify (userId u) return u -lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError (AppIO r) (Maybe UserProfile) +lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfilesFromDomain @@ -1140,7 +1140,7 @@ lookupProfiles :: Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> - ExceptT FederationError (AppIO r) [UserProfile] + ExceptT FederationError AppIO [UserProfile] lookupProfiles self others = fmap concat $ traverseConcurrentlyWithErrors @@ -1148,14 +1148,14 @@ lookupProfiles self others = (bucketQualified others) lookupProfilesFromDomain :: - Local UserId -> Qualified [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] + Local UserId -> Qualified [UserId] -> ExceptT FederationError AppIO [UserProfile] lookupProfilesFromDomain self = foldQualified self (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) lookupRemoteProfiles -lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] +lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError AppIO [UserProfile] lookupRemoteProfiles (qUntagged -> Qualified uids domain) = Federation.getUsersByIds domain uids @@ -1167,7 +1167,7 @@ lookupLocalProfiles :: Maybe UserId -> -- | The users ('others') for which to obtain the profiles. [UserId] -> - (AppIO r) [UserProfile] + AppIO [UserProfile] lookupLocalProfiles requestingUser others = do users <- Data.lookupUsers NoPendingInvitations others >>= mapM userGC css <- case requestingUser of @@ -1186,7 +1186,7 @@ lookupLocalProfiles requestingUser others = do toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - getSelfInfo :: UserId -> (AppIO r) (Maybe (TeamId, Team.TeamMember)) + getSelfInfo :: UserId -> AppIO (Maybe (TeamId, Team.TeamMember)) getSelfInfo selfId = do -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') -- to return 'Nothing'. we could throw errors here if that happens, rather than just @@ -1206,10 +1206,10 @@ lookupLocalProfiles requestingUser others = do else publicProfile u userLegalHold in baseProfile {profileEmail = profileEmail'} -getLegalHoldStatus :: UserId -> (AppIO r) (Maybe UserLegalHoldStatus) +getLegalHoldStatus :: UserId -> AppIO (Maybe UserLegalHoldStatus) getLegalHoldStatus uid = traverse (getLegalHoldStatus' . accountUser) =<< lookupAccount uid -getLegalHoldStatus' :: User -> (AppIO r) UserLegalHoldStatus +getLegalHoldStatus' :: User -> AppIO UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus @@ -1241,7 +1241,7 @@ getEmailForProfile _ EmailVisibleToSelf' = Nothing -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppIO r) [UserAccount] +lookupAccountsByIdentity :: Either Email Phone -> Bool -> AppIO [UserAccount] lookupAccountsByIdentity emailOrPhone includePendingInvitations = do let uk = either userEmailKey userPhoneKey emailOrPhone activeUid <- Data.lookupKey uk @@ -1251,26 +1251,26 @@ lookupAccountsByIdentity emailOrPhone includePendingInvitations = do then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result -isBlacklisted :: Either Email Phone -> (AppIO r) Bool +isBlacklisted :: Either Email Phone -> AppIO Bool isBlacklisted emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.exists uk -blacklistInsert :: Either Email Phone -> (AppIO r) () +blacklistInsert :: Either Email Phone -> AppIO () blacklistInsert emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.insert uk -blacklistDelete :: Either Email Phone -> (AppIO r) () +blacklistDelete :: Either Email Phone -> AppIO () blacklistDelete emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.delete uk -phonePrefixGet :: PhonePrefix -> (AppIO r) [ExcludedPrefix] +phonePrefixGet :: PhonePrefix -> AppIO [ExcludedPrefix] phonePrefixGet prefix = Blacklist.getAllPrefixes prefix -phonePrefixDelete :: PhonePrefix -> (AppIO r) () +phonePrefixDelete :: PhonePrefix -> AppIO () phonePrefixDelete = Blacklist.deletePrefix -phonePrefixInsert :: ExcludedPrefix -> (AppIO r) () +phonePrefixInsert :: ExcludedPrefix -> AppIO () phonePrefixInsert = Blacklist.insertPrefix diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 4f5ecbcb9c9..58d90d80c28 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -57,7 +57,7 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> (AppIO r) (Maybe UserIdentity) +fetchUserIdentity :: UserId -> AppIO (Maybe UserIdentity) fetchUserIdentity uid = lookupSelfProfile uid >>= maybe @@ -65,7 +65,7 @@ fetchUserIdentity uid = (return . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> (AppIO r) (Maybe SelfProfile) +lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount where mk a = SelfProfile (accountUser a) @@ -83,9 +83,9 @@ logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCod -- | Traverse concurrently and fail on first error. traverseConcurrentlyWithErrors :: (Traversable t, Exception e) => - (a -> ExceptT e (AppIO r) b) -> + (a -> ExceptT e AppIO b) -> t a -> - ExceptT e (AppIO r) (t b) + ExceptT e AppIO (t b) traverseConcurrentlyWithErrors f = ExceptT . try . (traverse (either throwIO pure) =<<) . pooledMapConcurrentlyN 8 (runExceptT . f) diff --git a/services/brig/src/Brig/AWS/SesNotification.hs b/services/brig/src/Brig/AWS/SesNotification.hs index f4b10a0180f..1bcdccfc829 100644 --- a/services/brig/src/Brig/AWS/SesNotification.hs +++ b/services/brig/src/Brig/AWS/SesNotification.hs @@ -29,27 +29,27 @@ import Imports import System.Logger.Class (field, msg, (~~)) import qualified System.Logger.Class as Log -onEvent :: SESNotification -> (AppIO r) () +onEvent :: SESNotification -> AppIO () onEvent (MailBounce BouncePermanent es) = onPermanentBounce es onEvent (MailBounce BounceTransient es) = onTransientBounce es onEvent (MailBounce BounceUndetermined es) = onUndeterminedBounce es onEvent (MailComplaint es) = onComplaint es -onPermanentBounce :: [Email] -> (AppIO r) () +onPermanentBounce :: [Email] -> AppIO () onPermanentBounce = mapM_ $ \e -> do logEmailEvent "Permanent bounce" e Blacklist.insert (userEmailKey e) -onTransientBounce :: [Email] -> (AppIO r) () +onTransientBounce :: [Email] -> AppIO () onTransientBounce = mapM_ (logEmailEvent "Transient bounce") -onUndeterminedBounce :: [Email] -> (AppIO r) () +onUndeterminedBounce :: [Email] -> AppIO () onUndeterminedBounce = mapM_ (logEmailEvent "Undetermined bounce") -onComplaint :: [Email] -> (AppIO r) () +onComplaint :: [Email] -> AppIO () onComplaint = mapM_ $ \e -> do logEmailEvent "Complaint" e Blacklist.insert (userEmailKey e) -logEmailEvent :: Text -> Email -> (AppIO r) () +logEmailEvent :: Text -> Email -> AppIO () logEmailEvent t e = Log.info $ field "email" (fromEmail e) ~~ msg t diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index cb48e47c77f..dc4c9ecc3e2 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -419,13 +419,13 @@ initCredentials secretFile = do dat <- loadSecret secretFile return $ either (\e -> error $ "Could not load secrets from " ++ show secretFile ++ ": " ++ e) id dat -userTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, UserTemplates) +userTemplates :: Monad m => Maybe Locale -> AppT m (Locale, UserTemplates) userTemplates l = forLocale l <$> view usrTemplates -providerTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, ProviderTemplates) +providerTemplates :: Monad m => Maybe Locale -> AppT m (Locale, ProviderTemplates) providerTemplates l = forLocale l <$> view provTemplates -teamTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, TeamTemplates) +teamTemplates :: Monad m => Maybe Locale -> AppT m (Locale, TeamTemplates) teamTemplates l = forLocale l <$> view tmTemplates closeEnv :: Env -> IO () @@ -437,7 +437,7 @@ closeEnv e = do ------------------------------------------------------------------------------- -- App Monad -newtype AppT r m a = AppT +newtype AppT m a = AppT { unAppT :: ReaderT Env m a } deriving newtype @@ -454,58 +454,58 @@ newtype AppT r m a = AppT ( Semigroup, Monoid ) - via (Ap (AppT r m) a) + via (Ap (AppT m) a) -type AppIO r = AppT r IO +type AppIO = AppT IO -instance MonadIO m => MonadLogger (AppT r m) where +instance MonadIO m => MonadLogger (AppT m) where log l m = do g <- view applog r <- view requestId Log.log g l $ field "request" (unRequestId r) ~~ m -instance MonadIO m => MonadLogger (ExceptT err (AppT r m)) where +instance MonadIO m => MonadLogger (ExceptT err (AppT m)) where log l m = lift (LC.log l m) -instance (Monad m, MonadIO m) => MonadHttp (AppT r m) where +instance (Monad m, MonadIO m) => MonadHttp (AppT m) where handleRequestWithCont req handler = do manager <- view httpManager liftIO $ withResponse req manager handler -instance MonadIO m => MonadZAuth (AppT r m) where +instance MonadIO m => MonadZAuth (AppT m) where liftZAuth za = view zauthEnv >>= \e -> runZAuth e za -instance MonadIO m => MonadZAuth (ExceptT err (AppT r m)) where +instance MonadIO m => MonadZAuth (ExceptT err (AppT m)) where liftZAuth = lift . liftZAuth -instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT r m) where +instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT m) where liftClient m = view casClient >>= \c -> runClient c m localState f = local (over casClient f) -instance MonadIndexIO (AppIO r) where +instance MonadIndexIO AppIO where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance (MonadIndexIO (AppT r m), Monad m) => MonadIndexIO (ExceptT err (AppT r m)) where +instance (MonadIndexIO (AppT m), Monad m) => MonadIndexIO (ExceptT err (AppT m)) where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance Monad m => HasRequestId (AppT r m) where +instance Monad m => HasRequestId (AppT m) where getRequestId = view requestId -instance MonadUnliftIO m => MonadUnliftIO (AppT r m) where +instance MonadUnliftIO m => MonadUnliftIO (AppT m) where withRunInIO inner = AppT . ReaderT $ \r -> withRunInIO $ \run -> inner (run . flip runReaderT r . unAppT) -runAppT :: Env -> AppT r m a -> m a +runAppT :: Env -> AppT m a -> m a runAppT e (AppT ma) = runReaderT ma e -runAppResourceT :: ResourceT (AppIO r) a -> (AppIO r) a +runAppResourceT :: ResourceT AppIO a -> AppIO a runAppResourceT ma = do e <- ask liftIO . runResourceT $ transResourceT (runAppT e) ma -forkAppIO :: Maybe UserId -> (AppIO r) a -> (AppIO r) () +forkAppIO :: Maybe UserId -> AppIO a -> AppIO () forkAppIO u ma = do a <- ask g <- view applog diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 919f93df768..1f3b394214c 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -78,7 +78,7 @@ activateKey :: ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError (AppIO r) (Maybe ActivationEvent) + ExceptT ActivationError AppIO (Maybe ActivationEvent) activateKey k c u = verifyCode k c >>= pickUser >>= activate where pickUser (uk, u') = maybe (throwE invalidUser) (return . (uk,)) (u <|> u') @@ -129,7 +129,7 @@ newActivation :: Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> - (AppIO r) Activation + AppIO Activation newActivation uk timeout u = do (typ, key, code) <- liftIO $ @@ -148,7 +148,7 @@ newActivation uk timeout u = do <$> randIntegerZeroToNMinusOne 1000000 -- | Lookup an activation code and it's associated owner (if any) for a 'UserKey'. -lookupActivationCode :: UserKey -> (AppIO r) (Maybe (Maybe UserId, ActivationCode)) +lookupActivationCode :: UserKey -> AppIO (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity @@ -157,7 +157,7 @@ lookupActivationCode k = verifyCode :: ActivationKey -> ActivationCode -> - ExceptT ActivationError (AppIO r) (UserKey, Maybe UserId) + ExceptT ActivationError AppIO (UserKey, Maybe UserId) verifyCode key code = do s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of @@ -185,7 +185,7 @@ mkActivationKey k = do let bs = digestBS d' (T.encodeUtf8 $ keyText k) return . ActivationKey $ Ascii.encodeBase64Url bs -deleteActivationPair :: ActivationKey -> (AppIO r) () +deleteActivationPair :: ActivationKey -> AppIO () deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 4289470dd0d..b6178a0a8d5 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -94,7 +94,7 @@ addClient :: Int -> Maybe Location -> Maybe (Imports.Set ClientCapability) -> - ExceptT ClientDataError (AppIO r) (Client, [Client], Word) + ExceptT ClientDataError AppIO (Client, [Client], Word) addClient u newId c maxPermClients loc cps = do clients <- lookupClients u let typed = filter ((== newClientType c) . clientType) clients @@ -120,7 +120,7 @@ addClient u newId c maxPermClients loc cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: ExceptT ClientDataError (AppIO r) Client + insert :: ExceptT ClientDataError AppIO Client insert = do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) @@ -184,7 +184,7 @@ lookupPrekeyIds u c = hasClient :: MonadClient m => UserId -> ClientId -> m Bool hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) -rmClient :: UserId -> ClientId -> (AppIO r) () +rmClient :: UserId -> ClientId -> AppIO () rmClient u c = do retry x5 $ write removeClient (params LocalQuorum (u, c)) retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) @@ -212,7 +212,7 @@ updatePrekeys u c pks = do Success n -> return (CryptoBox.prekeyId n == keyId (prekeyId a)) _ -> return False -claimPrekey :: UserId -> ClientId -> (AppIO r) (Maybe ClientPrekey) +claimPrekey :: UserId -> ClientId -> AppIO (Maybe ClientPrekey) claimPrekey u c = view randomPrekeyLocalLock >>= \case -- Use random prekey selection strategy @@ -225,7 +225,7 @@ claimPrekey u c = prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) removeAndReturnPreKey prekey where - removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> (AppIO r) (Maybe ClientPrekey) + removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> AppIO (Maybe ClientPrekey) removeAndReturnPreKey (Just (i, k)) = do if i /= lastPrekeyId then retry x1 $ write removePrekey (params LocalQuorum (u, c, i)) @@ -237,7 +237,7 @@ claimPrekey u c = return $ Just (ClientPrekey c (Prekey i k)) removeAndReturnPreKey Nothing = return Nothing - pickRandomPrekey :: [(PrekeyId, Text)] -> (AppIO r) (Maybe (PrekeyId, Text)) + pickRandomPrekey :: [(PrekeyId, Text)] -> AppIO (Maybe (PrekeyId, Text)) pickRandomPrekey [] = return Nothing -- unless we only have one key left pickRandomPrekey [pk] = return $ Just pk @@ -330,13 +330,13 @@ ddbKey u c = AWS.attributeValue & AWS.avS ?~ UUID.toText (toUUID u) <> "." <> cl key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue key u c = HashMap.singleton ddbClient (ddbKey u c) -deleteOptLock :: UserId -> ClientId -> (AppIO r) () +deleteOptLock :: UserId -> ClientId -> AppIO () deleteOptLock u c = do t <- view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) void $ exec e (AWS.deleteItem t & AWS.diKey .~ (key u c)) -withOptLock :: UserId -> ClientId -> (AppIO r) a -> (AppIO r) a +withOptLock :: UserId -> ClientId -> AppIO a -> AppIO a withOptLock u c ma = go (10 :: Int) where go !n = do @@ -372,17 +372,17 @@ withOptLock u c ma = go (10 :: Int) key u c toAttributeValue :: Word32 -> AWS.AttributeValue toAttributeValue w = AWS.attributeValue & AWS.avN ?~ AWS.toText (fromIntegral w :: Int) - reportAttemptFailure :: (AppIO r) () + reportAttemptFailure :: AppIO () reportAttemptFailure = Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_grab_attempt_failed") =<< view metrics - reportFailureAndLogError :: (AppIO r) () + reportFailureAndLogError :: AppIO () reportFailureAndLogError = do Log.err $ Log.field "user" (toByteString' u) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics - execDyn :: (AWS.AWSRequest r) => (AWS.Rs r -> Maybe a) -> (Text -> r) -> (AppIO r) (Maybe a) + execDyn :: (AWS.AWSRequest r) => (AWS.Rs r -> Maybe a) -> (Text -> r) -> AppIO (Maybe a) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) @@ -406,6 +406,6 @@ withOptLock u c ma = go (10 :: Int) return Nothing handleErr _ = return Nothing -withLocalLock :: MVar () -> (AppIO r) a -> (AppIO r) a +withLocalLock :: MVar () -> AppIO a -> AppIO a withLocalLock l ma = do (takeMVar l *> ma) `finally` putMVar l () diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index fe43894b4f4..949a458f57e 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -73,7 +73,7 @@ insertConnection :: Qualified UserId -> RelationWithHistory -> Qualified ConvId -> - (AppIO r) UserConnection + AppIO UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -92,7 +92,7 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do ucConvId = Just qcnv } -updateConnection :: UserConnection -> RelationWithHistory -> (AppIO r) UserConnection +updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection updateConnection c status = do self <- qualifyLocal (ucFrom c) now <- updateConnectionStatus self (ucTo c) status @@ -102,7 +102,7 @@ updateConnection c status = do ucLastUpdate = now } -updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> (AppIO r) UTCTimeMillis +updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -115,7 +115,7 @@ updateConnectionStatus self target status = do pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupConnection :: Local UserId -> Qualified UserId -> (AppIO r) (Maybe UserConnection) +lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) lookupConnection self target = runMaybeT $ do let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- @@ -143,7 +143,7 @@ lookupRelationWithHistory :: Local UserId -> -- | User 'B' Qualified UserId -> - (AppIO r) (Maybe RelationWithHistory) + AppIO (Maybe RelationWithHistory) lookupRelationWithHistory self target = do let local (tUnqualified -> ltarget) = query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) @@ -151,14 +151,14 @@ lookupRelationWithHistory self target = do query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) -lookupRelation :: Local UserId -> Qualified UserId -> (AppIO r) Relation +lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation lookupRelation self target = lookupRelationWithHistory self target <&> \case Nothing -> Cancelled Just relh -> (relationDropHistory relh) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) (ResultPage UserConnection) +lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> @@ -196,48 +196,48 @@ lookupRemoteConnectionsPage self pagingState size = (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus :: [UserId] -> [UserId] -> (AppIO r) [ConnectionStatus] +lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus from to = map toConnectionStatus <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus' :: [UserId] -> (AppIO r) [ConnectionStatus] +lookupConnectionStatus' :: [UserId] -> AppIO [ConnectionStatus] lookupConnectionStatus' from = map toConnectionStatus <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) -lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> (AppIO r) [ConnectionStatusV2] +lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) -lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> (AppIO r) [ConnectionStatusV2] +lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] + lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) -lookupAllStatuses :: Local [UserId] -> (AppIO r) [ConnectionStatusV2] +lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] lookupAllStatuses lfroms = do let froms = tUnqualified lfroms concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms where - lookupAndCombine :: UserId -> (AppIO r) [ConnectionStatusV2] + lookupAndCombine :: UserId -> AppIO [ConnectionStatusV2] lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u - lookupLocalStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] + lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupLocalStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) - lookupRemoteStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] + lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] lookupRemoteStatuses from = map (\(d, u, r) -> toConnectionStatusV2 from d u r) <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) @@ -248,20 +248,20 @@ lookupRemoteConnectedUsersC u maxResults = .| C.map (map (uncurry toRemoteUnsafe)) -- | See 'lookupContactListWithRelation'. -lookupContactList :: UserId -> (AppIO r) [UserId] +lookupContactList :: UserId -> AppIO [UserId] lookupContactList u = fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) -- | For a given user 'A', lookup the list of users that form his contact list, -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). -lookupContactListWithRelation :: UserId -> (AppIO r) [(UserId, RelationWithHistory)] +lookupContactListWithRelation :: UserId -> AppIO [(UserId, RelationWithHistory)] lookupContactListWithRelation 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.) -- Note: The count is eventually consistent. -countConnections :: Local UserId -> [Relation] -> (AppIO r) Int64 +countConnections :: Local UserId -> [Relation] -> AppIO Int64 countConnections u r = do rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) @@ -277,7 +277,7 @@ countConnections u r = do count n (Identity s) | (relationDropHistory s) `elem` r = n + 1 count n _ = n -deleteConnections :: UserId -> (AppIO r) () +deleteConnections :: UserId -> AppIO () deleteConnections u = do runConduit $ paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 @@ -287,7 +287,7 @@ deleteConnections u = do where delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) -deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> (AppIO r) () +deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = pooledForConcurrentlyN_ 16 locals $ \u -> write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index d5627e7e81b..c4665d92324 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 600 -createLoginCode :: UserId -> (AppIO r) PendingLoginCode +createLoginCode :: UserId -> AppIO PendingLoginCode createLoginCode u = do now <- liftIO =<< view currentTime code <- liftIO genCode @@ -57,7 +57,7 @@ createLoginCode u = do where genCode = LoginCode . T.pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -verifyLoginCode :: UserId -> LoginCode -> (AppIO r) Bool +verifyLoginCode :: UserId -> LoginCode -> AppIO Bool verifyLoginCode u c = do code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime @@ -67,7 +67,7 @@ verifyLoginCode u c = do Just (_, _, _) -> deleteLoginCode u >> return False Nothing -> return False -lookupLoginCode :: UserId -> (AppIO r) (Maybe PendingLoginCode) +lookupLoginCode :: UserId -> AppIO (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) @@ -77,10 +77,10 @@ lookupLoginCode u = do pending c now t = PendingLoginCode c (timeout now t) timeout now t = Timeout (t `diffUTCTime` now) -deleteLoginCode :: UserId -> (AppIO r) () +deleteLoginCode :: UserId -> AppIO () deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) -insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> (AppIO r) () +insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> AppIO () 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 942d14f4065..98295204b17 100644 --- a/services/brig/src/Brig/Data/PasswordReset.hs +++ b/services/brig/src/Brig/Data/PasswordReset.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 3600 -- 60 minutes -createPasswordResetCode :: UserId -> Either Email Phone -> (AppIO r) PasswordResetPair +createPasswordResetCode :: UserId -> Either Email Phone -> AppIO PasswordResetPair createPasswordResetCode u target = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -61,7 +61,7 @@ createPasswordResetCode u target = do PasswordResetCode . Ascii.unsafeFromText . pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -lookupPasswordResetCode :: UserId -> (AppIO r) (Maybe PasswordResetCode) +lookupPasswordResetCode :: UserId -> AppIO (Maybe PasswordResetCode) lookupPasswordResetCode u = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -70,7 +70,7 @@ lookupPasswordResetCode u = do validate now (Just (c, _, _, Just t)) | t > now = return $ Just c validate _ _ = return Nothing -verifyPasswordResetCode :: PasswordResetPair -> (AppIO r) (Maybe UserId) +verifyPasswordResetCode :: PasswordResetPair -> AppIO (Maybe UserId) verifyPasswordResetCode (k, c) = do now <- liftIO =<< view currentTime code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity k))) @@ -84,7 +84,7 @@ verifyPasswordResetCode (k, c) = do where countdown = retry x5 . write codeInsert . params LocalQuorum -deletePasswordResetCode :: PasswordResetKey -> (AppIO r) () +deletePasswordResetCode :: PasswordResetKey -> AppIO () deletePasswordResetCode k = retry x5 . write codeDelete $ params LocalQuorum (Identity k) mkPasswordResetKey :: (MonadIO m) => UserId -> m PasswordResetKey diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index 5ec00292621..822df183aa2 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -40,30 +40,30 @@ maxProperties = 16 data PropertiesDataError = TooManyProperties -insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () +insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () insertProperty u k v = do 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 LocalQuorum (u, k, v)) -deleteProperty :: UserId -> PropertyKey -> (AppIO r) () +deleteProperty :: UserId -> PropertyKey -> AppIO () deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) -clearProperties :: UserId -> (AppIO r) () +clearProperties :: UserId -> AppIO () clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) -lookupProperty :: UserId -> PropertyKey -> (AppIO r) (Maybe PropertyValue) +lookupProperty :: UserId -> PropertyKey -> AppIO (Maybe PropertyValue) lookupProperty u k = fmap runIdentity <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) -lookupPropertyKeys :: UserId -> (AppIO r) [PropertyKey] +lookupPropertyKeys :: UserId -> AppIO [PropertyKey] lookupPropertyKeys u = map runIdentity <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) -lookupPropertyKeysAndValues :: UserId -> (AppIO r) PropertyKeysAndValues +lookupPropertyKeysAndValues :: UserId -> AppIO PropertyKeysAndValues lookupPropertyKeysAndValues u = PropertyKeysAndValues <$> retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 3959dfc3fb0..55e4c7fd00e 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -116,7 +116,7 @@ data ReAuthError -- Condition (2.) is essential for maintaining handle uniqueness. It is guaranteed by the -- fact that we're setting getting @mbHandle@ from table @"user"@, and when/if it was added -- there, it was claimed properly. -newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> (AppIO r) (UserAccount, Maybe Password) +newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> AppIO (UserAccount, Maybe Password) newAccount u inv tid mbHandle = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -152,7 +152,7 @@ newAccount u inv tid mbHandle = do managedBy = fromMaybe defaultManagedBy (newUserManagedBy u) user uid domain l e = User uid (Qualified uid domain) ident name pict assets colour False l Nothing mbHandle e tid managedBy -newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> (AppIO r) UserAccount +newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> AppIO UserAccount newAccountInviteViaScim uid tid locale name email = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -176,7 +176,7 @@ newAccountInviteViaScim uid tid locale name email = do ManagedByScim -- | Mandatory password authentication. -authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError (AppIO r) () +authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError AppIO () authenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE AuthInvalidUser @@ -217,7 +217,7 @@ insertAccount :: Maybe Password -> -- | Whether the user is activated Bool -> - (AppIO r) () + AppIO () insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -260,10 +260,10 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc "INSERT INTO service_team (provider, service, user, conv, team) \ \VALUES (?, ?, ?, ?, ?)" -updateLocale :: UserId -> Locale -> (AppIO r) () +updateLocale :: UserId -> Locale -> AppIO () updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) -updateUser :: UserId -> UserUpdate -> (AppIO r) () +updateUser :: UserId -> UserUpdate -> AppIO () updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -272,13 +272,13 @@ updateUser u UserUpdate {..} = retry x5 . batch $ do for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) -updateEmail :: UserId -> Email -> (AppIO r) () +updateEmail :: UserId -> Email -> AppIO () updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) -updatePhone :: UserId -> Phone -> (AppIO r) () +updatePhone :: UserId -> Phone -> AppIO () updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) -updateSSOId :: UserId -> Maybe UserSSOId -> (AppIO r) Bool +updateSSOId :: UserId -> Maybe UserSSOId -> AppIO Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of @@ -287,21 +287,21 @@ updateSSOId u ssoid = do pure True Nothing -> pure False -updateManagedBy :: UserId -> ManagedBy -> (AppIO r) () +updateManagedBy :: UserId -> ManagedBy -> AppIO () updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) -updateHandle :: UserId -> Handle -> (AppIO r) () +updateHandle :: UserId -> Handle -> AppIO () updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) -updatePassword :: UserId -> PlainTextPassword -> (AppIO r) () +updatePassword :: UserId -> PlainTextPassword -> AppIO () updatePassword u t = do p <- liftIO $ mkSafePassword t retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) -updateRichInfo :: UserId -> RichInfoAssocList -> (AppIO r) () +updateRichInfo :: UserId -> RichInfoAssocList -> AppIO () updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) -updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> (AppIO r) (Maybe ApiFt.TeamFeatureStatusNoConfig) +updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> AppIO (Maybe ApiFt.TeamFeatureStatusNoConfig) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.tfwoStatus <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) @@ -310,13 +310,13 @@ updateFeatureConferenceCalling uid mbStatus = do update :: PrepQuery W (Maybe ApiFt.TeamFeatureStatusValue, UserId) () update = fromString $ "update user set feature_conference_calling = ? where id = ?" -deleteEmail :: UserId -> (AppIO r) () +deleteEmail :: UserId -> AppIO () deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) -deletePhone :: UserId -> (AppIO r) () +deletePhone :: UserId -> AppIO () deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) -deleteServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) () +deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () deleteServiceUser pid sid bid = do lookupServiceUser pid sid bid >>= \case Nothing -> pure () @@ -336,17 +336,17 @@ deleteServiceUser pid sid bid = do "DELETE FROM service_team \ \WHERE provider = ? AND service = ? AND team = ? AND user = ?" -updateStatus :: UserId -> AccountStatus -> (AppIO r) () +updateStatus :: UserId -> AccountStatus -> AppIO () 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 r) Bool +isActivated :: UserId -> AppIO Bool isActivated u = (== Just (Identity True)) <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) -filterActive :: [UserId] -> (AppIO r) [UserId] +filterActive :: [UserId] -> AppIO [UserId] filterActive us = map (view _1) . filter isActiveUser <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) @@ -355,46 +355,46 @@ filterActive us = isActiveUser (_, True, Just Active) = True isActiveUser _ = False -lookupUser :: HavePendingInvitations -> UserId -> (AppIO r) (Maybe User) +lookupUser :: HavePendingInvitations -> UserId -> AppIO (Maybe User) lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] -activateUser :: UserId -> UserIdentity -> (AppIO r) () +activateUser :: UserId -> UserIdentity -> AppIO () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) -deactivateUser :: UserId -> (AppIO r) () +deactivateUser :: UserId -> AppIO () deactivateUser u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) -lookupLocale :: UserId -> (AppIO r) (Maybe Locale) +lookupLocale :: UserId -> AppIO (Maybe Locale) lookupLocale u = do defLoc <- setDefaultUserLocale <$> view settings fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) -lookupName :: UserId -> (AppIO r) (Maybe Name) +lookupName :: UserId -> AppIO (Maybe Name) lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) -lookupPassword :: UserId -> (AppIO r) (Maybe Password) +lookupPassword :: UserId -> AppIO (Maybe Password) lookupPassword u = join . fmap runIdentity <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) -lookupStatus :: UserId -> (AppIO r) (Maybe AccountStatus) +lookupStatus :: UserId -> AppIO (Maybe AccountStatus) lookupStatus u = join . fmap runIdentity <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) -lookupRichInfo :: UserId -> (AppIO r) (Maybe RichInfoAssocList) +lookupRichInfo :: UserId -> AppIO (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users -lookupRichInfoMultiUsers :: [UserId] -> (AppIO r) [(UserId, RichInfo)] +lookupRichInfoMultiUsers :: [UserId] -> AppIO [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) @@ -402,7 +402,7 @@ lookupRichInfoMultiUsers users = do -- | 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* -- successful login. -lookupUserTeam :: UserId -> (AppIO r) (Maybe TeamId) +lookupUserTeam :: UserId -> AppIO (Maybe TeamId) lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) @@ -415,22 +415,22 @@ lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Ident -- | Return users with given IDs. -- -- Skips nonexistent users. /Does not/ skip users who have been deleted. -lookupUsers :: HavePendingInvitations -> [UserId] -> (AppIO r) [User] +lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] lookupUsers hpi usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) -lookupAccount :: UserId -> (AppIO r) (Maybe UserAccount) +lookupAccount :: UserId -> AppIO (Maybe UserAccount) lookupAccount u = listToMaybe <$> lookupAccounts [u] -lookupAccounts :: [UserId] -> (AppIO r) [UserAccount] +lookupAccounts :: [UserId] -> AppIO [UserAccount] lookupAccounts usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) -lookupServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) (Maybe (ConvId, Maybe TeamId)) +lookupServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) @@ -442,7 +442,7 @@ lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, s lookupServiceUsers :: ProviderId -> ServiceId -> - ConduitM () [(BotId, ConvId, Maybe TeamId)] (AppIO r) () + ConduitM () [(BotId, ConvId, Maybe TeamId)] AppIO () lookupServiceUsers pid sid = paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 where @@ -455,7 +455,7 @@ lookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> - ConduitM () [(BotId, ConvId)] (AppIO r) () + ConduitM () [(BotId, ConvId)] AppIO () lookupServiceUsersForTeam pid sid tid = paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index f4483c09b9b..c8e08659216 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -124,7 +124,7 @@ claimKey :: UserKey -> -- | The user claiming the key. UserId -> - (AppIO r) Bool + AppIO Bool claimKey k u = do free <- keyAvailable k (Just u) when free (insertKey u k) @@ -138,7 +138,7 @@ keyAvailable :: UserKey -> -- | The user looking to claim the key, if any. Maybe UserId -> - (AppIO r) Bool + AppIO Bool keyAvailable k u = do o <- lookupKey k case (o, u) of @@ -146,32 +146,32 @@ keyAvailable k u = do (Just x, Just y) | x == y -> return True (Just x, _) -> not <$> User.isActivated x -lookupKey :: UserKey -> (AppIO r) (Maybe UserId) +lookupKey :: UserKey -> AppIO (Maybe UserId) lookupKey k = fmap runIdentity <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) -insertKey :: UserId -> UserKey -> (AppIO r) () +insertKey :: UserId -> UserKey -> AppIO () insertKey u k = do hk <- hashKey k let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) -deleteKey :: UserKey -> (AppIO r) () +deleteKey :: UserKey -> AppIO () deleteKey k = do hk <- hashKey k retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) -hashKey :: UserKey -> (AppIO r) UserKeyHash +hashKey :: UserKey -> AppIO UserKeyHash hashKey uk = do d <- view digestSHA256 let d' = digestBS d $ T.encodeUtf8 (keyText uk) return . UserKeyHash $ MH.MultihashDigest MH.SHA256 (B.length d') d' -lookupPhoneHashes :: [ByteString] -> (AppIO r) [(ByteString, UserId)] +lookupPhoneHashes :: [ByteString] -> AppIO [(ByteString, UserId)] lookupPhoneHashes hp = mapMaybe mk <$> retry x1 (query selectHashed (params One (Identity hashed))) where diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 2f1222194d7..4a11f83c1d6 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -38,14 +38,14 @@ data UserPendingActivation = UserPendingActivation } deriving stock (Eq, Show, Ord) -usersPendingActivationAdd :: UserPendingActivation -> (AppIO r) () +usersPendingActivationAdd :: UserPendingActivation -> AppIO () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do 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 r) (Page UserPendingActivation) +usersPendingActivationList :: AppIO (Page UserPendingActivation) usersPendingActivationList = do uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where @@ -53,10 +53,10 @@ usersPendingActivationList = do selectExpired = "SELECT user, expires_at FROM users_pending_activation" -usersPendingActivationRemove :: UserId -> (AppIO r) () +usersPendingActivationRemove :: UserId -> AppIO () usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] -usersPendingActivationRemoveMultiple :: [UserId] -> (AppIO r) () +usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () usersPendingActivationRemoveMultiple uids = retry x5 . write deleteExpired . params LocalQuorum $ (Identity uids) where diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index a411875b493..fa6253c1eb6 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -49,7 +49,7 @@ import Imports import Network.Mail.Mime ------------------------------------------------------------------------------- -sendMail :: Mail -> (AppIO r) () +sendMail :: Mail -> AppIO () sendMail m = view smtpEnv >>= \case Just smtp -> SMTP.sendMail smtp m diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 92784ffd2f2..73cec62b241 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -50,7 +50,7 @@ import Wire.API.User.Client (UserClientPrekeyMap) import Wire.API.User.Client.Prekey (ClientPrekey) import Wire.API.UserMap (UserMap) -type FederationAppIO = ExceptT FederationError (AppIO r) +type FederationAppIO = ExceptT FederationError AppIO getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) getUserHandleInfo (qUntagged -> Qualified handle domain) = do diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 2aa0c9cdd88..5568bb9171a 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -127,7 +127,7 @@ import qualified Wire.API.Team.Member as Member ----------------------------------------------------------------------------- -- Event Handlers -onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () +onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> AppIO () onUserEvent orig conn e = updateSearchIndex orig e *> dispatchNotifications orig conn e @@ -140,7 +140,7 @@ onConnectionEvent :: Maybe ConnId -> -- | The event. ConnectionEvent -> - (AppIO r) () + AppIO () onConnectionEvent orig conn evt = do let from = ucFrom (ucConn evt) notify @@ -156,7 +156,7 @@ onPropertyEvent :: -- | Client connection ID. ConnId -> PropertyEvent -> - (AppIO r) () + AppIO () onPropertyEvent orig conn e = notify (singleton $ PropertyEvent e) @@ -172,7 +172,7 @@ onClientEvent :: Maybe ConnId -> -- | The event. ClientEvent -> - (AppIO r) () + AppIO () onClientEvent orig conn e = do let events = singleton (ClientEvent e) let rcps = list1 orig [] @@ -181,7 +181,7 @@ onClientEvent orig conn e = do -- in the stream. push events rcps orig Push.RouteAny conn -updateSearchIndex :: UserId -> UserEvent -> (AppIO r) () +updateSearchIndex :: UserId -> UserEvent -> AppIO () updateSearchIndex orig e = case e of -- no-ops UserCreated {} -> return () @@ -206,7 +206,7 @@ updateSearchIndex orig e = case e of ] when interesting $ Search.reindex orig -journalEvent :: UserId -> UserEvent -> (AppIO r) () +journalEvent :: UserId -> UserEvent -> AppIO () journalEvent orig e = case e of UserActivated acc -> Journal.userActivate acc @@ -229,7 +229,7 @@ journalEvent orig e = case e of -- | Notify the origin user's contact list (first-level contacts), -- as well as his other clients about a change to his user account -- or profile. -dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () +dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> AppIO () dispatchNotifications orig conn e = case e of UserCreated {} -> return () UserSuspended {} -> return () @@ -252,21 +252,21 @@ dispatchNotifications orig conn e = case e of where event = singleton $ UserEvent e -notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> (AppIO r) () +notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> AppIO () notifyUserDeletionLocals deleted conn event = do recipients <- list1 deleted <$> lookupContactList deleted notify event deleted Push.RouteDirect conn (pure recipients) -notifyUserDeletionRemotes :: UserId -> (AppIO r) () +notifyUserDeletionRemotes :: UserId -> AppIO () notifyUserDeletionRemotes deleted = do runConduit $ Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) .| C.mapM_ fanoutNotifications where - fanoutNotifications :: [Remote UserId] -> (AppIO r) () + fanoutNotifications :: [Remote UserId] -> AppIO () fanoutNotifications = mapM_ notifyBackend . bucketRemote - notifyBackend :: Remote [UserId] -> (AppIO r) () + notifyBackend :: Remote [UserId] -> AppIO () notifyBackend uids = do case tUnqualified (checked <$> uids) of Nothing -> @@ -279,7 +279,7 @@ notifyUserDeletionRemotes deleted = do whenLeft eitherFErr $ logFederationError (tDomain uids) - logFederationError :: Domain -> FederationError -> AppT r IO () + logFederationError :: Domain -> FederationError -> AppT IO () logFederationError domain fErr = Log.err $ Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) @@ -299,7 +299,7 @@ push :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - (AppIO r) () + AppIO () push (toList -> events) usrs orig route conn = case mapMaybe toPushData events of [] -> pure () @@ -323,7 +323,7 @@ rawPush :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - (AppIO r) () + AppIO () -- TODO: if we decide to have service whitelist events in Brig instead of -- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. rawPush (toList -> events) usrs orig route conn = do @@ -368,7 +368,7 @@ notify :: Maybe ConnId -> -- | Users to notify. IO (List1 UserId) -> - (AppIO r) () + AppIO () notify events orig route conn recipients = forkAppIO (Just orig) $ do rs <- liftIO recipients push events rs orig route conn @@ -381,7 +381,7 @@ notifySelf :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - (AppIO r) () + AppIO () notifySelf events orig route conn = notify events orig route conn (pure (singleton orig)) @@ -393,19 +393,19 @@ notifyContacts :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - (AppIO r) () + AppIO () notifyContacts events orig route conn = do env <- ask notify events orig route conn $ runAppT env $ list1 orig <$> liftA2 (++) contacts teamContacts where - contacts :: (AppIO r) [UserId] + contacts :: AppIO [UserId] contacts = lookupContactList orig - teamContacts :: (AppIO r) [UserId] + teamContacts :: AppIO [UserId] teamContacts = screenMemberList =<< getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts - screenMemberList :: Maybe Team.TeamMemberList -> (AppIO r) [UserId] + screenMemberList :: Maybe Team.TeamMemberList -> AppIO [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = return $ fmap (view Team.userId) (mems ^. Team.teamMembers) @@ -572,7 +572,7 @@ toApsData _ = Nothing -- Conversation Management -- | Calls 'Galley.API.createSelfConversationH'. -createSelfConv :: UserId -> (AppIO r) () +createSelfConv :: UserId -> AppIO () createSelfConv u = do debug $ remote "galley" @@ -590,7 +590,7 @@ createLocalConnectConv :: Local UserId -> Maybe Text -> Maybe ConnId -> - (AppIO r) ConvId + AppIO ConvId createLocalConnectConv from to cname conn = do debug $ logConnection (tUnqualified from) (qUntagged to) @@ -613,20 +613,20 @@ createConnectConv :: Qualified UserId -> Maybe Text -> Maybe ConnId -> - (AppIO r) (Qualified ConvId) + AppIO (Qualified ConvId) createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to qUntagged . qualifyAs lfrom <$> createLocalConnectConv lfrom lto cname conn where - ensureLocal :: Qualified a -> (AppIO r) (Local a) + ensureLocal :: Qualified a -> AppIO (Local a) ensureLocal x = do loc <- qualifyLocal () foldQualified loc pure (\_ -> throwM federationNotImplemented) x -- | Calls 'Galley.API.acceptConvH'. -acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation +acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation acceptLocalConnectConv from conn cnv = do debug $ remote "galley" @@ -640,7 +640,7 @@ acceptLocalConnectConv from conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation +acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation acceptConnectConv from conn = foldQualified from @@ -648,7 +648,7 @@ acceptConnectConv from conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. -blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) () +blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO () blockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -662,7 +662,7 @@ blockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) () +blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () blockConv lusr conn = foldQualified lusr @@ -670,7 +670,7 @@ blockConv lusr conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. -unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation +unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation unblockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -684,7 +684,7 @@ unblockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation +unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation unblockConv luid conn = foldQualified luid @@ -692,7 +692,7 @@ unblockConv luid conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.getConversationH'. -getConv :: UserId -> ConvId -> (AppIO r) (Maybe Conversation) +getConv :: UserId -> ConvId -> AppIO (Maybe Conversation) getConv usr cnv = do debug $ remote "galley" @@ -708,7 +708,7 @@ getConv usr cnv = do . zUser usr . expect [status200, status404] -upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> (AppIO r) UpsertOne2OneConversationResponse +upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> AppIO UpsertOne2OneConversationResponse upsertOne2OneConversation urequest = do response <- galleyRequest POST req case Bilge.statusCode response of @@ -721,7 +721,7 @@ upsertOne2OneConversation urequest = do . lbytes (encode urequest) -- | Calls 'Galley.API.getTeamConversationH'. -getTeamConv :: UserId -> TeamId -> ConvId -> (AppIO r) (Maybe Team.TeamConversation) +getTeamConv :: UserId -> TeamId -> ConvId -> AppIO (Maybe Team.TeamConversation) getTeamConv usr tid cnv = do debug $ remote "galley" @@ -741,7 +741,7 @@ getTeamConv usr tid cnv = do -- User management -- | Calls 'Galley.API.rmUserH', as well as gundeck and cargohold. -rmUser :: UserId -> [Asset] -> (AppIO r) () +rmUser :: UserId -> [Asset] -> AppIO () rmUser usr asts = do debug $ remote "gundeck" @@ -767,7 +767,7 @@ rmUser usr asts = do -- Client management -- | Calls 'Galley.API.addClientH'. -newClient :: UserId -> ClientId -> (AppIO r) () +newClient :: UserId -> ClientId -> AppIO () newClient u c = do debug $ remote "galley" @@ -778,7 +778,7 @@ newClient u c = do void $ galleyRequest POST (p . zUser u . expect2xx) -- | Calls 'Galley.API.rmClientH', as well as gundeck. -rmClient :: UserId -> ClientId -> (AppIO r) () +rmClient :: UserId -> ClientId -> AppIO () rmClient u c = do let cid = toByteString' c debug $ @@ -808,7 +808,7 @@ rmClient u c = do where expected = [status200, status204, status404] -lookupPushToken :: UserId -> (AppIO r) [Push.PushToken] +lookupPushToken :: UserId -> AppIO [Push.PushToken] lookupPushToken uid = do g <- view gundeck rsp <- @@ -826,7 +826,7 @@ lookupPushToken uid = do -- Team Management -- | Calls 'Galley.API.canUserJoinTeamH'. -checkUserCanJoinTeam :: TeamId -> (AppIO r) (Maybe Wai.Error) +checkUserCanJoinTeam :: TeamId -> AppIO (Maybe Wai.Error) checkUserCanJoinTeam tid = do debug $ remote "galley" @@ -843,7 +843,7 @@ checkUserCanJoinTeam tid = do . header "Content-Type" "application/json" -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. -addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> (AppIO r) Bool +addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> AppIO Bool addTeamMember u tid (minvmeta, role) = do debug $ remote "galley" @@ -863,7 +863,7 @@ addTeamMember u tid (minvmeta, role) = do . lbytes (encode bdy) -- | Calls 'Galley.API.createBindingTeamH'. -createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> (AppIO r) CreateUserTeam +createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> AppIO CreateUserTeam createTeam u t@(Team.BindingNewTeam bt) teamid = do debug $ remote "galley" @@ -883,7 +883,7 @@ createTeam u t@(Team.BindingNewTeam bt) teamid = do . lbytes (encode t) -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. -getTeamMember :: UserId -> TeamId -> (AppIO r) (Maybe Team.TeamMember) +getTeamMember :: UserId -> TeamId -> AppIO (Maybe Team.TeamMember) getTeamMember u tid = do debug $ remote "galley" @@ -903,7 +903,7 @@ getTeamMember u tid = do -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will -- be suspended, and the rest will remain active. -getTeamMembers :: TeamId -> (AppIO r) Team.TeamMemberList +getTeamMembers :: TeamId -> AppIO Team.TeamMemberList getTeamMembers tid = do debug $ remote "galley" . msg (val "Get team members") galleyRequest GET req >>= decodeBody "galley" @@ -912,7 +912,7 @@ getTeamMembers tid = do paths ["i", "teams", toByteString' tid, "members"] . expect2xx -memberIsTeamOwner :: TeamId -> UserId -> (AppIO r) Bool +memberIsTeamOwner :: TeamId -> UserId -> AppIO Bool memberIsTeamOwner tid uid = do r <- galleyRequest GET $ @@ -922,7 +922,7 @@ memberIsTeamOwner tid uid = do -- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. -- -- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: UserId -> (AppIO r) (Maybe Team.TeamMemberList) +getTeamContacts :: UserId -> AppIO (Maybe Team.TeamMemberList) getTeamContacts u = do debug $ remote "galley" . msg (val "Get team contacts") rs <- galleyRequest GET req @@ -935,7 +935,7 @@ getTeamContacts u = do . expect [status200, status404] -- | Calls 'Galley.API.getBindingTeamIdH'. -getTeamId :: UserId -> (AppIO r) (Maybe TeamId) +getTeamId :: UserId -> AppIO (Maybe TeamId) getTeamId u = do debug $ remote "galley" . msg (val "Get team from user") rs <- galleyRequest GET req @@ -948,7 +948,7 @@ getTeamId u = do . expect [status200, status404] -- | Calls 'Galley.API.getTeamInternalH'. -getTeam :: TeamId -> (AppIO r) Team.TeamData +getTeam :: TeamId -> AppIO Team.TeamData getTeam tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -958,7 +958,7 @@ getTeam tid = do . expect2xx -- | Calls 'Galley.API.getTeamInternalH'. -getTeamName :: TeamId -> (AppIO r) Team.TeamName +getTeamName :: TeamId -> AppIO Team.TeamName getTeamName tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -968,7 +968,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> (AppIO r) (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" @@ -978,7 +978,7 @@ getTeamLegalHoldStatus tid = do . expect2xx -- | Calls 'Galley.API.getSearchVisibilityInternalH'. -getTeamSearchVisibility :: TeamId -> (AppIO r) Team.TeamSearchVisibility +getTeamSearchVisibility :: TeamId -> AppIO Team.TeamSearchVisibility getTeamSearchVisibility tid = coerce @Team.TeamSearchVisibilityView @Team.TeamSearchVisibility <$> do debug $ remote "galley" . msg (val "Get search visibility settings") @@ -989,7 +989,7 @@ getTeamSearchVisibility tid = . expect2xx -- | Calls 'Galley.API.updateTeamStatusH'. -changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> (AppIO r) () +changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> AppIO () changeTeamStatus tid s cur = do debug $ remote "galley" . msg (val "Change Team status") void $ galleyRequest PUT req @@ -1000,7 +1000,7 @@ changeTeamStatus tid s cur = do . expect2xx . lbytes (encode $ Team.TeamStatusUpdate s cur) -guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) () +guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO () guardLegalhold protectee userClients = do res <- lift $ galleyRequest PUT req case Bilge.statusCode res of diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index 7703eb03e36..3a2aaf1d37b 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -47,19 +47,19 @@ import qualified Proto.UserEvents_Fields as U -- User journal operations to SQS are a no-op when the service is started -- without journaling arguments for user updates -userActivate :: User -> (AppIO r) () +userActivate :: User -> AppIO () userActivate u@User {..} = journalEvent UserEvent'USER_ACTIVATE userId (userEmail u) (Just userLocale) userTeam (Just userDisplayName) -userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> (AppIO r) () +userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> AppIO () userUpdate uid em loc nm = journalEvent UserEvent'USER_UPDATE uid em loc Nothing nm -userEmailRemove :: UserId -> Email -> (AppIO r) () +userEmailRemove :: UserId -> Email -> AppIO () userEmailRemove uid em = journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing -userDelete :: UserId -> (AppIO r) () +userDelete :: UserId -> AppIO () userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing -journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> (AppIO r) () +journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> AppIO () journalEvent typ uid em loc tid nm = view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do ts <- now diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 60b3b8d92f1..c2b3b8109e6 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -36,7 +36,7 @@ import UnliftIO (timeout) -- | Handle an internal event. -- -- Has a one-minute timeout that should be enough for anything that it does. -onEvent :: InternalNotification -> (AppIO r) () +onEvent :: InternalNotification -> AppIO () onEvent n = handleTimeout $ case n of DeleteUser uid -> do Log.info $ diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index cacf9321044..c3de7fe9508 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -73,7 +73,7 @@ data PhoneException instance Exception PhoneException -sendCall :: Nexmo.Call -> (AppIO r) () +sendCall :: Nexmo.Call -> AppIO () sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do m <- view httpManager cred <- view nexmoCreds @@ -99,9 +99,9 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do Nexmo.CallInternal -> True _ -> False ] - unreachable :: Nexmo.CallErrorResponse -> AppT r IO () + unreachable :: Nexmo.CallErrorResponse -> AppT IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Nexmo.CallErrorResponse -> AppT r IO () + barred :: Nexmo.CallErrorResponse -> AppT IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -109,7 +109,7 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do ~~ field "error" (show ex) ~~ field "phone" (Nexmo.callTo call) -sendSms :: Locale -> SMSMessage -> (AppIO r) () +sendSms :: Locale -> SMSMessage -> AppIO () sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do m <- view httpManager withSmsBudget smsTo $ do @@ -132,7 +132,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do _ -> throwM ex' Right () -> return () where - sendNexmoSms :: Manager -> (AppIO r) () + sendNexmoSms :: Manager -> AppIO () sendNexmoSms mgr = do crd <- view nexmoCreds void . liftIO . recovering x3 nexmoHandlers $ @@ -149,7 +149,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do ES -> Nexmo.UCS2 ZH -> Nexmo.UCS2 _ -> Nexmo.GSM7 - sendTwilioSms :: Manager -> (AppIO r) () + sendTwilioSms :: Manager -> AppIO () sendTwilioSms mgr = do crd <- view twilioCreds void . liftIO . recovering x3 twilioHandlers $ @@ -179,9 +179,9 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do 20503 -> True -- Temporarily Unavailable _ -> False ] - unreachable :: Twilio.ErrorResponse -> AppT r IO () + unreachable :: Twilio.ErrorResponse -> AppT IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Twilio.ErrorResponse -> AppT r IO () + barred :: Twilio.ErrorResponse -> AppT IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -194,7 +194,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do -- | Validate a phone number. Returns the canonical -- E.164 format of the given phone number on success. -validatePhone :: Phone -> (AppIO r) (Maybe Phone) +validatePhone :: Phone -> AppIO (Maybe Phone) validatePhone (Phone p) | isTestPhone p = return (Just (Phone p)) | otherwise = do @@ -223,7 +223,7 @@ smsBudget = budgetValue = 5 -- # of SMS within timeout } -withSmsBudget :: Text -> (AppIO r) a -> (AppIO r) a +withSmsBudget :: Text -> AppIO a -> AppIO a withSmsBudget phone go = do let k = BudgetKey ("sms#" <> phone) r <- withBudget k smsBudget go @@ -251,7 +251,7 @@ callBudget = budgetValue = 2 -- # of voice calls within timeout } -withCallBudget :: Text -> (AppIO r) a -> (AppIO r) a +withCallBudget :: Text -> AppIO a -> AppIO a withCallBudget phone go = do let k = BudgetKey ("call#" <> phone) r <- withBudget k callBudget go diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 717b53c98ac..774532db7f7 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -643,7 +643,7 @@ deleteService pid sid del = do queue <- view internalEvents lift $ Queue.enqueue queue (Internal.DeleteService pid sid) -finishDeleteService :: ProviderId -> ServiceId -> (AppIO r) () +finishDeleteService :: ProviderId -> ServiceId -> AppIO () finishDeleteService pid sid = do mbSvc <- DB.lookupService pid sid for_ mbSvc $ \svc -> do @@ -909,7 +909,7 @@ botGetClientH :: BotId -> Handler Response botGetClientH bot = do maybe (throwErrorDescriptionType @ClientNotFound) (pure . json) =<< lift (botGetClient bot) -botGetClient :: BotId -> (AppIO r) (Maybe Public.Client) +botGetClient :: BotId -> AppIO (Maybe Public.Client) botGetClient bot = do listToMaybe <$> User.lookupClients (botUserId bot) @@ -961,7 +961,7 @@ botGetUserClientsH :: UserId -> Handler Response botGetUserClientsH uid = do json <$> lift (botGetUserClients uid) -botGetUserClients :: UserId -> (AppIO r) [Public.PubClient] +botGetUserClients :: UserId -> AppIO [Public.PubClient] botGetUserClients uid = do pubClient <$$> User.lookupClients uid where @@ -992,7 +992,7 @@ activate pid old new = do throwStd emailExists DB.insertKey pid (mkEmailKey <$> old) emailKey -deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> (AppIO r) (Maybe Public.Event) +deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> AppIO (Maybe Public.Event) deleteBot zusr zcon bid cid = do -- Remove the bot from the conversation ev <- RPC.removeBotMember zusr zcon cid bid diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index b0d5f76b44f..f0b88831a8d 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -44,7 +44,7 @@ import Imports ------------------------------------------------------------------------------- -- Activation Email -sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> (AppIO r) () +sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> AppIO () sendActivationMail name email key code update = do tpl <- selectTemplate update . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -96,7 +96,7 @@ renderActivationUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Request Email -sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppIO r) () +sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> AppIO () sendApprovalRequestMail name email url descr key val = do tpl <- approvalRequestEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -147,7 +147,7 @@ renderApprovalUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Confirmation Email -sendApprovalConfirmMail :: Name -> Email -> (AppIO r) () +sendApprovalConfirmMail :: Name -> Email -> AppIO () sendApprovalConfirmMail name email = do tpl <- approvalConfirmEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -183,7 +183,7 @@ renderApprovalConfirmMail ApprovalConfirmEmail {..} ApprovalConfirmEmailTemplate -------------------------------------------------------------------------------- -- Password Reset Email -sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> (AppIO r) () +sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> AppIO () sendPasswordResetMail to key code = do tpl <- passwordResetEmail . snd <$> providerTemplates Nothing branding <- view templateBranding diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index d2dca30b6c2..03ce6c2f9a6 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -65,7 +65,7 @@ data ServiceError -- -- If the external service is unavailable, returns a specific error -- or the response body cannot be parsed, a 'ServiceError' is returned. -createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppIO r) NewBotResponse +createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError AppIO NewBotResponse createBot scon new = do let fprs = toList (sconFingerprints scon) (man, verifyFingerprints) <- view extGetManager @@ -130,7 +130,7 @@ extLogError scon e = -- Internal RPC -- | Set service connection information in galley. -setServiceConn :: ServiceConn -> (AppIO r) () +setServiceConn :: ServiceConn -> AppIO () setServiceConn scon = do Log.debug $ remote "galley" @@ -155,7 +155,7 @@ setServiceConn scon = do & set Galley.serviceEnabled (sconEnabled scon) -- | Remove service connection information from galley. -removeServiceConn :: ProviderId -> ServiceId -> (AppIO r) () +removeServiceConn :: ProviderId -> ServiceId -> AppIO () removeServiceConn pid sid = do Log.debug $ remote "galley" @@ -179,7 +179,7 @@ addBotMember :: ClientId -> ProviderId -> ServiceId -> - (AppIO r) Event + AppIO Event addBotMember zusr zcon conv bot clt pid sid = do Log.debug $ remote "galley" @@ -205,7 +205,7 @@ removeBotMember :: Maybe ConnId -> ConvId -> BotId -> - (AppIO r) (Maybe Event) + AppIO (Maybe Event) removeBotMember zusr zcon conv bot = do Log.debug $ remote "galley" diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index c4c811853e3..9e03c45cf65 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -63,7 +63,7 @@ import System.Logger.Class as Log hiding (settings) -- | Enqueue a message. -- -- Throws an error in case of failure. -enqueue :: ToJSON a => Queue -> a -> (AppIO r) () +enqueue :: ToJSON a => Queue -> a -> AppIO () enqueue (StompQueue queue) message = view stompEnv >>= \case Just env -> Stomp.enqueue (Stomp.broker env) queue message @@ -93,7 +93,7 @@ enqueue (SqsQueue queue) message = -- -- See documentation of underlying functions (e.g. 'Stomp.listen') for -- extra details. -listen :: (Show a, FromJSON a) => Queue -> (a -> (AppIO r) ()) -> (AppIO r) () +listen :: (Show a, FromJSON a) => Queue -> (a -> AppIO ()) -> AppIO () listen (StompQueue queue) callback = view stompEnv >>= \case Just env -> Stomp.listen (Stomp.broker env) queue callback diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index a9268ca9b9f..645abc530ed 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -62,19 +62,19 @@ expect ss rq = rq {checkResponse = check} cargoholdRequest :: StdMethod -> (Request -> Request) -> - (AppIO r) (Response (Maybe BL.ByteString)) + AppIO (Response (Maybe BL.ByteString)) cargoholdRequest = serviceRequest "cargohold" cargohold galleyRequest :: StdMethod -> (Request -> Request) -> - (AppIO r) (Response (Maybe BL.ByteString)) + AppIO (Response (Maybe BL.ByteString)) galleyRequest = serviceRequest "galley" galley gundeckRequest :: StdMethod -> (Request -> Request) -> - (AppIO r) (Response (Maybe BL.ByteString)) + AppIO (Response (Maybe BL.ByteString)) gundeckRequest = serviceRequest "gundeck" gundeck serviceRequest :: @@ -82,7 +82,7 @@ serviceRequest :: Control.Lens.Getting Request Env Request -> StdMethod -> (Request -> Request) -> - (AppIO r) (Response (Maybe BL.ByteString)) + AppIO (Response (Maybe BL.ByteString)) serviceRequest nm svc m r = do service <- view svc recovering x3 rpcHandlers $ diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index a2d283a5e68..dce7a876161 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -169,7 +169,7 @@ bodyParserErrorFormatter _ _ errMsg = Servant.errHeaders = [(HTTP.hContentType, HTTPMedia.renderHeader (Servant.contentType (Proxy @Servant.JSON)))] } -pendingActivationCleanup :: (AppIO r) () +pendingActivationCleanup :: AppIO () pendingActivationCleanup = do safeForever "pendingActivationCleanup" $ do now <- liftIO =<< view currentTime @@ -206,17 +206,17 @@ pendingActivationCleanup = do -- pause to keep worst-case noise in logs manageable threadDelay 60_000_000 - forExpirationsPaged :: ([UserPendingActivation] -> (AppIO r) ()) -> (AppIO r) () + forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () forExpirationsPaged f = do go =<< usersPendingActivationList where - go :: (Page UserPendingActivation) -> (AppIO r) () + go :: (Page UserPendingActivation) -> AppIO () go (Page hasMore result nextPage) = do f result when hasMore $ go =<< liftClient nextPage - threadDelayRandom :: (AppIO r) () + threadDelayRandom :: AppIO () threadDelayRandom = do cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings let d = realToFrac cleanupTimeout diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 20189b98fab..6b44547527a 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -42,21 +42,21 @@ import Imports ------------------------------------------------------------------------------- -- Invitation Email -sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> (AppIO r) () +sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> AppIO () sendInvitationMail to tid from code loc = do tpl <- invitationEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = InvitationEmail to tid code from Email.sendMail $ renderInvitationEmail mail tpl branding -sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () +sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () sendCreatorWelcomeMail to tid teamName loc = do tpl <- creatorWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = CreatorWelcomeEmail to tid teamName Email.sendMail $ renderCreatorWelcomeMail mail tpl branding -sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () +sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index bd530c489c4..64279ec00c5 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -27,7 +27,7 @@ import qualified Data.Set as Set import Galley.Types.Teams import Imports -ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error (AppIO r) () +ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error AppIO () ensurePermissions u t perms = do m <- lift $ Intra.getTeamMember u t unless (check m) $ @@ -40,7 +40,7 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error (AppIO r) () +ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error AppIO () ensurePermissionToAddUser u t inviteePerms = do minviter <- lift $ Intra.getTeamMember u t unless (check minviter) $ diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 38a068ffe05..e25ae0a82ae 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -308,7 +308,7 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do listCookiesH :: UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> Handler Response listCookiesH (u ::: ll ::: _) = json <$> lift (listCookies u ll) -listCookies :: UserId -> Maybe (List Public.CookieLabel) -> (AppIO r) Public.CookieList +listCookies :: UserId -> Maybe (List Public.CookieLabel) -> AppIO Public.CookieList listCookies u ll = do Public.CookieList <$> Auth.listCookies u (maybe [] fromList ll) @@ -406,7 +406,7 @@ tokenRequest = opt (userToken ||| legalHoldUserToken) .&. opt (accessToken ||| l ) Just t -> return t -tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> (AppIO r) Response +tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> AppIO Response tokenResponse (Auth.Access t Nothing) = pure $ json t tokenResponse (Auth.Access t (Just c)) = Auth.setResponseCookie c (json t) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 739a535df60..e11fb2cf127 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -78,7 +78,7 @@ data Access u = Access accessCookie :: !(Maybe (Cookie (ZAuth.Token u))) } -sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError (AppIO r) PendingLoginCode +sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError AppIO PendingLoginCode sendLoginCode phone call force = do pk <- maybe @@ -102,7 +102,7 @@ sendLoginCode phone call force = do else sendLoginSms ph (pendingLoginCode c) l return c -lookupLoginCode :: Phone -> (AppIO r) (Maybe PendingLoginCode) +lookupLoginCode :: Phone -> AppIO (Maybe PendingLoginCode) lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case Nothing -> return Nothing @@ -110,7 +110,7 @@ lookupLoginCode phone = Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") Data.lookupLoginCode u -login :: Login -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) +login :: Login -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) login (PasswordLogin li pw label _) typ = do case TeamFeatureSndFPasswordChallengeNotImplemented of -- mark this place to implement handling verification codes later @@ -135,19 +135,19 @@ login (SmsLogin phone code label) typ = do loginFailed uid newAccess @ZAuth.User @ZAuth.Access uid typ label -loginFailed :: UserId -> ExceptT LoginError (AppIO r) () +loginFailed :: UserId -> ExceptT LoginError AppIO () loginFailed uid = decrRetryLimit uid >> throwE LoginFailed -decrRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () +decrRetryLimit :: UserId -> ExceptT LoginError AppIO () decrRetryLimit = withRetryLimit (\k b -> withBudget k b $ pure ()) -checkRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () +checkRetryLimit :: UserId -> ExceptT LoginError AppIO () checkRetryLimit = withRetryLimit checkBudget withRetryLimit :: - (BudgetKey -> Budget -> ExceptT LoginError (AppIO r) (Budgeted ())) -> + (BudgetKey -> Budget -> ExceptT LoginError AppIO (Budgeted ())) -> UserId -> - ExceptT LoginError (AppIO r) () + ExceptT LoginError AppIO () withRetryLimit action uid = do mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) forM_ mLimitFailedLogins $ \opts -> do @@ -161,7 +161,7 @@ withRetryLimit action uid = do BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl BudgetedValue () _ -> pure () -logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure (AppIO r) () +logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure AppIO () logout uts at = do (u, ck) <- validateTokens uts (Just at) lift $ revokeCookies u [cookieId ck] [] @@ -170,7 +170,7 @@ renewAccess :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure (AppIO r) (Access u) + ExceptT ZAuth.Failure AppIO (Access u) renewAccess uts at = do (uid, ck) <- validateTokens uts at Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.renewAccess") @@ -184,7 +184,7 @@ revokeAccess :: PlainTextPassword -> [CookieId] -> [CookieLabel] -> - ExceptT AuthError (AppIO r) () + ExceptT AuthError AppIO () revokeAccess u pw cc ll = do Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") Data.authenticate u pw @@ -193,7 +193,7 @@ revokeAccess u pw cc ll = do -------------------------------------------------------------------------------- -- Internal -catchSuspendInactiveUser :: UserId -> e -> ExceptT e (AppIO r) () +catchSuspendInactiveUser :: UserId -> e -> ExceptT e AppIO () catchSuspendInactiveUser uid errval = do mustsuspend <- lift $ mustSuspendInactiveUser uid when mustsuspend $ do @@ -204,7 +204,7 @@ catchSuspendInactiveUser uid errval = do lift $ suspendAccount (List1.singleton uid) throwE errval -newAccess :: forall u a. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError (AppIO r) (Access u) +newAccess :: forall u a. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError AppIO (Access u) newAccess uid ct cl = do catchSuspendInactiveUser uid LoginSuspended r <- lift $ newCookieLimited uid ct cl @@ -214,7 +214,7 @@ newAccess uid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing return $ Access t (Just ck) -resolveLoginId :: LoginId -> ExceptT LoginError (AppIO r) UserId +resolveLoginId :: LoginId -> ExceptT LoginError AppIO UserId resolveLoginId li = do usr <- validateLoginId li >>= lift . either lookupKey lookupHandle case usr of @@ -226,7 +226,7 @@ resolveLoginId li = do else LoginFailed Just uid -> return uid -validateLoginId :: LoginId -> ExceptT LoginError (AppIO r) (Either UserKey Handle) +validateLoginId :: LoginId -> ExceptT LoginError AppIO (Either UserKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) @@ -240,7 +240,7 @@ validateLoginId (LoginByPhone phone) = validateLoginId (LoginByHandle h) = return (Right h) -isPendingActivation :: LoginId -> (AppIO r) Bool +isPendingActivation :: LoginId -> AppIO Bool isPendingActivation ident = case ident of (LoginByHandle _) -> return False (LoginByEmail e) -> checkKey (userEmailKey e) @@ -274,13 +274,13 @@ validateTokens :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) validateTokens uts at = do tokens <- forM uts $ \ut -> lift $ runExceptT (validateToken ut at) getFirstSuccessOrFirstFail tokens where -- FUTUREWORK: There is surely a better way to do this - getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) + getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) getFirstSuccessOrFirstFail tks = case (lefts $ NE.toList $ List1.toNonEmpty tks, rights $ NE.toList $ List1.toNonEmpty tks) of (_, (suc : _)) -> return suc ((e : _), _) -> throwE e @@ -290,7 +290,7 @@ validateToken :: ZAuth.TokenPair u a => ZAuth.Token u -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) validateToken ut at = do unless (maybe True ((ZAuth.userTokenOf ut ==) . ZAuth.accessTokenOf) at) $ throwE ZAuth.Invalid @@ -303,7 +303,7 @@ validateToken ut at = do return (ZAuth.userTokenOf ut, ck) -- | Allow to login as any user without having the credentials. -ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) +ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) ssoLogin (SsoLogin uid label) typ = do Data.reauthenticate uid Nothing `catchE` \case ReAuthMissingPassword -> pure () @@ -316,7 +316,7 @@ ssoLogin (SsoLogin uid label) typ = do newAccess @ZAuth.User @ZAuth.Access uid typ label -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. -legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError (AppIO r) (Access ZAuth.LegalHoldUser) +legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError AppIO (Access ZAuth.LegalHoldUser) legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do Data.reauthenticate uid plainTextPassword !>> LegalHoldReAuthError -- legalhold login is only possible if @@ -330,7 +330,7 @@ legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid typ label !>> LegalHoldLoginError -assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError (AppIO r) () +assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError AppIO () assertLegalHoldEnabled tid = do stat <- lift $ Intra.getTeamLegalHoldStatus tid case tfwoStatus stat of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 28023f58636..1bb09328eaf 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -68,7 +68,7 @@ newCookie :: UserId -> CookieType -> Maybe CookieLabel -> - (AppIO r) (Cookie (ZAuth.Token u)) + AppIO (Cookie (ZAuth.Token u)) newCookie uid typ label = do now <- liftIO =<< view currentTime tok <- @@ -90,7 +90,7 @@ newCookie uid typ label = do -- | Renew the given cookie with a fresh token, if its age -- exceeds the configured minimum threshold. -nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) +nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Maybe (Cookie (ZAuth.Token u))) nextCookie c = do s <- view settings now <- liftIO =<< view currentTime @@ -116,7 +116,7 @@ nextCookie c = do return c' {cookieValue = t} -- | Renew the given cookie with a fresh token. -renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Cookie (ZAuth.Token u)) +renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Cookie (ZAuth.Token u)) renewCookie old = do let t = cookieValue old let uid = ZAuth.userTokenOf t @@ -134,7 +134,7 @@ renewCookie old = do -- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', -- 'newCookieLimited' if there is a chance that the user should be suspended (we don't do it -- implicitly because of cyclical dependencies). -mustSuspendInactiveUser :: UserId -> (AppIO r) Bool +mustSuspendInactiveUser :: UserId -> AppIO Bool mustSuspendInactiveUser uid = view (settings . to setSuspendInactiveUsers) >>= \case Nothing -> pure False @@ -151,7 +151,7 @@ mustSuspendInactiveUser uid = | otherwise = True pure mustSuspend -newAccessToken :: forall u a r. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> (AppIO r) AccessToken +newAccessToken :: forall u a. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> AppIO AccessToken newAccessToken c mt = do t' <- case mt of Nothing -> ZAuth.newAccessToken (cookieValue c) @@ -166,7 +166,7 @@ newAccessToken c mt = do -- | Lookup the stored cookie associated with a user token, -- if one exists. -lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) +lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> AppIO (Maybe (Cookie (ZAuth.Token u))) lookupCookie t = do let user = ZAuth.userTokenOf t let rand = ZAuth.userTokenRand t @@ -175,16 +175,16 @@ lookupCookie t = do where setToken c = c {cookieValue = t} -listCookies :: UserId -> [CookieLabel] -> (AppIO r) [Cookie ()] +listCookies :: UserId -> [CookieLabel] -> AppIO [Cookie ()] listCookies u [] = DB.listCookies u listCookies u ll = filter byLabel <$> DB.listCookies u where byLabel c = maybe False (`elem` ll) (cookieLabel c) -revokeAllCookies :: UserId -> (AppIO r) () +revokeAllCookies :: UserId -> AppIO () revokeAllCookies u = revokeCookies u [] [] -revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> (AppIO r) () +revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> AppIO () revokeCookies u [] [] = DB.deleteAllCookies u revokeCookies u ids labels = do cc <- filter matching <$> DB.listCookies u @@ -202,7 +202,7 @@ newCookieLimited :: UserId -> CookieType -> Maybe CookieLabel -> - (AppIO r) (Either RetryAfter (Cookie (ZAuth.Token t))) + AppIO (Either RetryAfter (Cookie (ZAuth.Token t))) newCookieLimited u typ label = do cs <- filter ((typ ==) . cookieType) <$> DB.listCookies u now <- liftIO =<< view currentTime @@ -246,7 +246,7 @@ setResponseCookie c r = do -------------------------------------------------------------------------------- -- Tracking -trackSuperseded :: UserId -> CookieId -> (AppIO r) () +trackSuperseded :: UserId -> CookieId -> AppIO () trackSuperseded u c = do m <- view metrics Metrics.counterIncr (Metrics.path "user.auth.cookie.superseded") m diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index a5c366d22c2..1a089b56da7 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -45,14 +45,14 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where -- find uid given handle - go1 :: Bool -> Handle -> (AppIO r) (Maybe EJPDResponseItem) + go1 :: Bool -> Handle -> AppIO (Maybe EJPDResponseItem) go1 includeContacts' handle = do mbUid <- lookupHandle handle mbUsr <- maybe (pure Nothing) (lookupUser NoPendingInvitations) mbUid maybe (pure Nothing) (fmap Just . go2 includeContacts') mbUsr -- construct response item given uid - go2 :: Bool -> User -> (AppIO r) EJPDResponseItem + go2 :: Bool -> User -> AppIO EJPDResponseItem go2 includeContacts' target = do let uid = userId target diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs index b1c3e11c6a0..1a58f57285e 100644 --- a/services/brig/src/Brig/User/Email.hs +++ b/services/brig/src/Brig/User/Email.hs @@ -45,14 +45,14 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Lazy (toStrict) import Imports -sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> (AppIO r) () +sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> AppIO () sendVerificationMail to pair loc = do tpl <- verificationEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = VerificationEmail to pair Email.sendMail $ renderVerificationMail mail tpl branding -sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> (AppIO r) () +sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> AppIO () sendActivationMail to name pair loc ident = do tpl <- selectTemplate . snd <$> userTemplates loc branding <- view templateBranding @@ -64,26 +64,26 @@ sendActivationMail to name pair loc ident = do then activationEmail else activationEmailUpdate -sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> (AppIO r) () +sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> AppIO () sendPasswordResetMail to pair loc = do tpl <- passwordResetEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = PasswordResetEmail to pair Email.sendMail $ renderPwResetMail mail tpl branding -sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> (AppIO r) () +sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> AppIO () sendDeletionEmail name email key code locale = do tpl <- deletionEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderDeletionEmail tpl (DeletionEmail email name key code) branding -sendNewClientEmail :: Name -> Email -> Client -> Locale -> (AppIO r) () +sendNewClientEmail :: Name -> Email -> Client -> Locale -> AppIO () sendNewClientEmail name email client locale = do tpl <- newClientEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderNewClientEmail tpl (NewClientEmail locale email name client) branding -sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> (AppIO r) () +sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> AppIO () sendTeamActivationMail to name pair loc team = do tpl <- teamActivationEmail . snd <$> userTemplates loc let mail = TeamActivationEmail to name team pair diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 5616c5efb85..1f53d68492d 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -34,7 +34,7 @@ import Data.Id import Imports -- | Claim a new handle for an existing 'User'. -claimHandle :: UserId -> Maybe Handle -> Handle -> (AppIO r) Bool +claimHandle :: UserId -> Maybe Handle -> Handle -> AppIO Bool claimHandle uid oldHandle newHandle = isJust <$> do owner <- lookupHandle newHandle @@ -56,19 +56,19 @@ claimHandle uid oldHandle newHandle = return result -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: UserId -> Handle -> (AppIO r) () +freeHandle :: UserId -> Handle -> AppIO () freeHandle uid h = do 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 r) (Maybe UserId) +lookupHandle :: Handle -> AppIO (Maybe UserId) lookupHandle = lookupHandleWithPolicy LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. -glimpseHandle :: Handle -> (AppIO r) (Maybe UserId) +glimpseHandle :: Handle -> AppIO (Maybe UserId) glimpseHandle = lookupHandleWithPolicy One {-# INLINE lookupHandleWithPolicy #-} @@ -78,7 +78,7 @@ glimpseHandle = lookupHandleWithPolicy One -- -- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' -- and only allowing it to be parsed. -lookupHandleWithPolicy :: Consistency -> Handle -> (AppIO r) (Maybe UserId) +lookupHandleWithPolicy :: Consistency -> Handle -> AppIO (Maybe UserId) lookupHandleWithPolicy policy h = do join . fmap runIdentity <$> retry x1 (query1 handleSelect (params policy (Identity h))) diff --git a/services/brig/src/Brig/User/Phone.hs b/services/brig/src/Brig/User/Phone.hs index a172780d083..31ab888f2ac 100644 --- a/services/brig/src/Brig/User/Phone.hs +++ b/services/brig/src/Brig/User/Phone.hs @@ -52,37 +52,37 @@ import Data.Text.Lazy (toStrict) import Imports import qualified Ropes.Nexmo as Nexmo -sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () +sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> AppIO () sendActivationSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) branding -sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> (AppIO r) () +sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> AppIO () sendPasswordResetSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) branding -sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () +sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> AppIO () sendLoginSms to code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) branding -sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> (AppIO r) () +sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> AppIO () sendDeletionSms to key code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates (Just loc) sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) branding -sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () +sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> AppIO () sendActivationCall to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' branding -sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () +sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> AppIO () sendLoginCall to c loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc From 21ad2cef27826ba2448861d29c679171468aa64e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 17 Feb 2022 12:13:33 +0100 Subject: [PATCH 54/58] Backend feature config: 2nd factor for some password actions (#2138) * team feature definition * added to feature flags * schema migration for sndFactorPasswordChallenge * routes and handler, +it (failing atm) * integration tests and all features/configs endpoint handler * fix galley-tests build * changelog and config options docs update * moved changelog to internal * updated helm configmap --- changelog.d/5-internal/pr-2138 | 2 + charts/galley/templates/configmap.yaml | 4 ++ charts/galley/values.yaml | 7 ++- docs/reference/cassandra-schema.cql | 2 + docs/reference/config-options.md | 15 ++++++ libs/galley-types/src/Galley/Types/Teams.hs | 11 +++- .../test/unit/Test/Galley/Types.hs | 1 + .../src/Wire/API/Event/FeatureConfig.hs | 1 + .../src/Wire/API/Routes/Public/Galley.hs | 3 ++ libs/wire-api/src/Wire/API/Team/Feature.hs | 17 +++++++ services/galley/galley.cabal | 1 + services/galley/schema/src/Main.hs | 4 +- ...0_TeamFeatureSndFactorPasswordChallenge.hs | 34 +++++++++++++ services/galley/src/Galley/API/Internal.hs | 2 + .../galley/src/Galley/API/Public/Servant.hs | 14 ++++++ .../galley/src/Galley/API/Teams/Features.hs | 50 ++++++++++++++++++- services/galley/src/Galley/Cassandra.hs | 2 +- .../galley/src/Galley/Data/TeamFeatures.hs | 5 ++ .../test/integration/API/Teams/Feature.hs | 7 ++- 19 files changed, 173 insertions(+), 9 deletions(-) create mode 100644 changelog.d/5-internal/pr-2138 create mode 100644 services/galley/schema/src/V60_TeamFeatureSndFactorPasswordChallenge.hs diff --git a/changelog.d/5-internal/pr-2138 b/changelog.d/5-internal/pr-2138 new file mode 100644 index 00000000000..9e632da4a3a --- /dev/null +++ b/changelog.d/5-internal/pr-2138 @@ -0,0 +1,2 @@ +[not done yet, please do not enable] Optional team feature config `sndFactorPasswordChallenge` added to galley.yaml. +The feature is disabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#2nd-factor-password-challenge](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#2nd-factor-password-challenge) diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 548db7f85e9..ba36849e6c5 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -68,5 +68,9 @@ data: fileSharing: {{- toYaml .settings.featureFlags.fileSharing | nindent 10 }} {{- end }} + {{- if .settings.featureFlags.sndFactorPasswordChallenge }} + sndFactorPasswordChallenge: + {{- toYaml .settings.featureFlags.sndFactorPasswordChallenge | nindent 10 }} + {{- end }} {{- end }} {{- end }} diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 45e9c0ca77e..26546dba980 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -39,7 +39,12 @@ config: # fileSharing: # defaults: # status: enabled - # lockStatus: unlocked + # lockStatus: unlocked + # sndFactorPasswordChallenge setting is optional + # sndFactorPasswordChallenge: + # defaults: + # status: disabled + # lockStatus: unlocked aws: region: "eu-west-1" proxy: {} diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 5aee8661a51..ac4a6ce6461 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -429,6 +429,8 @@ CREATE TABLE galley_test.team_features ( self_deleting_messages_lock_status int, self_deleting_messages_status int, self_deleting_messages_ttl int, + snd_factor_password_challenge_lock_status int, + snd_factor_password_challenge_status int, sso_status int, validate_saml_emails int ) WITH bloom_filter_fp_chance = 0.1 diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index dc6665b1738..0e5e21fe381 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -180,6 +180,21 @@ validateSAMLEmails: status: disabled ``` +### 2nd Factor Password Challenge + +By default Wire enforces a 2nd factor authentication for certain user operations like e.g. activating an account, changing email or password, or deleting an account. +If this feature is enabled, a 2nd factor password challenge will be performed for a set of additional user operations like e.g. for generating SCIM tokens, login, or adding a client. + +Usually the default is what you want. If you explicitly want to enable the feature, use the following syntax: + +```yaml +# galley.yaml +sndFactorPasswordChallenge: + defaults: + status: disabled|enabled + lockStatus: locked|unlocked +``` + ### Federation Domain Regardless of whether a backend wants to enable federation or not, the operator diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 4313979db00..7c106a93d30 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -34,6 +34,7 @@ module Galley.Types.Teams flagSelfDeletingMessages, flagConversationGuestLinks, flagsTeamFeatureValidateSAMLEmailsStatus, + flagTeamFeatureSndFactorPasswordChallengeStatus, Defaults (..), unDefaults, FeatureSSO (..), @@ -218,7 +219,8 @@ data FeatureFlags = FeatureFlags _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)), _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)), - _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails)) + _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails)), + _flagTeamFeatureSndFactorPasswordChallengeStatus :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge)) } deriving (Eq, Show, Generic) @@ -267,6 +269,7 @@ instance FromJSON FeatureFlags where <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) <*> (fromMaybe (Defaults defaultGuestLinksStatus) <$> (obj .:? "conversationGuestLinks")) <*> (fromMaybe (Defaults defaultTeamFeatureValidateSAMLEmailsStatus) <$> (obj .:? "validateSAMLEmails")) + <*> (fromMaybe (Defaults defaultTeamFeatureSndFactorPasswordChallengeStatus) <$> (obj .:? "sndFactorPasswordChallenge")) instance ToJSON FeatureFlags where toJSON @@ -281,6 +284,7 @@ instance ToJSON FeatureFlags where selfDeletingMessages guestLinks validateSAMLEmails + sndFactorPasswordChallenge ) = object [ "sso" .= sso, @@ -292,7 +296,8 @@ instance ToJSON FeatureFlags where "conferenceCalling" .= conferenceCalling, "selfDeletingMessages" .= selfDeletingMessages, "conversationGuestLinks" .= guestLinks, - "validateSAMLEmails" .= validateSAMLEmails + "validateSAMLEmails" .= validateSAMLEmails, + "sndFactorPasswordChallenge" .= sndFactorPasswordChallenge ] instance FromJSON FeatureSSO where @@ -387,6 +392,7 @@ roleHiddenPermissions role = HiddenPermissions p p ChangeTeamFeature TeamFeatureClassifiedDomains {- the features not listed here can only be changed in stern -}, ChangeTeamFeature TeamFeatureSelfDeletingMessages, ChangeTeamFeature TeamFeatureGuestLinks, + ChangeTeamFeature TeamFeatureSndFactorPasswordChallenge, ChangeTeamMemberProfiles, ReadIdp, CreateUpdateDeleteIdp, @@ -409,6 +415,7 @@ roleHiddenPermissions role = HiddenPermissions p p ViewTeamFeature TeamFeatureConferenceCalling, ViewTeamFeature TeamFeatureSelfDeletingMessages, ViewTeamFeature TeamFeatureGuestLinks, + ViewTeamFeature TeamFeatureSndFactorPasswordChallenge, 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 6720b746947..43681bdf5ca 100644 --- a/libs/galley-types/test/unit/Test/Galley/Types.hs +++ b/libs/galley-types/test/unit/Test/Galley/Types.hs @@ -99,3 +99,4 @@ instance Arbitrary FeatureFlags where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index f9bfca464f3..6a3a9752fde 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -77,6 +77,7 @@ taggedEventDataSchema = TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema) TeamFeatureGuestLinks -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema) + TeamFeatureSndFactorPasswordChallenge -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema) eventObjectSchema :: ObjectSchema SwaggerDoc Event eventObjectSchema = 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 6e7b1f4be18..bd4c46d60f1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -920,6 +920,8 @@ type FeatureAPI = :<|> FeatureStatusPut 'TeamFeatureSelfDeletingMessages :<|> FeatureStatusGet 'TeamFeatureGuestLinks :<|> FeatureStatusPut 'TeamFeatureGuestLinks + :<|> FeatureStatusGet 'TeamFeatureSndFactorPasswordChallenge + :<|> FeatureStatusPut 'TeamFeatureSndFactorPasswordChallenge :<|> AllFeatureConfigsGet :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureLegalHold :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureSSO @@ -932,6 +934,7 @@ type FeatureAPI = :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureConferenceCalling :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureGuestLinks + :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge type FeatureStatusGet f = Named diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index bdd44107006..92aa3b062c8 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -43,6 +43,7 @@ module Wire.API.Team.Feature defaultGuestLinksStatus, defaultTeamFeatureFileSharing, defaultTeamFeatureValidateSAMLEmailsStatus, + defaultTeamFeatureSndFactorPasswordChallengeStatus, -- * Swagger typeTeamFeatureName, @@ -140,6 +141,7 @@ data TeamFeatureName | TeamFeatureConferenceCalling | TeamFeatureSelfDeletingMessages | TeamFeatureGuestLinks + | TeamFeatureSndFactorPasswordChallenge deriving stock (Eq, Show, Ord, Generic, Enum, Bounded, Typeable) deriving (Arbitrary) via (GenericUniform TeamFeatureName) @@ -191,6 +193,10 @@ instance KnownTeamFeatureName 'TeamFeatureGuestLinks where type KnownTeamFeatureNameSymbol 'TeamFeatureGuestLinks = "conversationGuestLinks" knownTeamFeatureName = TeamFeatureGuestLinks +instance KnownTeamFeatureName 'TeamFeatureSndFactorPasswordChallenge where + type KnownTeamFeatureNameSymbol 'TeamFeatureSndFactorPasswordChallenge = "sndFactorPasswordChallenge" + knownTeamFeatureName = TeamFeatureSndFactorPasswordChallenge + instance FromByteString TeamFeatureName where parser = Parser.takeByteString >>= \b -> @@ -210,6 +216,7 @@ instance FromByteString TeamFeatureName where Right "conferenceCalling" -> pure TeamFeatureConferenceCalling Right "selfDeletingMessages" -> pure TeamFeatureSelfDeletingMessages Right "conversationGuestLinks" -> pure TeamFeatureGuestLinks + Right "sndFactorPasswordChallenge" -> pure TeamFeatureSndFactorPasswordChallenge Right t -> fail $ "Invalid TeamFeatureName: " <> T.unpack t -- TODO: how do we make this consistent with 'KnownTeamFeatureNameSymbol'? add a test for @@ -226,6 +233,7 @@ instance ToByteString TeamFeatureName where builder TeamFeatureConferenceCalling = "conferenceCalling" builder TeamFeatureSelfDeletingMessages = "selfDeletingMessages" builder TeamFeatureGuestLinks = "conversationGuestLinks" + builder TeamFeatureSndFactorPasswordChallenge = "sndFactorPasswordChallenge" instance ToSchema TeamFeatureName where schema = @@ -320,6 +328,8 @@ type family TeamFeatureStatus (ps :: IncludeLockStatus) (a :: TeamFeatureName) : TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfigAndLockStatus TeamFeatureSelfDeletingMessagesConfig TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureGuestLinks = TeamFeatureStatusNoConfig TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks = TeamFeatureStatusNoConfigAndLockStatus + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSndFactorPasswordChallenge = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge = TeamFeatureStatusNoConfigAndLockStatus type family FeatureHasNoConfig (ps :: IncludeLockStatus) (a :: TeamFeatureName) :: Constraint where FeatureHasNoConfig 'WithLockStatus a = (TeamFeatureStatus 'WithLockStatus a ~ TeamFeatureStatusNoConfigAndLockStatus) @@ -338,6 +348,7 @@ modelForTeamFeature name@TeamFeatureClassifiedDomains = modelTeamFeatureStatusWi modelForTeamFeature TeamFeatureConferenceCalling = modelTeamFeatureStatusNoConfig modelForTeamFeature name@TeamFeatureSelfDeletingMessages = modelTeamFeatureStatusWithConfig name modelTeamFeatureSelfDeletingMessagesConfig modelForTeamFeature TeamFeatureGuestLinks = modelTeamFeatureStatusNoConfig +modelForTeamFeature TeamFeatureSndFactorPasswordChallenge = modelTeamFeatureStatusNoConfig ---------------------------------------------------------------------- -- TeamFeatureStatusNoConfig @@ -622,6 +633,12 @@ defaultGuestLinksStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnab defaultTeamFeatureValidateSAMLEmailsStatus :: TeamFeatureStatusNoConfig defaultTeamFeatureValidateSAMLEmailsStatus = TeamFeatureStatusNoConfig TeamFeatureEnabled +---------------------------------------------------------------------- +-- TeamFeatureSndFactorPasswordChallenge + +defaultTeamFeatureSndFactorPasswordChallengeStatus :: TeamFeatureStatusNoConfigAndLockStatus +defaultTeamFeatureSndFactorPasswordChallengeStatus = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureDisabled Unlocked + ---------------------------------------------------------------------- -- internal diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 35ef91c0317..66d82b2f610 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -598,6 +598,7 @@ executable galley-schema V57_GuestLinksLockStatus V58_ConversationAccessRoleV2 V59_FileSharingLockStatus + V60_TeamFeatureSndFactorPasswordChallenge Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 450b1342320..ae17ad977e3 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -62,6 +62,7 @@ import qualified V56_GuestLinksTeamFeatureStatus import qualified V57_GuestLinksLockStatus import qualified V58_ConversationAccessRoleV2 import qualified V59_FileSharingLockStatus +import qualified V60_TeamFeatureSndFactorPasswordChallenge main :: IO () main = do @@ -109,7 +110,8 @@ main = do V56_GuestLinksTeamFeatureStatus.migration, V57_GuestLinksLockStatus.migration, V58_ConversationAccessRoleV2.migration, - V59_FileSharingLockStatus.migration + V59_FileSharingLockStatus.migration, + V60_TeamFeatureSndFactorPasswordChallenge.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/schema/src/V60_TeamFeatureSndFactorPasswordChallenge.hs b/services/galley/schema/src/V60_TeamFeatureSndFactorPasswordChallenge.hs new file mode 100644 index 00000000000..f71ab44871f --- /dev/null +++ b/services/galley/schema/src/V60_TeamFeatureSndFactorPasswordChallenge.hs @@ -0,0 +1,34 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V60_TeamFeatureSndFactorPasswordChallenge + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 60 "Add feature config for team feature snd factor password challenge" $ do + schema' + [r| ALTER TABLE team_features ADD ( + snd_factor_password_challenge_status int, + snd_factor_password_challenge_lock_status int + ) + |] diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 3c1179eb18c..16909bcc4bf 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -117,6 +117,7 @@ type IFeatureAPI = :<|> IFeatureStatus 'TeamFeatureConferenceCalling :<|> IFeatureStatusWithLock 'TeamFeatureSelfDeletingMessages :<|> IFeatureStatusWithLock 'TeamFeatureGuestLinks + :<|> IFeatureStatusWithLock 'TeamFeatureSndFactorPasswordChallenge type InternalAPI = "i" @@ -211,6 +212,7 @@ featureAPI = :<|> featureStatus @'TeamFeatureConferenceCalling getConferenceCallingInternal setConferenceCallingInternal :<|> featureStatusWithLock getSelfDeletingMessagesInternal setSelfDeletingMessagesInternal :<|> featureStatusWithLock getGuestLinkInternal setGuestLinkInternal + :<|> featureStatusWithLock getSndFactorPasswordChallengeInternal setSndFactorPasswordChallengeInternal featureStatusGet :: forall (l :: IncludeLockStatus) f r. diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index db412c0198b..78374814986 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -200,6 +200,16 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> bot :< setGuestLinkInternal . DoAuth ) + :<|> Named @'("get", 'TeamFeatureSndFactorPasswordChallenge) + ( getFeatureStatus @'WithLockStatus @'TeamFeatureSndFactorPasswordChallenge + getSndFactorPasswordChallengeInternal + . DoAuth + ) + :<|> Named @'("put", 'TeamFeatureSndFactorPasswordChallenge) + ( setFeatureStatus @'TeamFeatureSndFactorPasswordChallenge + setSndFactorPasswordChallengeInternal + . DoAuth + ) :<|> Named @"get-all-feature-configs" getAllFeatureConfigs :<|> Named @'("get-config", 'TeamFeatureLegalHold) ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureLegalHold @@ -245,3 +255,7 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> bot :< ( getFeatureConfig @'WithLockStatus @'TeamFeatureGuestLinks getGuestLinkInternal ) + :<|> Named @'("get-config", 'TeamFeatureSndFactorPasswordChallenge) + ( getFeatureConfig @'WithLockStatus @'TeamFeatureSndFactorPasswordChallenge + getSndFactorPasswordChallengeInternal + ) diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 085b62b48c0..6d10186d14e 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -41,6 +41,8 @@ module Galley.API.Teams.Features setConferenceCallingInternal, getSelfDeletingMessagesInternal, setSelfDeletingMessagesInternal, + getSndFactorPasswordChallengeInternal, + setSndFactorPasswordChallengeInternal, getGuestLinkInternal, setGuestLinkInternal, setLockStatus, @@ -236,7 +238,8 @@ getAllFeatureConfigs zusr = do getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, - getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal + getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSndFactorPasswordChallenge getSndFactorPasswordChallengeInternal ] getAllFeaturesH :: @@ -285,7 +288,8 @@ getAllFeatures uid tid = do getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, - getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal + getStatus @'Public.WithLockStatus @'Public.TeamFeatureGuestLinks getGuestLinkInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureSndFactorPasswordChallenge getSndFactorPasswordChallengeInternal ] where getStatus :: @@ -710,6 +714,48 @@ setGuestLinkInternal tid status = do getDftLockStatus :: Sem r Public.LockStatusValue getDftLockStatus = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults . to Public.tfwoapsLockStatus) +getSndFactorPasswordChallengeInternal :: + forall r. + (Member (Input Opts) r, Member TeamFeatureStore r) => + GetFeatureInternalParam -> + Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSndFactorPasswordChallenge) +getSndFactorPasswordChallengeInternal = \case + Left _ -> getCfgDefault + Right tid -> do + cfgDefault <- getCfgDefault + (mbFeatureStatus, fromMaybe (Public.tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'Public.TeamFeatureSndFactorPasswordChallenge tid + pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus + where + getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureSndFactorPasswordChallenge) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSndFactorPasswordChallengeStatus . unDefaults) + +setSndFactorPasswordChallengeInternal :: + forall r. + ( Member GundeckAccess r, + Member TeamStore r, + Member TeamFeatureStore r, + Member P.TinyLog r, + Member (Error TeamFeatureError) r, + Member (Input Opts) r + ) => + TeamId -> + Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSndFactorPasswordChallenge -> + Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureSndFactorPasswordChallenge) +setSndFactorPasswordChallengeInternal tid status = do + getDftLockStatus >>= guardLockStatus @'Public.TeamFeatureSndFactorPasswordChallenge tid + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event + Event.Update + Public.TeamFeatureSndFactorPasswordChallenge + ( EdFeatureWithoutConfigAndLockStatusChanged + (Public.TeamFeatureStatusNoConfigAndLockStatus (Public.tfwoStatus status) Public.Unlocked) + ) + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureSndFactorPasswordChallenge tid status <* pushEvent + where + getDftLockStatus :: Sem r Public.LockStatusValue + getDftLockStatus = input <&> view (optSettings . setFeatureFlags . flagTeamFeatureSndFactorPasswordChallengeStatus . unDefaults . to Public.tfwoapsLockStatus) + -- TODO(fisx): move this function to a more suitable place / module. guardLockStatus :: forall (a :: Public.TeamFeatureName) r. diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index f0b39e870fd..b7ee15df559 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 59 +schemaVersion = 60 diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 99f100215a9..86daac19ff9 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -51,6 +51,8 @@ instance HasStatusCol 'TeamFeatureSelfDeletingMessages where statusCol = "self_d instance HasStatusCol 'TeamFeatureGuestLinks where statusCol = "guest_links_status" +instance HasStatusCol 'TeamFeatureSndFactorPasswordChallenge where statusCol = "snd_factor_password_challenge_status" + ---------------------------------------------------------------------- class HasLockStatusCol (a :: TeamFeatureName) where lockStatusCol :: String @@ -71,6 +73,9 @@ instance HasLockStatusCol 'TeamFeatureGuestLinks where instance HasLockStatusCol 'TeamFeatureFileSharing where lockStatusCol = "file_sharing_lock_status" +instance HasLockStatusCol 'TeamFeatureSndFactorPasswordChallenge where + lockStatusCol = "snd_factor_password_challenge_lock_status" + instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing instance MaybeHasLockStatusCol 'TeamFeatureSSO where maybeLockStatusCol = Nothing diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 2340a461014..700ecd965ed 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -72,7 +72,8 @@ tests s = test s "SelfDeletingMessages" testSelfDeletingMessages, test s "ConversationGuestLinks - public API" testGuestLinksPublic, test s "ConversationGuestLinks - internal API" testGuestLinksInternal, - test s "ConversationGuestLinks - lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureGuestLinks Public.TeamFeatureEnabled Public.Unlocked + test s "ConversationGuestLinks - lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureGuestLinks Public.TeamFeatureEnabled Public.Unlocked, + test s "SndFactorPasswordChallenge - lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureSndFactorPasswordChallenge Public.TeamFeatureDisabled Public.Unlocked ] testSSO :: TestM () @@ -678,7 +679,9 @@ testAllFeatures = do .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Public.Unlocked, - toS TeamFeatureValidateSAMLEmails .= Public.TeamFeatureStatusNoConfig TeamFeatureEnabled + toS TeamFeatureValidateSAMLEmails .= Public.TeamFeatureStatusNoConfig TeamFeatureEnabled, + toS TeamFeatureGuestLinks .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Public.Unlocked, + toS TeamFeatureSndFactorPasswordChallenge .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureDisabled Public.Unlocked ] toS :: TeamFeatureName -> Text toS = TE.decodeUtf8 . toByteString' From 8281461864f623d78d78ef82a27390a5a06de49b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 17 Feb 2022 15:31:46 +0100 Subject: [PATCH 55/58] [Polysemy] Introduce the Row Type Variable in Brig (#2140) * Introduce type variable r to AppT, ConnectionM and Handler * Use IO instead of constrained monad for running an action - This is to work around the issue of an otherwise imposed constraint of `Typeable effs` * Add a changelog --- changelog.d/5-internal/brig-polysemy-row | 1 + services/brig/src/Brig/API.hs | 2 +- services/brig/src/Brig/API/Client.hs | 52 ++--- services/brig/src/Brig/API/Connection.hs | 59 +++--- .../brig/src/Brig/API/Connection/Remote.hs | 16 +- services/brig/src/Brig/API/Connection/Util.hs | 4 +- services/brig/src/Brig/API/Federation.hs | 22 +-- services/brig/src/Brig/API/Handler.hs | 10 +- services/brig/src/Brig/API/Internal.hs | 112 +++++------ services/brig/src/Brig/API/Properties.hs | 6 +- services/brig/src/Brig/API/Public.hs | 178 +++++++++--------- services/brig/src/Brig/API/User.hs | 124 ++++++------ services/brig/src/Brig/API/Util.hs | 12 +- services/brig/src/Brig/AWS/SesNotification.hs | 12 +- services/brig/src/Brig/App.hs | 38 ++-- services/brig/src/Brig/Calling/API.hs | 10 +- services/brig/src/Brig/Data/Activation.hs | 10 +- services/brig/src/Brig/Data/Client.hs | 35 ++-- services/brig/src/Brig/Data/Connection.hs | 44 ++--- services/brig/src/Brig/Data/LoginCode.hs | 10 +- services/brig/src/Brig/Data/PasswordReset.hs | 8 +- services/brig/src/Brig/Data/Properties.hs | 12 +- services/brig/src/Brig/Data/User.hs | 72 +++---- services/brig/src/Brig/Data/UserKey.hs | 14 +- .../src/Brig/Data/UserPendingActivation.hs | 8 +- services/brig/src/Brig/Email.hs | 2 +- services/brig/src/Brig/Federation/Client.hs | 29 +-- services/brig/src/Brig/IO/Intra.hs | 102 +++++----- services/brig/src/Brig/IO/Journal.hs | 10 +- .../brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/Phone.hs | 22 +-- services/brig/src/Brig/Provider/API.hs | 170 ++++++++--------- services/brig/src/Brig/Provider/Email.hs | 8 +- services/brig/src/Brig/Provider/RPC.hs | 10 +- services/brig/src/Brig/Queue.hs | 4 +- services/brig/src/Brig/RPC.hs | 8 +- services/brig/src/Brig/Run.hs | 10 +- services/brig/src/Brig/Team/API.hs | 60 +++--- services/brig/src/Brig/Team/Email.hs | 6 +- services/brig/src/Brig/Team/Util.hs | 4 +- services/brig/src/Brig/User/API/Auth.hs | 52 ++--- services/brig/src/Brig/User/API/Handle.hs | 8 +- services/brig/src/Brig/User/API/Search.hs | 18 +- services/brig/src/Brig/User/Auth.hs | 44 ++--- services/brig/src/Brig/User/Auth/Cookie.hs | 22 +-- services/brig/src/Brig/User/EJPD.hs | 6 +- services/brig/src/Brig/User/Email.hs | 12 +- services/brig/src/Brig/User/Handle.hs | 10 +- services/brig/src/Brig/User/Phone.hs | 12 +- 49 files changed, 753 insertions(+), 749 deletions(-) create mode 100644 changelog.d/5-internal/brig-polysemy-row diff --git a/changelog.d/5-internal/brig-polysemy-row b/changelog.d/5-internal/brig-polysemy-row new file mode 100644 index 00000000000..cdad27dcaaf --- /dev/null +++ b/changelog.d/5-internal/brig-polysemy-row @@ -0,0 +1 @@ +Introduce the row type variable in Brig monads diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 9856f8520e5..3a668844344 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -26,7 +26,7 @@ import qualified Brig.API.Public as Public import qualified Data.Swagger.Build.Api as Doc import Network.Wai.Routing (Routes) -sitemap :: Routes Doc.ApiBuilder Handler () +sitemap :: Routes Doc.ApiBuilder (Handler r) () sitemap = do Public.sitemap Public.apiDocs diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index a265fbc462e..27324a294b9 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -84,18 +84,18 @@ import Wire.API.Team.LegalHold (LegalholdProtectee (..)) import Wire.API.User.Client import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) -lookupLocalClient :: UserId -> ClientId -> AppIO (Maybe Client) +lookupLocalClient :: UserId -> ClientId -> (AppIO r) (Maybe Client) lookupLocalClient = Data.lookupClient -lookupLocalClients :: UserId -> AppIO [Client] +lookupLocalClients :: UserId -> (AppIO r) [Client] lookupLocalClients = Data.lookupClients -lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe PubClient) +lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe PubClient) lookupPubClient qid cid = do clients <- lookupPubClients qid pure $ find ((== cid) . pubClientId) clients -lookupPubClients :: Qualified UserId -> ExceptT ClientError AppIO [PubClient] +lookupPubClients :: Qualified UserId -> ExceptT ClientError (AppIO r) [PubClient] lookupPubClients qid@(Qualified uid domain) = do getForUser <$> lookupPubClientsBulk [qid] where @@ -104,7 +104,7 @@ lookupPubClients qid@(Qualified uid domain) = do um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap) Set.toList <$> Map.lookup uid um -lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError AppIO (QualifiedUserMap (Set PubClient)) +lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError (AppIO r) (QualifiedUserMap (Set PubClient)) lookupPubClientsBulk qualifiedUids = do loc <- qualifyLocal () let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids @@ -116,12 +116,12 @@ lookupPubClientsBulk qualifiedUids = do localUserClientMap <- Map.singleton (tDomain loc) <$> lookupLocalPubClientsBulk localUsers pure $ QualifiedUserMap (Map.union localUserClientMap remoteUserClientMap) -lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError AppIO (UserMap (Set PubClient)) +lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppIO r) (UserMap (Set PubClient)) lookupLocalPubClientsBulk = Data.lookupPubClientsBulk -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError AppIO Client +addClient :: UserId -> Maybe ConnId -> Maybe IP -> NewClient -> ExceptT ClientError (AppIO r) Client addClient u con ip new = do acc <- lift (Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) return loc <- maybe (return Nothing) locationOf ip @@ -149,7 +149,7 @@ addClient u con ip new = do where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) -updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError AppIO () +updateClient :: UserId -> ClientId -> UpdateClient -> ExceptT ClientError (AppIO r) () updateClient u c r = do client <- lift (Data.lookupClient u c) >>= maybe (throwE ClientNotFound) pure for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just @@ -163,7 +163,7 @@ updateClient u c r = do -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. -rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError AppIO () +rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError (AppIO r) () rmClient u con clt pw = maybe (throwE ClientNotFound) fn =<< lift (Data.lookupClient u clt) where @@ -177,14 +177,14 @@ rmClient u con clt pw = _ -> Data.reauthenticate u pw !>> ClientDataError . ClientReAuthError lift $ execDelete u (Just con) client -claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimPrekey :: LegalholdProtectee -> UserId -> Domain -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimPrekey protectee u d c = do isLocalDomain <- (d ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekey protectee u c else claimRemotePrekey (Qualified u d) c -claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimLocalPrekey :: LegalholdProtectee -> UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimLocalPrekey protectee user client = do guardLegalhold protectee (mkUserClients [(user, [client])]) lift $ do @@ -192,27 +192,27 @@ claimLocalPrekey protectee user client = do when (isNothing prekey) (noPrekeys user client) pure prekey -claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError AppIO (Maybe ClientPrekey) +claimRemotePrekey :: Qualified UserId -> ClientId -> ExceptT ClientError (AppIO r) (Maybe ClientPrekey) claimRemotePrekey quser client = fmapLT ClientFederationError $ Federation.claimPrekey quser client -claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError AppIO PrekeyBundle +claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimPrekeyBundle protectee domain uid = do isLocalDomain <- (domain ==) <$> viewFederationDomain if isLocalDomain then claimLocalPrekeyBundle protectee uid else claimRemotePrekeyBundle (Qualified uid domain) -claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError AppIO PrekeyBundle +claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimLocalPrekeyBundle protectee u = do clients <- map clientId <$> Data.lookupClients u guardLegalhold protectee (mkUserClients [(u, clients)]) PrekeyBundle u . catMaybes <$> lift (mapM (Data.claimPrekey u) clients) -claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError AppIO PrekeyBundle +claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppIO r) PrekeyBundle claimRemotePrekeyBundle quser = do Federation.claimPrekeyBundle quser !>> ClientFederationError -claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError AppIO QualifiedUserClientPrekeyMap +claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppIO r) QualifiedUserClientPrekeyMap claimMultiPrekeyBundles protectee quc = do loc <- qualifyLocal () let (locals, remotes) = @@ -232,17 +232,17 @@ claimMultiPrekeyBundles protectee quc = do where claimRemote :: Remote UserClients -> - ExceptT FederationError AppIO (Qualified UserClientPrekeyMap) + ExceptT FederationError (AppIO r) (Qualified UserClientPrekeyMap) claimRemote ruc = qUntagged . qualifyAs ruc <$> Federation.claimMultiPrekeyBundle (tDomain ruc) (tUnqualified ruc) - claimLocal :: Local UserClients -> ExceptT ClientError AppIO (Qualified UserClientPrekeyMap) + claimLocal :: Local UserClients -> ExceptT ClientError (AppIO r) (Qualified UserClientPrekeyMap) claimLocal luc = qUntagged . qualifyAs luc <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc) -claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO UserClientPrekeyMap +claimLocalMultiPrekeyBundles :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) UserClientPrekeyMap claimLocalMultiPrekeyBundles protectee userClients = do guardLegalhold protectee userClients lift @@ -253,13 +253,13 @@ claimLocalMultiPrekeyBundles protectee userClients = do . Message.userClients $ userClients where - getChunk :: Map UserId (Set ClientId) -> AppIO (Map UserId (Map ClientId (Maybe Prekey))) + getChunk :: Map UserId (Set ClientId) -> (AppIO r) (Map UserId (Map ClientId (Maybe Prekey))) getChunk = runConcurrently . Map.traverseWithKey (\u -> Concurrently . getUserKeys u) - getUserKeys :: UserId -> Set ClientId -> AppIO (Map ClientId (Maybe Prekey)) + getUserKeys :: UserId -> Set ClientId -> (AppIO r) (Map ClientId (Maybe Prekey)) getUserKeys u = sequenceA . Map.fromSet (getClientKeys u) - getClientKeys :: UserId -> ClientId -> AppIO (Maybe Prekey) + getClientKeys :: UserId -> ClientId -> (AppIO r) (Maybe Prekey) getClientKeys u c = do key <- fmap prekeyData <$> Data.claimPrekey u c when (isNothing key) $ noPrekeys u c @@ -268,7 +268,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- Utilities -- | Perform an orderly deletion of an existing client. -execDelete :: UserId -> Maybe ConnId -> Client -> AppIO () +execDelete :: UserId -> Maybe ConnId -> Client -> (AppIO r) () execDelete u con c = do Intra.rmClient u (clientId c) for_ (clientCookie c) $ \l -> Auth.revokeCookies u [] [l] @@ -280,7 +280,7 @@ execDelete u con c = do -- not exist, since there must be no client without prekeys, -- thus repairing any inconsistencies related to distributed -- (and possibly duplicated) client data. -noPrekeys :: UserId -> ClientId -> AppIO () +noPrekeys :: UserId -> ClientId -> (AppIO r) () noPrekeys u c = do Log.info $ field "user" (toByteString u) @@ -301,7 +301,7 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> AppIO () +legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppIO r) () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = Intra.onUserEvent targetUser Nothing lhClientEvent where @@ -312,7 +312,7 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: UserId -> AppIO () +removeLegalHoldClient :: UserId -> (AppIO r) () removeLegalHoldClient uid = do clients <- Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 9495087c814..2cf4f49372a 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -59,12 +59,12 @@ import Wire.API.Connection (RelationWithHistory (..)) import Wire.API.ErrorDescription import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -ensureIsActivated :: Local UserId -> MaybeT AppIO () +ensureIsActivated :: Local UserId -> MaybeT (AppIO r) () ensureIsActivated lusr = do active <- lift $ Data.isActivated (tUnqualified lusr) guard active -ensureNotSameTeam :: Local UserId -> Local UserId -> ConnectionM () +ensureNotSameTeam :: Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do selfTeam <- lift $ Intra.getTeamId (tUnqualified self) targetTeam <- lift $ Intra.getTeamId (tUnqualified target) @@ -75,7 +75,7 @@ createConnection :: Local UserId -> ConnId -> Qualified UserId -> - ConnectionM (ResponseForExistedCreated UserConnection) + (ConnectionM r) (ResponseForExistedCreated UserConnection) createConnection self con target = do -- basic checks: no need to distinguish between local and remote at this point when (qUntagged self == target) $ @@ -94,7 +94,7 @@ createConnectionToLocalUser :: Local UserId -> ConnId -> Local UserId -> - ConnectionM (ResponseForExistedCreated UserConnection) + (ConnectionM r) (ResponseForExistedCreated UserConnection) createConnectionToLocalUser self conn target = do noteT (InvalidUser (qUntagged target)) $ ensureIsActivated target @@ -109,7 +109,7 @@ createConnectionToLocalUser self conn target = do checkLimit self Created <$> insert Nothing Nothing where - insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError AppIO UserConnection + insert :: Maybe UserConnection -> Maybe UserConnection -> ExceptT ConnectionError (AppIO r) UserConnection insert s2o o2s = lift $ do Log.info $ logConnection (tUnqualified self) (qUntagged target) @@ -124,7 +124,7 @@ createConnectionToLocalUser self conn target = do mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return s2o' - update :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) update s2o o2s = case (ucStatus s2o, ucStatus o2s) of (MissingLegalholdConsent, _) -> throwE $ InvalidTransition (tUnqualified self) (_, MissingLegalholdConsent) -> throwE $ InvalidTransition (tUnqualified self) @@ -139,7 +139,7 @@ createConnectionToLocalUser self conn target = do (_, Pending) -> resend s2o o2s (_, Cancelled) -> resend s2o o2s - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) accept s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -161,7 +161,7 @@ createConnectionToLocalUser self conn target = do lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] return $ Existed s2o' - resend :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) resend s2o o2s = do when (ucStatus s2o `notElem` [Sent, Accepted]) $ checkLimit self @@ -171,17 +171,17 @@ createConnectionToLocalUser self conn target = do s2o' <- insert (Just s2o) (Just o2s) return $ Existed s2o' - change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError AppIO (ResponseForExistedCreated UserConnection) + change :: UserConnection -> RelationWithHistory -> ExceptT ConnectionError (AppIO r) (ResponseForExistedCreated UserConnection) change c s = Existed <$> lift (Data.updateConnection c s) -- | Throw error if one user has a LH device and the other status `no_consent` or vice versa. -- -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. -checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError AppIO () +checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError (AppIO r) () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = - -- Does not fit into 'ExceptT', so throw in 'AppIO'. Anyway at the time of writing + -- Does not fit into 'ExceptT', so throw in '(AppIO r)'. Anyway at the time of writing -- this, users are guaranteed to exist when called from 'createConnectionToLocalUser'. maybe (throwM (errorDescriptionTypeToWai @UserNotFound)) return @@ -205,7 +205,7 @@ updateConnection :: Qualified UserId -> Relation -> Maybe ConnId -> - ConnectionM (Maybe UserConnection) + (ConnectionM r) (Maybe UserConnection) updateConnection self other newStatus conn = let doUpdate = foldQualified @@ -228,7 +228,7 @@ updateConnectionToLocalUser :: Relation -> -- | Acting device connection ID Maybe ConnId -> - ConnectionM (Maybe UserConnection) + (ConnectionM r) (Maybe UserConnection) updateConnectionToLocalUser self other newStatus conn = do s2o <- localConnection self other o2s <- localConnection other self @@ -279,7 +279,7 @@ updateConnectionToLocalUser self other newStatus conn = do in Intra.onConnectionEvent (tUnqualified self) conn e2s return s2oUserConn where - accept :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + accept :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) accept s2o o2s = do checkLimit self Log.info $ @@ -301,7 +301,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o AcceptedWithHistory - block :: UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + block :: UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) block s2o = lift $ do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -309,7 +309,7 @@ updateConnectionToLocalUser self other newStatus conn = do traverse_ (Intra.blockConv self conn) (ucConvId s2o) Just <$> Data.updateConnection s2o BlockedWithHistory - unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) + unblock :: UserConnection -> UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) unblock s2o o2s new = do -- FUTUREWORK: new is always in [Sent, Accepted]. Refactor to total function. when (new `elem` [Sent, Accepted]) $ @@ -330,7 +330,7 @@ updateConnectionToLocalUser self other newStatus conn = do Intra.onConnectionEvent (tUnqualified self) conn e2o lift $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO (Maybe UserConnection) + cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) cancel s2o o2s = do Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -342,7 +342,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled - change :: UserConnection -> Relation -> ExceptT ConnectionError AppIO (Maybe UserConnection) + change :: UserConnection -> Relation -> ExceptT ConnectionError (AppIO r) (Maybe UserConnection) change c s = do -- FUTUREWORK: refactor to total function. Gets only called with either Ignored, Accepted, Cancelled lift $ Just <$> Data.updateConnection c (mkRelationWithHistory (error "impossible") s) @@ -350,7 +350,7 @@ updateConnectionToLocalUser self other newStatus conn = do localConnection :: Local UserId -> Local UserId -> - ExceptT ConnectionError AppIO UserConnection + ExceptT ConnectionError (AppIO r) UserConnection localConnection la lb = do lift (Data.lookupConnection la (qUntagged lb)) >>= tryJust (NotConnected (tUnqualified la) (qUntagged lb)) @@ -374,8 +374,9 @@ mkRelationWithHistory oldRel = \case MissingLegalholdConsent -> error "impossible old relation" updateConnectionInternal :: + forall r. UpdateConnectionsInternal -> - ExceptT ConnectionError AppIO () + ExceptT ConnectionError (AppIO r) () updateConnectionInternal = \case BlockForMissingLHConsent uid others -> do self <- qualifyLocal uid @@ -391,7 +392,7 @@ updateConnectionInternal = \case other where -- inspired by @block@ in 'updateConnection'. - blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError AppIO () + blockForMissingLegalholdConsent :: Local UserId -> [UserId] -> ExceptT ConnectionError (AppIO r) () blockForMissingLegalholdConsent self others = do for_ others $ \(qualifyAs self -> other) -> do Log.info $ @@ -407,7 +408,7 @@ updateConnectionInternal = \case let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing Intra.onConnectionEvent (tUnqualified self) Nothing ev - removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError AppIO () + removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppIO r) () removeLHBlocksInvolving self = iterateConnections self (toRange (Proxy @500)) $ \conns -> do for_ conns $ \s2o -> @@ -422,10 +423,10 @@ updateConnectionInternal = \case unblockDirected s2o o2s unblockDirected o2s s2o where - iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError AppIO ()) -> ExceptT ConnectionError AppIO () + iterateConnections :: Local UserId -> Range 1 500 Int32 -> ([UserConnection] -> ExceptT ConnectionError (AppIO r) ()) -> ExceptT ConnectionError (AppIO r) () iterateConnections user pageSize handleConns = go Nothing where - go :: Maybe UserId -> ExceptT ConnectionError (AppT IO) () + go :: Maybe UserId -> ExceptT ConnectionError (AppT r IO) () go mbStart = do page <- lift $ Data.lookupLocalConnections user mbStart pageSize handleConns (resultList page) @@ -436,7 +437,7 @@ updateConnectionInternal = \case else pure () [] -> pure () - unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError AppIO () + unblockDirected :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppIO r) () unblockDirected uconn uconnRev = do lfrom <- qualifyLocal (ucFrom uconnRev) void . lift . for (ucConvId uconn) $ Intra.unblockConv lfrom Nothing @@ -451,7 +452,7 @@ updateConnectionInternal = \case } lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent - relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError AppIO RelationWithHistory + relationWithHistory :: Local UserId -> Qualified UserId -> ExceptT ConnectionError (AppIO r) RelationWithHistory relationWithHistory self target = lift (Data.lookupRelationWithHistory self target) >>= tryJust (NotConnected (tUnqualified self) target) @@ -473,18 +474,18 @@ updateConnectionInternal = \case SentWithHistory -> SentWithHistory CancelledWithHistory -> CancelledWithHistory -createLocalConnectionUnchecked :: Local UserId -> Local UserId -> AppIO () +createLocalConnectionUnchecked :: Local UserId -> Local UserId -> (AppIO r) () createLocalConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv void $ Data.insertConnection other (qUntagged self) AcceptedWithHistory qcnv -createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> AppIO () +createRemoteConnectionUnchecked :: Local UserId -> Remote UserId -> (AppIO r) () createRemoteConnectionUnchecked self other = do qcnv <- liftIO $ qUntagged . qualifyAs self <$> (Id <$> UUID.nextRandom) void $ Data.insertConnection self (qUntagged other) AcceptedWithHistory qcnv -lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO UserConnectionList +lookupConnections :: UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) UserConnectionList lookupConnections from start size = do lusr <- qualifyLocal from rs <- Data.lookupLocalConnections lusr start size diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 1e8190f203e..a36cc48ab33 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -108,7 +108,7 @@ updateOne2OneConv :: Maybe (Qualified ConvId) -> Relation -> Actor -> - AppIO (Qualified ConvId) + (AppIO r) (Qualified ConvId) updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do let request = UpsertOne2OneConversationRequest @@ -148,7 +148,7 @@ transitionTo :: Maybe UserConnection -> Maybe Relation -> Actor -> - ConnectionM (ResponseForExistedCreated UserConnection, Bool) + (ConnectionM r) (ResponseForExistedCreated UserConnection, Bool) transitionTo self _ _ Nothing Nothing _ = -- This can only happen if someone tries to ignore as a first action on a -- connection. This shouldn't be possible. @@ -181,7 +181,7 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. -pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> AppIO () +pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppIO r) () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing Intra.onConnectionEvent (tUnqualified self) mzcon event @@ -192,7 +192,7 @@ performLocalAction :: Remote UserId -> Maybe UserConnection -> LocalConnectionAction -> - ConnectionM (ResponseForExistedCreated UserConnection, Bool) + (ConnectionM r) (ResponseForExistedCreated UserConnection, Bool) performLocalAction self mzcon other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection checkLimitForLocalAction self rel0 action @@ -238,7 +238,7 @@ performRemoteAction :: Remote UserId -> Maybe UserConnection -> RemoteConnectionAction -> - AppIO (Maybe RemoteConnectionAction) + (AppIO r) (Maybe RemoteConnectionAction) performRemoteAction self other mconnection action = do let rel0 = maybe Cancelled ucStatus mconnection let rel1 = transition (RCA action) rel0 @@ -254,7 +254,7 @@ createConnectionToRemoteUser :: Local UserId -> ConnId -> Remote UserId -> - ConnectionM (ResponseForExistedCreated UserConnection) + (ConnectionM r) (ResponseForExistedCreated UserConnection) createConnectionToRemoteUser self zcon other = do mconnection <- lift $ Data.lookupConnection self (qUntagged other) fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect @@ -264,7 +264,7 @@ updateConnectionToRemoteUser :: Remote UserId -> Relation -> Maybe ConnId -> - ConnectionM (Maybe UserConnection) + (ConnectionM r) (Maybe UserConnection) updateConnectionToRemoteUser self other rel1 zcon = do mconnection <- lift $ Data.lookupConnection self (qUntagged other) action <- @@ -281,7 +281,7 @@ updateConnectionToRemoteUser self other rel1 zcon = do actionForTransition Pending = Nothing actionForTransition MissingLegalholdConsent = Nothing -checkLimitForLocalAction :: Local UserId -> Relation -> LocalConnectionAction -> ConnectionM () +checkLimitForLocalAction :: Local UserId -> Relation -> LocalConnectionAction -> (ConnectionM r) () checkLimitForLocalAction u oldRel action = when (oldRel `notElem` [Accepted, Sent] && (action == LocalConnect)) $ checkLimit u diff --git a/services/brig/src/Brig/API/Connection/Util.hs b/services/brig/src/Brig/API/Connection/Util.hs index b4730b0eaaa..49051bbd56b 100644 --- a/services/brig/src/Brig/API/Connection/Util.hs +++ b/services/brig/src/Brig/API/Connection/Util.hs @@ -33,11 +33,11 @@ import Data.Qualified (Local, tUnqualified) import Imports import Wire.API.Connection (Relation (..)) -type ConnectionM = ExceptT ConnectionError AppIO +type ConnectionM r = ExceptT ConnectionError (AppIO r) -- Helpers -checkLimit :: Local UserId -> ExceptT ConnectionError AppIO () +checkLimit :: Local UserId -> ExceptT ConnectionError (AppIO r) () checkLimit u = noteT (TooManyConnections (tUnqualified u)) $ do n <- lift $ Data.countConnections u [Accepted, Sent] l <- setUserMaxConnections <$> view settings diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index f56cd0645b9..d18f6e37ba8 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -59,7 +59,7 @@ import Wire.API.UserMap (UserMap) type FederationAPI = "federation" :> BrigApi -federationSitemap :: ServerT FederationAPI Handler +federationSitemap :: ServerT FederationAPI (Handler r) federationSitemap = Named @"get-user-by-handle" getUserByHandle :<|> Named @"get-users-by-ids" getUsersByIds @@ -71,7 +71,7 @@ federationSitemap = :<|> Named @"send-connection-action" sendConnectionAction :<|> Named @"on-user-deleted-connections" onUserDeleted -sendConnectionAction :: Domain -> NewConnectionRequest -> Handler NewConnectionResponse +sendConnectionAction :: Domain -> NewConnectionRequest -> (Handler r) NewConnectionResponse sendConnectionAction originDomain NewConnectionRequest {..} = do active <- lift $ Data.isActivated ncrTo if active @@ -83,7 +83,7 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do pure $ NewConnectionResponseOk maction else pure NewConnectionResponseUserNotActivated -getUserByHandle :: Domain -> Handle -> Handler (Maybe UserProfile) +getUserByHandle :: Domain -> Handle -> (Handler r) (Maybe UserProfile) getUserByHandle _ handle = lift $ do maybeOwnerId <- API.lookupHandle handle case maybeOwnerId of @@ -92,25 +92,25 @@ getUserByHandle _ handle = lift $ do Just ownerId -> listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] -getUsersByIds :: Domain -> [UserId] -> Handler [UserProfile] +getUsersByIds :: Domain -> [UserId] -> (Handler r) [UserProfile] getUsersByIds _ uids = lift (API.lookupLocalProfiles Nothing uids) -claimPrekey :: Domain -> (UserId, ClientId) -> Handler (Maybe ClientPrekey) +claimPrekey :: Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) claimPrekey _ (user, client) = do API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client !>> clientError -claimPrekeyBundle :: Domain -> UserId -> Handler PrekeyBundle +claimPrekeyBundle :: Domain -> UserId -> (Handler r) PrekeyBundle claimPrekeyBundle _ user = API.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user !>> clientError -claimMultiPrekeyBundle :: Domain -> UserClients -> Handler UserClientPrekeyMap +claimMultiPrekeyBundle :: Domain -> UserClients -> (Handler r) UserClientPrekeyMap claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError -- | Searching for federated users on a remote backend should -- only search by exact handle search, not in elasticsearch. -- (This decision may change in the future) -searchUsers :: Domain -> SearchRequest -> Handler [Contact] +searchUsers :: Domain -> SearchRequest -> (Handler r) [Contact] searchUsers _ (SearchRequest searchTerm) = do let maxResults = 15 @@ -126,7 +126,7 @@ searchUsers _ (SearchRequest searchTerm) = do pure $ maybeToList maybeExactHandleMatch <> searchResults esResult where - exactHandleSearch :: Handler (Maybe Contact) + exactHandleSearch :: (Handler r) (Maybe Contact) exactHandleSearch = do let maybeHandle = parseHandle searchTerm maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle @@ -134,10 +134,10 @@ searchUsers _ (SearchRequest searchTerm) = do Nothing -> pure Nothing Just foundUser -> lift $ fmap listToMaybe $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] -getUserClients :: Domain -> GetUserClients -> Handler (UserMap (Set PubClient)) +getUserClients :: Domain -> GetUserClients -> (Handler r) (UserMap (Set PubClient)) getUserClients _ (GetUserClients uids) = API.lookupLocalPubClientsBulk uids !>> clientError -onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> Handler EmptyResponse +onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> (Handler r) EmptyResponse onUserDeleted origDomain udcn = lift $ do let deletedUser = toRemoteUnsafe origDomain (udcnUser udcn) connections = udcnConnections udcn diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index b88d1efdf80..967e2afefb3 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -64,15 +64,15 @@ import System.Logger.Class (Logger) ------------------------------------------------------------------------------- -- HTTP Handler Monad -type Handler = ExceptT Error AppIO +type Handler r = ExceptT Error (AppIO r) -runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived +runHandler :: Env -> Request -> (Handler r) ResponseReceived -> Continue IO -> IO ResponseReceived runHandler e r h k = do let e' = set requestId (maybe def RequestId (lookupRequestId r)) e a <- runAppT e' (runExceptT h) `catches` brigErrorHandlers either (onError (view applog e') r k) return a -toServantHandler :: Env -> Handler a -> Servant.Handler a +toServantHandler :: Env -> (Handler r) a -> Servant.Handler a toServantHandler env action = do a <- liftIO $ runAppT env (runExceptT action) `catches` brigErrorHandlers case a of @@ -135,11 +135,11 @@ type JSON = Media "application" "json" -- TODO: move to libs/wai-utilities? there is a parseJson' in "Network.Wai.Utilities.Request", -- but adjusting its signature to this here would require to move more code out of brig (at least -- badRequest and probably all the other errors). -parseJsonBody :: FromJSON a => JsonRequest a -> Handler a +parseJsonBody :: FromJSON a => JsonRequest a -> (Handler r) a parseJsonBody req = parseBody req !>> StdError . badRequest -- | If a whitelist is configured, consult it, otherwise a no-op. {#RefActivationWhitelist} -checkWhitelist :: Either Email Phone -> Handler () +checkWhitelist :: Either Email Phone -> (Handler r) () checkWhitelist key = do eb <- setWhitelist <$> view settings case eb of diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 355e5ca1b9d..7e21804bf7a 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -81,7 +81,7 @@ import Wire.API.User.RichInfo --------------------------------------------------------------------------- -- Sitemap (servant) -servantSitemap :: ServerT BrigIRoutes.API Handler +servantSitemap :: ServerT BrigIRoutes.API (Handler r) servantSitemap = Brig.User.EJPD.ejpdRequest :<|> getAccountFeatureConfig @@ -91,16 +91,16 @@ servantSitemap = :<|> getConnectionsStatus -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. -getAccountFeatureConfig :: UserId -> Handler ApiFt.TeamFeatureStatusNoConfig +getAccountFeatureConfig :: UserId -> (Handler r) ApiFt.TeamFeatureStatusNoConfig getAccountFeatureConfig uid = lift (Data.lookupFeatureConferenceCalling uid) >>= maybe (view (settings . getAfcConferenceCallingDefNull)) pure -putAccountFeatureConfig :: UserId -> ApiFt.TeamFeatureStatusNoConfig -> Handler NoContent +putAccountFeatureConfig :: UserId -> ApiFt.TeamFeatureStatusNoConfig -> (Handler r) NoContent putAccountFeatureConfig uid status = lift $ Data.updateFeatureConferenceCalling uid (Just status) $> NoContent -deleteAccountFeatureConfig :: UserId -> Handler NoContent +deleteAccountFeatureConfig :: UserId -> (Handler r) NoContent deleteAccountFeatureConfig uid = lift $ Data.updateFeatureConferenceCalling uid Nothing $> NoContent @@ -110,7 +110,7 @@ swaggerDocsAPI = swaggerSchemaUIServer BrigIRoutes.swaggerDoc --------------------------------------------------------------------------- -- Sitemap (wai-route) -sitemap :: Routes a Handler () +sitemap :: Routes a (Handler r) () sitemap = do get "/i/status" (continue $ const $ return empty) true head "/i/status" (continue $ const $ return empty) true @@ -279,44 +279,44 @@ sitemap = do -- Handlers -- | Add a client without authentication checks -addClientInternalH :: UserId ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> Handler Response +addClientInternalH :: UserId ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> (Handler r) Response addClientInternalH (usr ::: req ::: connId ::: _) = do new <- parseJsonBody req setStatus status201 . json <$> addClientInternal usr new connId -addClientInternal :: UserId -> NewClient -> Maybe ConnId -> Handler Client +addClientInternal :: UserId -> NewClient -> Maybe ConnId -> (Handler r) Client addClientInternal usr new connId = do API.addClient usr connId Nothing new !>> clientError -legalHoldClientRequestedH :: UserId ::: JsonRequest LegalHoldClientRequest ::: JSON -> Handler Response +legalHoldClientRequestedH :: UserId ::: JsonRequest LegalHoldClientRequest ::: JSON -> (Handler r) Response legalHoldClientRequestedH (targetUser ::: req ::: _) = do clientRequest <- parseJsonBody req lift $ API.legalHoldClientRequested targetUser clientRequest return $ setStatus status200 empty -removeLegalHoldClientH :: UserId ::: JSON -> Handler Response +removeLegalHoldClientH :: UserId ::: JSON -> (Handler r) Response removeLegalHoldClientH (uid ::: _) = do lift $ API.removeLegalHoldClient uid return $ setStatus status200 empty -internalListClientsH :: JSON ::: JsonRequest UserSet -> Handler Response +internalListClientsH :: JSON ::: JsonRequest UserSet -> (Handler r) Response internalListClientsH (_ ::: req) = do json <$> (lift . internalListClients =<< parseJsonBody req) -internalListClients :: UserSet -> AppIO UserClients +internalListClients :: UserSet -> (AppIO r) UserClients internalListClients (UserSet usrs) = do UserClients . Map.fromList <$> API.lookupUsersClientIds (Set.toList usrs) -internalListFullClientsH :: JSON ::: JsonRequest UserSet -> Handler Response +internalListFullClientsH :: JSON ::: JsonRequest UserSet -> (Handler r) Response internalListFullClientsH (_ ::: req) = json <$> (lift . internalListFullClients =<< parseJsonBody req) -internalListFullClients :: UserSet -> AppIO UserClientsFull +internalListFullClients :: UserSet -> (AppIO r) UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> Data.lookupClientsBulk (Set.toList usrs) -createUserNoVerifyH :: JSON ::: JsonRequest NewUser -> Handler Response +createUserNoVerifyH :: JSON ::: JsonRequest NewUser -> (Handler r) Response createUserNoVerifyH (_ ::: req) = do CreateUserNoVerifyResponse uid prof <- createUserNoVerify =<< parseJsonBody req return . setStatus status201 @@ -325,7 +325,7 @@ createUserNoVerifyH (_ ::: req) = do data CreateUserNoVerifyResponse = CreateUserNoVerifyResponse UserId SelfProfile -createUserNoVerify :: NewUser -> Handler CreateUserNoVerifyResponse +createUserNoVerify :: NewUser -> (Handler r) CreateUserNoVerifyResponse createUserNoVerify uData = do result <- API.createUser uData !>> newUserError let acc = createdAccount result @@ -339,18 +339,18 @@ createUserNoVerify uData = do in API.activate key code (Just uid) !>> actError return $ CreateUserNoVerifyResponse uid (SelfProfile usr) -deleteUserNoVerifyH :: UserId -> Handler Response +deleteUserNoVerifyH :: UserId -> (Handler r) Response deleteUserNoVerifyH uid = do setStatus status202 empty <$ deleteUserNoVerify uid -deleteUserNoVerify :: UserId -> Handler () +deleteUserNoVerify :: UserId -> (Handler r) () deleteUserNoVerify uid = do void $ lift (API.lookupAccount uid) >>= ifNothing (errorDescriptionTypeToWai @UserNotFound) lift $ API.deleteUserNoVerify uid -changeSelfEmailMaybeSendH :: UserId ::: Bool ::: JsonRequest EmailUpdate -> Handler Response +changeSelfEmailMaybeSendH :: UserId ::: Bool ::: JsonRequest EmailUpdate -> (Handler r) Response changeSelfEmailMaybeSendH (u ::: validate ::: req) = do email <- euEmail <$> parseJsonBody req changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email API.AllowSCIMUpdates >>= \case @@ -359,7 +359,7 @@ changeSelfEmailMaybeSendH (u ::: validate ::: req) = do data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: UserId -> MaybeSendEmail -> Email -> API.AllowSCIMUpdates -> Handler ChangeEmailResponse +changeSelfEmailMaybeSend :: UserId -> MaybeSendEmail -> Email -> API.AllowSCIMUpdates -> (Handler r) ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -367,11 +367,11 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent ChangeEmailNeedsActivation _ -> pure ChangeEmailResponseNeedsActivation -listActivatedAccountsH :: JSON ::: Either (List UserId) (List Handle) ::: Bool -> Handler Response +listActivatedAccountsH :: JSON ::: Either (List UserId) (List Handle) ::: Bool -> (Handler r) Response listActivatedAccountsH (_ ::: qry ::: includePendingInvitations) = do json <$> lift (listActivatedAccounts qry includePendingInvitations) -listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> AppIO [UserAccount] +listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> (AppIO r) [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of @@ -380,10 +380,10 @@ listActivatedAccounts elh includePendingInvitations = do us <- mapM (API.lookupHandle) (fromList hs) byIds (catMaybes us) where - byIds :: [UserId] -> AppIO [UserAccount] + byIds :: [UserId] -> (AppIO r) [UserAccount] byIds uids = API.lookupAccounts uids >>= filterM accountValid - accountValid :: UserAccount -> AppIO Bool + accountValid :: UserAccount -> (AppIO r) Bool accountValid account = case userIdentity . accountUser $ account of Nothing -> pure False Just ident -> @@ -402,17 +402,17 @@ listActivatedAccounts elh includePendingInvitations = do (Deleted, _, _) -> pure True (Ephemeral, _, _) -> pure True -listAccountsByIdentityH :: JSON ::: Either Email Phone ::: Bool -> Handler Response +listAccountsByIdentityH :: JSON ::: Either Email Phone ::: Bool -> (Handler r) Response listAccountsByIdentityH (_ ::: emailOrPhone ::: includePendingInvitations) = lift $ json <$> API.lookupAccountsByIdentity emailOrPhone includePendingInvitations -getActivationCodeH :: JSON ::: Either Email Phone -> Handler Response +getActivationCodeH :: JSON ::: Either Email Phone -> (Handler r) Response getActivationCodeH (_ ::: emailOrPhone) = do json <$> getActivationCode emailOrPhone -getActivationCode :: Either Email Phone -> Handler GetActivationCodeResp +getActivationCode :: Either Email Phone -> (Handler r) GetActivationCodeResp getActivationCode emailOrPhone = do apair <- lift $ API.lookupActivationCode emailOrPhone maybe (throwStd activationKeyNotFound) (return . GetActivationCodeResp) apair @@ -422,11 +422,11 @@ data GetActivationCodeResp = GetActivationCodeResp (ActivationKey, ActivationCod instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] -getPasswordResetCodeH :: JSON ::: Either Email Phone -> Handler Response +getPasswordResetCodeH :: JSON ::: Either Email Phone -> (Handler r) Response getPasswordResetCodeH (_ ::: emailOrPhone) = do maybe (throwStd invalidPwResetKey) (pure . json) =<< lift (getPasswordResetCode emailOrPhone) -getPasswordResetCode :: Either Email Phone -> AppIO (Maybe GetPasswordResetCodeResp) +getPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe GetPasswordResetCodeResp) getPasswordResetCode emailOrPhone = do GetPasswordResetCodeResp <$$> API.lookupPasswordResetCode emailOrPhone @@ -435,27 +435,27 @@ data GetPasswordResetCodeResp = GetPasswordResetCodeResp (PasswordResetKey, Pass instance ToJSON GetPasswordResetCodeResp where toJSON (GetPasswordResetCodeResp (k, c)) = object ["key" .= k, "code" .= c] -changeAccountStatusH :: UserId ::: JsonRequest AccountStatusUpdate -> Handler Response +changeAccountStatusH :: UserId ::: JsonRequest AccountStatusUpdate -> (Handler r) Response changeAccountStatusH (usr ::: req) = do status <- suStatus <$> parseJsonBody req API.changeAccountStatus (List1.singleton usr) status !>> accountStatusError return empty -getAccountStatusH :: JSON ::: UserId -> Handler Response +getAccountStatusH :: JSON ::: UserId -> (Handler r) Response getAccountStatusH (_ ::: usr) = do status <- lift $ API.lookupStatus usr return $ case status of Just s -> json $ AccountStatusResp s Nothing -> setStatus status404 empty -getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> Handler [ConnectionStatus] +getConnectionsStatusUnqualified :: ConnectionsStatusRequest -> Maybe Relation -> (Handler r) [ConnectionStatus] getConnectionsStatusUnqualified ConnectionsStatusRequest {csrFrom, csrTo} flt = lift $ do r <- maybe (API.lookupConnectionStatus' csrFrom) (API.lookupConnectionStatus csrFrom) csrTo return $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((== rel) . csStatus) l -getConnectionsStatus :: ConnectionsStatusRequestV2 -> Handler [ConnectionStatusV2] +getConnectionsStatus :: ConnectionsStatusRequestV2 -> (Handler r) [ConnectionStatusV2] getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do loc <- qualifyLocal () conns <- lift $ case mtos of @@ -467,35 +467,35 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do where filterByRelation l rel = filter ((== rel) . csv2Status) l -revokeIdentityH :: Either Email Phone -> Handler Response +revokeIdentityH :: Either Email Phone -> (Handler r) Response revokeIdentityH emailOrPhone = do lift $ API.revokeIdentity emailOrPhone return $ setStatus status200 empty -updateConnectionInternalH :: JSON ::: JsonRequest UpdateConnectionsInternal -> Handler Response +updateConnectionInternalH :: JSON ::: JsonRequest UpdateConnectionsInternal -> (Handler r) Response updateConnectionInternalH (_ ::: req) = do updateConn <- parseJsonBody req API.updateConnectionInternal updateConn !>> connError return $ setStatus status200 empty -checkBlacklistH :: Either Email Phone -> Handler Response +checkBlacklistH :: Either Email Phone -> (Handler r) Response checkBlacklistH emailOrPhone = do bl <- lift $ API.isBlacklisted emailOrPhone return $ setStatus (bool status404 status200 bl) empty -deleteFromBlacklistH :: Either Email Phone -> Handler Response +deleteFromBlacklistH :: Either Email Phone -> (Handler r) Response deleteFromBlacklistH emailOrPhone = do void . lift $ API.blacklistDelete emailOrPhone return empty -addBlacklistH :: Either Email Phone -> Handler Response +addBlacklistH :: Either Email Phone -> (Handler r) Response addBlacklistH emailOrPhone = do void . lift $ API.blacklistInsert emailOrPhone return empty -- | Get any matching prefixes. Also try for shorter prefix matches, -- i.e. checking for +123456 also checks for +12345, +1234, ... -getPhonePrefixesH :: PhonePrefix -> Handler Response +getPhonePrefixesH :: PhonePrefix -> (Handler r) Response getPhonePrefixesH prefix = do results <- lift $ API.phonePrefixGet prefix return $ case results of @@ -503,18 +503,18 @@ getPhonePrefixesH prefix = do _ -> json results -- | Delete a phone prefix entry (must be an exact match) -deleteFromPhonePrefixH :: PhonePrefix -> Handler Response +deleteFromPhonePrefixH :: PhonePrefix -> (Handler r) Response deleteFromPhonePrefixH prefix = do void . lift $ API.phonePrefixDelete prefix return empty -addPhonePrefixH :: JSON ::: JsonRequest ExcludedPrefix -> Handler Response +addPhonePrefixH :: JSON ::: JsonRequest ExcludedPrefix -> (Handler r) Response addPhonePrefixH (_ ::: req) = do prefix :: ExcludedPrefix <- parseJsonBody req void . lift $ API.phonePrefixInsert prefix return empty -updateSSOIdH :: UserId ::: JSON ::: JsonRequest UserSSOId -> Handler Response +updateSSOIdH :: UserId ::: JSON ::: JsonRequest UserSSOId -> (Handler r) Response updateSSOIdH (uid ::: _ ::: req) = do ssoid :: UserSSOId <- parseJsonBody req success <- lift $ Data.updateSSOId uid (Just ssoid) @@ -524,7 +524,7 @@ updateSSOIdH (uid ::: _ ::: req) = do return empty else return . setStatus status404 $ plain "User does not exist or has no team." -deleteSSOIdH :: UserId ::: JSON -> Handler Response +deleteSSOIdH :: UserId ::: JSON -> (Handler r) Response deleteSSOIdH (uid ::: _) = do success <- lift $ Data.updateSSOId uid Nothing if success @@ -533,17 +533,17 @@ deleteSSOIdH (uid ::: _) = do return empty else return . setStatus status404 $ plain "User does not exist or has no team." -updateManagedByH :: UserId ::: JSON ::: JsonRequest ManagedByUpdate -> Handler Response +updateManagedByH :: UserId ::: JSON ::: JsonRequest ManagedByUpdate -> (Handler r) Response updateManagedByH (uid ::: _ ::: req) = do ManagedByUpdate managedBy <- parseJsonBody req lift $ Data.updateManagedBy uid managedBy return empty -updateRichInfoH :: UserId ::: JSON ::: JsonRequest RichInfoUpdate -> Handler Response +updateRichInfoH :: UserId ::: JSON ::: JsonRequest RichInfoUpdate -> (Handler r) Response updateRichInfoH (uid ::: _ ::: req) = do empty <$ (updateRichInfo uid =<< parseJsonBody req) -updateRichInfo :: UserId -> RichInfoUpdate -> Handler () +updateRichInfo :: UserId -> RichInfoUpdate -> (Handler r) () updateRichInfo uid rup = do let (unRichInfoAssocList -> richInfo) = normalizeRichInfoAssocList . riuRichInfo $ rup maxSize <- setRichInfoLimit <$> view settings @@ -552,31 +552,31 @@ updateRichInfo uid rup = do -- Intra.onUserEvent uid (Just conn) (richInfoUpdate uid ri) lift $ Data.updateRichInfo uid (mkRichInfoAssocList richInfo) -getRichInfoH :: UserId -> Handler Response +getRichInfoH :: UserId -> (Handler r) Response getRichInfoH uid = json <$> getRichInfo uid -getRichInfo :: UserId -> Handler RichInfo +getRichInfo :: UserId -> (Handler r) RichInfo getRichInfo uid = RichInfo . fromMaybe mempty <$> lift (API.lookupRichInfo uid) -getRichInfoMultiH :: List UserId -> Handler Response +getRichInfoMultiH :: List UserId -> (Handler r) Response getRichInfoMultiH uids = json <$> getRichInfoMulti (List.fromList uids) -getRichInfoMulti :: [UserId] -> Handler [(UserId, RichInfo)] +getRichInfoMulti :: [UserId] -> (Handler r) [(UserId, RichInfo)] getRichInfoMulti uids = lift (API.lookupRichInfoMultiUsers uids) -updateHandleH :: UserId ::: JSON ::: JsonRequest HandleUpdate -> Handler Response +updateHandleH :: UserId ::: JSON ::: JsonRequest HandleUpdate -> (Handler r) Response updateHandleH (uid ::: _ ::: body) = empty <$ (updateHandle uid =<< parseJsonBody body) -updateHandle :: UserId -> HandleUpdate -> Handler () +updateHandle :: UserId -> HandleUpdate -> (Handler r) () updateHandle uid (HandleUpdate handleUpd) = do handle <- validateHandle handleUpd API.changeHandle uid Nothing handle API.AllowSCIMUpdates !>> changeHandleError -updateUserNameH :: UserId ::: JSON ::: JsonRequest NameUpdate -> Handler Response +updateUserNameH :: UserId ::: JSON ::: JsonRequest NameUpdate -> (Handler r) Response updateUserNameH (uid ::: _ ::: body) = empty <$ (updateUserName uid =<< parseJsonBody body) -updateUserName :: UserId -> NameUpdate -> Handler () +updateUserName :: UserId -> NameUpdate -> (Handler r) () updateUserName uid (NameUpdate nameUpd) = do name <- either (const $ throwStd (errorDescriptionTypeToWai @InvalidUser)) pure $ mkName nameUpd let uu = @@ -590,19 +590,19 @@ updateUserName uid (NameUpdate nameUpd) = do Just _ -> API.updateUser uid Nothing uu API.AllowSCIMUpdates !>> updateProfileError Nothing -> throwStd (errorDescriptionTypeToWai @InvalidUser) -checkHandleInternalH :: Text -> Handler Response +checkHandleInternalH :: Text -> (Handler r) Response checkHandleInternalH = API.checkHandle >=> \case API.CheckHandleInvalid -> throwE (StdError (errorDescriptionTypeToWai @InvalidHandle)) API.CheckHandleFound -> pure $ setStatus status200 empty API.CheckHandleNotFound -> pure $ setStatus status404 empty -getContactListH :: JSON ::: UserId -> Handler Response +getContactListH :: JSON ::: UserId -> (Handler r) Response getContactListH (_ ::: uid) = do contacts <- lift $ API.lookupContactList uid return $ json $ UserIds contacts -- Utilities -ifNothing :: Utilities.Error -> Maybe a -> Handler a +ifNothing :: Utilities.Error -> Maybe a -> (Handler r) a ifNothing e = maybe (throwStd e) return diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index d6c3e00cd18..48d5af9e9c1 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -36,17 +36,17 @@ import Control.Error import Data.Id import Imports -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () +setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () setProperty u c k v = do Data.insertProperty u k v lift $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: UserId -> ConnId -> PropertyKey -> AppIO () +deleteProperty :: UserId -> ConnId -> PropertyKey -> (AppIO r) () deleteProperty u c k = do Data.deleteProperty u k Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: UserId -> ConnId -> AppIO () +clearProperties :: UserId -> ConnId -> (AppIO r) () clearProperties u c = do Data.clearProperties u Intra.onPropertyEvent u c (PropertiesCleared u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index f1c7bef947f..afffe057767 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -160,10 +160,10 @@ swaggerDocsAPI = . (S.required %~ nubOrd) . (S.enum_ . _Just %~ nub) -servantSitemap :: ServerT BrigAPI Handler +servantSitemap :: ServerT BrigAPI (Handler r) servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI where - userAPI :: ServerT UserAPI Handler + userAPI :: ServerT UserAPI (Handler r) userAPI = Named @"get-user-unqualified" getUserUnqualifiedH :<|> Named @"get-user-qualified" getUser @@ -174,7 +174,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"list-users-by-ids-or-handles" listUsersByIdsOrHandles :<|> Named @"send-verification-code" (const sendVerificationCode) - selfAPI :: ServerT SelfAPI Handler + selfAPI :: ServerT SelfAPI (Handler r) selfAPI = Named @"get-self" getSelf :<|> Named @"delete-self" deleteUser @@ -187,7 +187,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"change-locale" changeLocale :<|> Named @"change-handle" changeHandle - clientAPI :: ServerT ClientAPI Handler + clientAPI :: ServerT ClientAPI (Handler r) clientAPI = Named @"get-user-clients-unqualified" getUserClientsUnqualified :<|> Named @"get-user-clients-qualified" getUserClientsQualified @@ -196,7 +196,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"list-clients-bulk" listClientsBulk :<|> Named @"list-clients-bulk-v2" listClientsBulkV2 - prekeyAPI :: ServerT PrekeyAPI Handler + prekeyAPI :: ServerT PrekeyAPI (Handler r) prekeyAPI = Named @"get-users-prekeys-client-unqualified" getPrekeyUnqualifiedH :<|> Named @"get-users-prekeys-client-qualified" getPrekeyH @@ -205,7 +205,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"get-multi-user-prekey-bundle-unqualified" getMultiUserPrekeyBundleUnqualifiedH :<|> Named @"get-multi-user-prekey-bundle-qualified" getMultiUserPrekeyBundleH - userClientAPI :: ServerT UserClientAPI Handler + userClientAPI :: ServerT UserClientAPI (Handler r) userClientAPI = Named @"add-client" addClient :<|> Named @"update-client" updateClient @@ -215,7 +215,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"get-client-capabilities" getClientCapabilities :<|> Named @"get-client-prekeys" getClientPrekeys - connectionAPI :: ServerT ConnectionAPI Handler + connectionAPI :: ServerT ConnectionAPI (Handler r) connectionAPI = Named @"create-connection-unqualified" createConnectionUnqualified :<|> Named @"create-connection" createConnection @@ -234,7 +234,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli -- - UserDeleted event to contacts of the user -- - MemberLeave event to members for all conversations the user was in (via galley) -sitemap :: Routes Doc.ApiBuilder Handler () +sitemap :: Routes Doc.ApiBuilder (Handler r) () sitemap = do -- User Handle API ---------------------------------------------------- @@ -487,7 +487,7 @@ sitemap = do Team.routesPublic Calling.routesPublic -apiDocs :: Routes Doc.ApiBuilder Handler () +apiDocs :: Routes Doc.ApiBuilder (Handler r) () apiDocs = get "/users/api-docs" @@ -501,17 +501,17 @@ apiDocs = --------------------------------------------------------------------------- -- Handlers -setPropertyH :: UserId ::: ConnId ::: Public.PropertyKey ::: JsonRequest Public.PropertyValue -> Handler Response +setPropertyH :: UserId ::: ConnId ::: Public.PropertyKey ::: JsonRequest Public.PropertyValue -> (Handler r) Response setPropertyH (u ::: c ::: k ::: req) = do propkey <- safeParsePropertyKey k propval <- safeParsePropertyValue (lazyRequestBody (fromJsonRequest req)) empty <$ setProperty u c propkey propval -setProperty :: UserId -> ConnId -> Public.PropertyKey -> Public.PropertyValue -> Handler () +setProperty :: UserId -> ConnId -> Public.PropertyKey -> Public.PropertyValue -> (Handler r) () setProperty u c propkey propval = API.setProperty u c propkey propval !>> propDataError -safeParsePropertyKey :: Public.PropertyKey -> Handler Public.PropertyKey +safeParsePropertyKey :: Public.PropertyKey -> (Handler r) Public.PropertyKey safeParsePropertyKey k = do maxKeyLen <- fromMaybe defMaxKeyLen <$> view (settings . propertyMaxKeyLen) let keyText = Ascii.toText (Public.propertyKeyName k) @@ -522,7 +522,7 @@ safeParsePropertyKey k = do -- | Parse a 'PropertyValue' from a bytestring. This is different from 'FromJSON' in that -- checks the byte size of the input, and fails *without consuming all of it* if that size -- exceeds the settings. -safeParsePropertyValue :: IO Lazy.ByteString -> Handler Public.PropertyValue +safeParsePropertyValue :: IO Lazy.ByteString -> (Handler r) Public.PropertyValue safeParsePropertyValue lreqbody = do maxValueLen <- fromMaybe defMaxValueLen <$> view (settings . propertyMaxValueLen) lbs <- Lazy.take (maxValueLen + 1) <$> liftIO lreqbody @@ -530,56 +530,56 @@ safeParsePropertyValue lreqbody = do throwStd propertyValueTooLarge hoistEither $ fmapL (StdError . badRequest . pack) (eitherDecode lbs) -deletePropertyH :: UserId ::: ConnId ::: Public.PropertyKey -> Handler Response +deletePropertyH :: UserId ::: ConnId ::: Public.PropertyKey -> (Handler r) Response deletePropertyH (u ::: c ::: k) = lift (API.deleteProperty u c k) >> return empty -clearPropertiesH :: UserId ::: ConnId -> Handler Response +clearPropertiesH :: UserId ::: ConnId -> (Handler r) Response clearPropertiesH (u ::: c) = lift (API.clearProperties u c) >> return empty -getPropertyH :: UserId ::: Public.PropertyKey ::: JSON -> Handler Response +getPropertyH :: UserId ::: Public.PropertyKey ::: JSON -> (Handler r) Response getPropertyH (u ::: k ::: _) = do val <- lift $ API.lookupProperty u k return $ case val of Nothing -> setStatus status404 empty Just v -> json (v :: Public.PropertyValue) -listPropertyKeysH :: UserId ::: JSON -> Handler Response +listPropertyKeysH :: UserId ::: JSON -> (Handler r) Response listPropertyKeysH (u ::: _) = do keys <- lift (API.lookupPropertyKeys u) pure $ json (keys :: [Public.PropertyKey]) -listPropertyKeysAndValuesH :: UserId ::: JSON -> Handler Response +listPropertyKeysAndValuesH :: UserId ::: JSON -> (Handler r) Response listPropertyKeysAndValuesH (u ::: _) = do keysAndVals <- lift (API.lookupPropertyKeysAndValues u) pure $ json (keysAndVals :: Public.PropertyKeysAndValues) -getPrekeyUnqualifiedH :: UserId -> UserId -> ClientId -> Handler Public.ClientPrekey +getPrekeyUnqualifiedH :: UserId -> UserId -> ClientId -> (Handler r) Public.ClientPrekey getPrekeyUnqualifiedH zusr user client = do domain <- viewFederationDomain getPrekeyH zusr (Qualified user domain) client -getPrekeyH :: UserId -> Qualified UserId -> ClientId -> Handler Public.ClientPrekey +getPrekeyH :: UserId -> Qualified UserId -> ClientId -> (Handler r) Public.ClientPrekey getPrekeyH zusr (Qualified user domain) client = do mPrekey <- API.claimPrekey (ProtectedUser zusr) user domain client !>> clientError ifNothing (notFound "prekey not found") mPrekey -getPrekeyBundleUnqualifiedH :: UserId -> UserId -> Handler Public.PrekeyBundle +getPrekeyBundleUnqualifiedH :: UserId -> UserId -> (Handler r) Public.PrekeyBundle getPrekeyBundleUnqualifiedH zusr uid = do domain <- viewFederationDomain API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError -getPrekeyBundleH :: UserId -> Qualified UserId -> Handler Public.PrekeyBundle +getPrekeyBundleH :: UserId -> Qualified UserId -> (Handler r) Public.PrekeyBundle getPrekeyBundleH zusr (Qualified uid domain) = API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError -getMultiUserPrekeyBundleUnqualifiedH :: UserId -> Public.UserClients -> Handler Public.UserClientPrekeyMap +getMultiUserPrekeyBundleUnqualifiedH :: UserId -> Public.UserClients -> (Handler r) Public.UserClientPrekeyMap getMultiUserPrekeyBundleUnqualifiedH zusr userClients = do maxSize <- fromIntegral . setMaxConvSize <$> view settings when (Map.size (Public.userClients userClients) > maxSize) $ throwErrorDescriptionType @TooManyClients API.claimLocalMultiPrekeyBundles (ProtectedUser zusr) userClients !>> clientError -getMultiUserPrekeyBundleH :: UserId -> Public.QualifiedUserClients -> Handler Public.QualifiedUserClientPrekeyMap +getMultiUserPrekeyBundleH :: UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMap getMultiUserPrekeyBundleH zusr qualUserClients = do maxSize <- fromIntegral . setMaxConvSize <$> view settings let Sum (size :: Int) = @@ -590,7 +590,7 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do throwErrorDescriptionType @TooManyClients API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError -addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> Handler NewClientResponse +addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> (Handler r) NewClientResponse addClient usr con ip new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ @@ -600,56 +600,56 @@ addClient usr con ip new = do clientResponse :: Public.Client -> NewClientResponse clientResponse client = Servant.addHeader (Public.clientId client) client -deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> Handler () +deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> (Handler r) () deleteClient usr con clt body = API.rmClient usr con clt (Public.rmPassword body) !>> clientError -updateClient :: UserId -> ClientId -> Public.UpdateClient -> Handler () +updateClient :: UserId -> ClientId -> Public.UpdateClient -> (Handler r) () updateClient usr clt upd = API.updateClient usr clt upd !>> clientError -listClients :: UserId -> Handler [Public.Client] +listClients :: UserId -> (Handler r) [Public.Client] listClients zusr = lift $ API.lookupLocalClients zusr -getClient :: UserId -> ClientId -> Handler (Maybe Public.Client) +getClient :: UserId -> ClientId -> (Handler r) (Maybe Public.Client) getClient zusr clientId = lift $ API.lookupLocalClient zusr clientId -getUserClientsUnqualified :: UserId -> Handler [Public.PubClient] +getUserClientsUnqualified :: UserId -> (Handler r) [Public.PubClient] getUserClientsUnqualified uid = do localdomain <- viewFederationDomain API.lookupPubClients (Qualified uid localdomain) !>> clientError -getUserClientsQualified :: Qualified UserId -> Handler [Public.PubClient] +getUserClientsQualified :: Qualified UserId -> (Handler r) [Public.PubClient] getUserClientsQualified quid = API.lookupPubClients quid !>> clientError -getUserClientUnqualified :: UserId -> ClientId -> Handler Public.PubClient +getUserClientUnqualified :: UserId -> ClientId -> (Handler r) Public.PubClient getUserClientUnqualified uid cid = do localdomain <- viewFederationDomain x <- API.lookupPubClient (Qualified uid localdomain) cid !>> clientError ifNothing (notFound "client not found") x -listClientsBulk :: UserId -> Range 1 MaxUsersForListClientsBulk [Qualified UserId] -> Handler (Public.QualifiedUserMap (Set Public.PubClient)) +listClientsBulk :: UserId -> Range 1 MaxUsersForListClientsBulk [Qualified UserId] -> (Handler r) (Public.QualifiedUserMap (Set Public.PubClient)) listClientsBulk _zusr limitedUids = API.lookupPubClientsBulk (fromRange limitedUids) !>> clientError -listClientsBulkV2 :: UserId -> Public.LimitedQualifiedUserIdList MaxUsersForListClientsBulk -> Handler (Public.WrappedQualifiedUserMap (Set Public.PubClient)) +listClientsBulkV2 :: UserId -> Public.LimitedQualifiedUserIdList MaxUsersForListClientsBulk -> (Handler r) (Public.WrappedQualifiedUserMap (Set Public.PubClient)) listClientsBulkV2 zusr userIds = Public.Wrapped <$> listClientsBulk zusr (Public.qualifiedUsers userIds) -getUserClientQualified :: Qualified UserId -> ClientId -> Handler Public.PubClient +getUserClientQualified :: Qualified UserId -> ClientId -> (Handler r) Public.PubClient getUserClientQualified quid cid = do x <- API.lookupPubClient quid cid !>> clientError ifNothing (notFound "client not found") x -getClientCapabilities :: UserId -> ClientId -> Handler Public.ClientCapabilityList +getClientCapabilities :: UserId -> ClientId -> (Handler r) Public.ClientCapabilityList getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) maybe (throwErrorDescriptionType @ClientNotFound) (pure . Public.clientCapabilities) mclient -getRichInfoH :: UserId ::: UserId ::: JSON -> Handler Response +getRichInfoH :: UserId ::: UserId ::: JSON -> (Handler r) Response getRichInfoH (self ::: user ::: _) = json <$> getRichInfo self user -getRichInfo :: UserId -> UserId -> Handler Public.RichInfoAssocList +getRichInfo :: UserId -> UserId -> (Handler r) Public.RichInfoAssocList getRichInfo self user = do -- Check that both users exist and the requesting user is allowed to see rich info of the -- other user @@ -665,11 +665,11 @@ getRichInfo self user = do -- Query rich info fromMaybe mempty <$> lift (API.lookupRichInfo user) -getClientPrekeys :: UserId -> ClientId -> Handler [Public.PrekeyId] +getClientPrekeys :: UserId -> ClientId -> (Handler r) [Public.PrekeyId] getClientPrekeys usr clt = lift (API.lookupPrekeyIds usr clt) -- docs/reference/user/registration.md {#RefRegistration} -createUserH :: JSON ::: JsonRequest Public.NewUserPublic -> Handler Response +createUserH :: JSON ::: JsonRequest Public.NewUserPublic -> (Handler r) Response createUserH (_ ::: req) = do CreateUserResponse cok loc prof <- createUser =<< parseJsonBody req lift . Auth.setResponseCookie cok @@ -680,7 +680,7 @@ createUserH (_ ::: req) = do data CreateUserResponse = CreateUserResponse (Public.Cookie (ZAuth.Token ZAuth.User)) UserId Public.SelfProfile -createUser :: Public.NewUserPublic -> Handler CreateUserResponse +createUser :: Public.NewUserPublic -> (Handler r) CreateUserResponse createUser (Public.NewUserPublic new) = do API.checkRestrictedUserCreation new !>> newUserError for_ (Public.newUserEmail new) $ checkWhitelist . Left @@ -724,7 +724,7 @@ createUser (Public.NewUserPublic new) = do UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel pure $ CreateUserResponse cok userId (Public.SelfProfile usr) where - sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> AppIO () + sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppIO r) () sendActivationEmail e u p l mTeamUser | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, @@ -733,7 +733,7 @@ createUser (Public.NewUserPublic new) = do | otherwise = sendActivationMail e u p l Nothing - sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> AppIO () + sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppIO r) () -- NOTE: Welcome e-mails for the team creator are not dealt by brig anymore sendWelcomeEmail e (CreateUserTeam t n) newUser l = case newUser of Public.NewTeamCreator _ -> @@ -743,23 +743,23 @@ createUser (Public.NewUserPublic new) = do Public.NewTeamMemberSSO _ -> Team.sendMemberWelcomeMail e t n l -getSelf :: UserId -> Handler Public.SelfProfile +getSelf :: UserId -> (Handler r) Public.SelfProfile getSelf self = lift (API.lookupSelfProfile self) >>= ifNothing (errorDescriptionTypeToWai @UserNotFound) -getUserUnqualifiedH :: UserId -> UserId -> Handler (Maybe Public.UserProfile) +getUserUnqualifiedH :: UserId -> UserId -> (Handler r) (Maybe Public.UserProfile) getUserUnqualifiedH self uid = do domain <- viewFederationDomain getUser self (Qualified uid domain) -getUser :: UserId -> Qualified UserId -> Handler (Maybe Public.UserProfile) +getUser :: UserId -> Qualified UserId -> (Handler r) (Maybe Public.UserProfile) getUser self qualifiedUserId = do lself <- qualifyLocal self API.lookupProfile lself qualifiedUserId !>> fedError -- FUTUREWORK: Make servant understand that at least one of these is required -listUsersByUnqualifiedIdsOrHandles :: UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> Handler [Public.UserProfile] +listUsersByUnqualifiedIdsOrHandles :: UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> (Handler r) [Public.UserProfile] listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do domain <- viewFederationDomain case (mUids, mHandles) of @@ -775,7 +775,7 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do in listUsersByIdsOrHandles self (Public.ListUsersByHandles qualifiedRangedList) (Nothing, Nothing) -> throwStd $ badRequest "at least one ids or handles must be provided" -listUsersByIdsOrHandles :: UserId -> Public.ListUsersQuery -> Handler [Public.UserProfile] +listUsersByIdsOrHandles :: UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] listUsersByIdsOrHandles self q = do lself <- qualifyLocal self foundUsers <- case q of @@ -789,12 +789,12 @@ listUsersByIdsOrHandles self q = do [] -> throwStd $ notFound "None of the specified ids or handles match any users" _ -> pure foundUsers where - getIds :: [Handle] -> Handler [Qualified UserId] + getIds :: [Handle] -> (Handler r) [Qualified UserId] getIds localHandles = do localUsers <- catMaybes <$> traverse (lift . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers - byIds :: Local UserId -> [Qualified UserId] -> Handler [Public.UserProfile] + byIds :: Local UserId -> [Qualified UserId] -> (Handler r) [Public.UserProfile] byIds lself uids = API.lookupProfiles lself uids !>> fedError newtype GetActivationCodeResp @@ -803,45 +803,45 @@ newtype GetActivationCodeResp instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] -updateUser :: UserId -> ConnId -> Public.UserUpdate -> Handler (Maybe Public.UpdateProfileError) +updateUser :: UserId -> ConnId -> Public.UserUpdate -> (Handler r) (Maybe Public.UpdateProfileError) updateUser uid conn uu = do eithErr <- lift $ runExceptT $ API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates pure $ either Just (const Nothing) eithErr -changePhone :: UserId -> ConnId -> Public.PhoneUpdate -> Handler (Maybe Public.ChangePhoneError) +changePhone :: UserId -> ConnId -> Public.PhoneUpdate -> (Handler r) (Maybe Public.ChangePhoneError) changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do (adata, pn) <- API.changePhone u phone loc <- lift $ API.lookupLocale u let apair = (activationKey adata, activationCode adata) lift $ sendActivationSms pn apair loc -removePhone :: UserId -> ConnId -> Handler (Maybe Public.RemoveIdentityError) +removePhone :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) removePhone self conn = lift . exceptTToMaybe $ API.removePhone self conn -removeEmail :: UserId -> ConnId -> Handler (Maybe Public.RemoveIdentityError) +removeEmail :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) removeEmail self conn = lift . exceptTToMaybe $ API.removeEmail self conn -checkPasswordExists :: UserId -> Handler Bool +checkPasswordExists :: UserId -> (Handler r) Bool checkPasswordExists = fmap isJust . lift . API.lookupPassword -changePassword :: UserId -> Public.PasswordChange -> Handler (Maybe Public.ChangePasswordError) +changePassword :: UserId -> Public.PasswordChange -> (Handler r) (Maybe Public.ChangePasswordError) changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp -changeLocale :: UserId -> ConnId -> Public.LocaleUpdate -> Handler () +changeLocale :: UserId -> ConnId -> Public.LocaleUpdate -> (Handler r) () changeLocale u conn l = lift $ API.changeLocale u conn l -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandleH :: UserId ::: Text -> Handler Response +checkHandleH :: UserId ::: Text -> (Handler r) Response checkHandleH (_uid ::: hndl) = API.checkHandle hndl >>= \case API.CheckHandleInvalid -> throwE (StdError (errorDescriptionTypeToWai @InvalidHandle)) API.CheckHandleFound -> pure $ setStatus status200 empty API.CheckHandleNotFound -> pure $ setStatus status404 empty -checkHandlesH :: JSON ::: UserId ::: JsonRequest Public.CheckHandles -> Handler Response +checkHandlesH :: JSON ::: UserId ::: JsonRequest Public.CheckHandles -> (Handler r) Response checkHandlesH (_ ::: _ ::: req) = do Public.CheckHandles hs num <- parseJsonBody req let handles = mapMaybe parseHandle (fromRange hs) @@ -852,22 +852,22 @@ checkHandlesH (_ ::: _ ::: req) = do -- compatibility, whereas the corresponding qualified endpoint (implemented by -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. -getHandleInfoUnqualifiedH :: UserId -> Handle -> Handler (Maybe Public.UserHandleInfo) +getHandleInfoUnqualifiedH :: UserId -> Handle -> (Handler r) (Maybe Public.UserHandleInfo) getHandleInfoUnqualifiedH self handle = do domain <- viewFederationDomain Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> Handler (Maybe Public.ChangeHandleError) +changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> (Handler r) (Maybe Public.ChangeHandleError) changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates -beginPasswordResetH :: JSON ::: JsonRequest Public.NewPasswordReset -> Handler Response +beginPasswordResetH :: JSON ::: JsonRequest Public.NewPasswordReset -> (Handler r) Response beginPasswordResetH (_ ::: req) = setStatus status201 empty <$ (beginPasswordReset =<< parseJsonBody req) -beginPasswordReset :: Public.NewPasswordReset -> Handler () +beginPasswordReset :: Public.NewPasswordReset -> (Handler r) () beginPasswordReset (Public.NewPasswordReset target) = do checkWhitelist target (u, pair) <- API.beginPasswordReset target !>> pwResetError @@ -876,19 +876,19 @@ beginPasswordReset (Public.NewPasswordReset target) = do Left email -> sendPasswordResetMail email pair loc Right phone -> sendPasswordResetSms phone pair loc -completePasswordResetH :: JSON ::: JsonRequest Public.CompletePasswordReset -> Handler Response +completePasswordResetH :: JSON ::: JsonRequest Public.CompletePasswordReset -> (Handler r) Response completePasswordResetH (_ ::: req) = do Public.CompletePasswordReset {..} <- parseJsonBody req API.completePasswordReset cpwrIdent cpwrCode cpwrPassword !>> pwResetError return empty -sendActivationCodeH :: JsonRequest Public.SendActivationCode -> Handler Response +sendActivationCodeH :: JsonRequest Public.SendActivationCode -> (Handler r) Response sendActivationCodeH req = empty <$ (sendActivationCode =<< parseJsonBody req) -- docs/reference/user/activation.md {#RefActivationRequest} -- docs/reference/user/registration.md {#RefRegistration} -sendActivationCode :: Public.SendActivationCode -> Handler () +sendActivationCode :: Public.SendActivationCode -> (Handler r) () sendActivationCode Public.SendActivationCode {..} = do either customerExtensionCheckBlockedDomains (const $ pure ()) saUserKey checkWhitelist saUserKey @@ -898,7 +898,7 @@ sendActivationCode Public.SendActivationCode {..} = do -- -- The tautological constraint in the type signature is added so that once we remove the -- feature, ghc will guide us here. -customerExtensionCheckBlockedDomains :: (DomainsBlockedForRegistration ~ DomainsBlockedForRegistration) => Public.Email -> Handler () +customerExtensionCheckBlockedDomains :: (DomainsBlockedForRegistration ~ DomainsBlockedForRegistration) => Public.Email -> (Handler r) () customerExtensionCheckBlockedDomains email = do mBlockedDomains <- asks (fmap domainsBlockedForRegistration . setCustomerExtensions . view settings) for_ mBlockedDomains $ \(DomainsBlockedForRegistration blockedDomains) -> do @@ -909,30 +909,30 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> Handler (Public.ResponseForExistedCreated Public.UserConnection) +createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) createConnectionUnqualified self conn cr = do lself <- qualifyLocal self target <- qualifyLocal (Public.crUser cr) API.createConnection lself conn (qUntagged target) !>> connError -createConnection :: UserId -> ConnId -> Qualified UserId -> Handler (Public.ResponseForExistedCreated Public.UserConnection) +createConnection :: UserId -> ConnId -> Qualified UserId -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) createConnection self conn target = do lself <- qualifyLocal self API.createConnection lself conn target !>> connError -updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) +updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> (Handler r) (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do lother <- qualifyLocal other updateConnection self conn (qUntagged lother) update -updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> Handler (Public.UpdateResult Public.UserConnection) +updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> (Handler r) (Public.UpdateResult Public.UserConnection) updateConnection self conn other update = do let newStatus = Public.cuStatus update lself <- qualifyLocal self mc <- API.updateConnection lself other newStatus (Just conn) !>> connError return $ maybe Public.Unchanged Public.Updated mc -listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> Handler Public.UserConnectionList +listLocalConnections :: UserId -> Maybe UserId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.UserConnectionList listLocalConnections uid start msize = do let defaultSize = toRange (Proxy @100) lift $ API.lookupConnections uid start (fromMaybe defaultSize msize) @@ -945,7 +945,7 @@ listLocalConnections uid start msize = do -- -- - After local connections, remote connections are listed ordered -- - lexicographically by their domain and then by their id. -listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> Handler Public.ConnectionsPage +listConnections :: UserId -> Public.ListConnectionsRequestPaginated -> (Handler r) Public.ConnectionsPage listConnections uid Public.GetMultiTablePageRequest {..} = do self <- qualifyLocal uid case gmtprState of @@ -965,7 +965,7 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do mkState :: ByteString -> C.PagingState mkState = C.PagingState . LBS.fromStrict - localsAndRemotes :: Local UserId -> Maybe C.PagingState -> Range 1 500 Int32 -> Handler Public.ConnectionsPage + localsAndRemotes :: Local UserId -> Maybe C.PagingState -> Range 1 500 Int32 -> (Handler r) Public.ConnectionsPage localsAndRemotes self pagingState size = do localPage <- pageToConnectionsPage Public.PagingLocals <$> Data.lookupLocalConnectionsPage self pagingState (rcast size) let remainingSize = fromRange size - fromIntegral (length (Public.mtpResults localPage)) @@ -975,16 +975,16 @@ listConnections uid Public.GetMultiTablePageRequest {..} = do remotePage <- remotesOnly self Nothing remainingSize pure remotePage {Public.mtpResults = Public.mtpResults localPage <> Public.mtpResults remotePage} - remotesOnly :: Local UserId -> Maybe C.PagingState -> Int32 -> Handler Public.ConnectionsPage + remotesOnly :: Local UserId -> Maybe C.PagingState -> Int32 -> (Handler r) Public.ConnectionsPage remotesOnly self pagingState size = pageToConnectionsPage Public.PagingRemotes <$> Data.lookupRemoteConnectionsPage self pagingState size -getLocalConnection :: UserId -> UserId -> Handler (Maybe Public.UserConnection) +getLocalConnection :: UserId -> UserId -> (Handler r) (Maybe Public.UserConnection) getLocalConnection self other = do lother <- qualifyLocal other getConnection self (qUntagged lother) -getConnection :: UserId -> Qualified UserId -> Handler (Maybe Public.UserConnection) +getConnection :: UserId -> Qualified UserId -> (Handler r) (Maybe Public.UserConnection) getConnection self other = do lself <- qualifyLocal self lift $ Data.lookupConnection lself other @@ -992,17 +992,17 @@ getConnection self other = do deleteUser :: UserId -> Public.DeleteUser -> - Handler (Maybe Code.Timeout) + (Handler r) (Maybe Code.Timeout) deleteUser u body = API.deleteUser u (Public.deleteUserPassword body) !>> deleteUserError -verifyDeleteUserH :: JsonRequest Public.VerifyDeleteUser ::: JSON -> Handler Response +verifyDeleteUserH :: JsonRequest Public.VerifyDeleteUser ::: JSON -> (Handler r) Response verifyDeleteUserH (r ::: _) = do body <- parseJsonBody r API.verifyDeleteUser body !>> deleteUserError return (setStatus status200 empty) -updateUserEmail :: UserId -> UserId -> Public.EmailUpdate -> Handler () +updateUserEmail :: UserId -> UserId -> Public.EmailUpdate -> (Handler r) () updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do maybeZuserTeamId <- lift $ Data.lookupUserTeam zuserId whenM (not <$> assertHasPerm maybeZuserTeamId) $ throwStd insufficientTeamPermissions @@ -1010,12 +1010,12 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do checkSameTeam maybeZuserTeamId maybeEmailOwnerTeamId void $ API.changeSelfEmail emailOwnerId email API.AllowSCIMUpdates where - checkSameTeam :: Maybe TeamId -> Maybe TeamId -> Handler () + checkSameTeam :: Maybe TeamId -> Maybe TeamId -> (Handler r) () checkSameTeam (Just zuserTeamId) maybeEmailOwnerTeamId = when (Just zuserTeamId /= maybeEmailOwnerTeamId) $ throwStd $ notFound "user not found" checkSameTeam Nothing _ = throwStd insufficientTeamPermissions - assertHasPerm :: Maybe TeamId -> Handler Bool + assertHasPerm :: Maybe TeamId -> (Handler r) Bool assertHasPerm maybeTeamId = fromMaybe False <$> check where check = runMaybeT $ do @@ -1039,17 +1039,17 @@ respFromActivationRespWithStatus = \case ActivationRespSuccessNoIdent -> empty -- docs/reference/user/activation.md {#RefActivationSubmit} -activateKeyH :: JSON ::: JsonRequest Public.Activate -> Handler Response +activateKeyH :: JSON ::: JsonRequest Public.Activate -> (Handler r) Response activateKeyH (_ ::: req) = do activationRequest <- parseJsonBody req respFromActivationRespWithStatus <$> activate activationRequest -activateH :: Public.ActivationKey ::: Public.ActivationCode -> Handler Response +activateH :: Public.ActivationKey ::: Public.ActivationCode -> (Handler r) Response activateH (k ::: c) = do let activationRequest = Public.Activate (Public.ActivateKey k) c False respFromActivationRespWithStatus <$> activate activationRequest -activate :: Public.Activate -> Handler ActivationRespWithStatus +activate :: Public.Activate -> (Handler r) ActivationRespWithStatus activate (Public.Activate tgt code dryrun) | dryrun = do API.preverify tgt code !>> actError @@ -1065,14 +1065,14 @@ activate (Public.Activate tgt code dryrun) -- Verification -sendVerificationCode :: Handler () +sendVerificationCode :: (Handler r) () sendVerificationCode = case Public.TeamFeatureSndFPasswordChallengeNotImplemented of _ -> pure () -- Deprecated -deprecatedOnboardingH :: JSON ::: UserId ::: JsonRequest Value -> Handler Response +deprecatedOnboardingH :: JSON ::: UserId ::: JsonRequest Value -> (Handler r) Response deprecatedOnboardingH (_ ::: _ ::: _) = pure $ json DeprecatedMatchingResult data DeprecatedMatchingResult = DeprecatedMatchingResult @@ -1084,7 +1084,7 @@ instance ToJSON DeprecatedMatchingResult where "auto-connects" .= ([] :: [()]) ] -deprecatedCompletePasswordResetH :: JSON ::: Public.PasswordResetKey ::: JsonRequest Public.PasswordReset -> Handler Response +deprecatedCompletePasswordResetH :: JSON ::: Public.PasswordResetKey ::: JsonRequest Public.PasswordReset -> (Handler r) Response deprecatedCompletePasswordResetH (_ ::: k ::: req) = do pwr <- parseJsonBody req API.completePasswordReset @@ -1096,5 +1096,5 @@ deprecatedCompletePasswordResetH (_ ::: k ::: req) = do -- Utilities -ifNothing :: Utilities.Error -> Maybe a -> Handler a +ifNothing :: Utilities.Error -> Maybe a -> (Handler r) a ifNothing e = maybe (throwStd e) return diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ccbb7df3623..447cc3b3ef4 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -163,7 +163,7 @@ data AllowSCIMUpdates ------------------------------------------------------------------------------- -- Create User -verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError AppIO () +verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError (AppIO r) () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk blacklisted <- lift $ Blacklist.exists uk @@ -177,7 +177,7 @@ verifyUniquenessAndCheckBlacklist uk = do DuplicateUserKey k -- docs/reference/user/registration.md {#RefRegistration} -createUser :: NewUser -> ExceptT CreateUserError AppIO CreateUserResult +createUser :: NewUser -> ExceptT CreateUserError (AppIO r) CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -276,7 +276,7 @@ createUser new = do where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT IO) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT r IO) (Maybe Email, Maybe Phone) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> @@ -297,7 +297,7 @@ createUser new = do pure (email, phone) - findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError AppIO (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError (AppIO r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE MissingIdentity findTeamInvitation (Just e) c = lift (Team.lookupInvitationInfo c) >>= \case @@ -311,7 +311,7 @@ createUser new = do _ -> throwE InvalidInvitationCode Nothing -> throwE InvalidInvitationCode - ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError AppIO () + ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError (AppIO r) () ensureMemberCanJoin tid = do maxSize <- fromIntegral . setMaxTeamSize <$> view settings (TeamSize teamSize) <- TeamSize.teamSize tid @@ -330,7 +330,7 @@ createUser new = do Team.InvitationInfo -> UserKey -> UserIdentity -> - ExceptT CreateUserError (AppT IO) () + ExceptT CreateUserError (AppT r IO) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) ok <- lift $ Data.claimKey uk uid @@ -352,7 +352,7 @@ createUser new = do Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError (AppIO r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) added <- lift $ Intra.addTeamMember uid tid (Nothing, Team.defaultRole) @@ -369,7 +369,7 @@ createUser new = do pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT IO) (Maybe Activation) + handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) handleEmailActivation email uid newTeam = do fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do @@ -386,7 +386,7 @@ createUser new = do return Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT IO) (Maybe Activation) + handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) handlePhoneActivation phone uid = do pdata <- fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of Nothing -> do @@ -403,7 +403,7 @@ createUser new = do return Nothing pure pdata -initAccountFeatureConfig :: UserId -> AppIO () +initAccountFeatureConfig :: UserId -> (AppIO r) () initAccountFeatureConfig uid = do mbCciDefNew <- view (settings . getAfcConferenceCallingDefNewMaybe) forM_ mbCciDefNew $ Data.updateFeatureConferenceCalling uid . Just @@ -411,7 +411,7 @@ initAccountFeatureConfig uid = do -- | 'createUser' is becoming hard to maintian, and instead of adding more case distinctions -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. -createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error AppIO UserAccount +createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error (AppIO r) UserAccount createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`catchE` (throwE . Error.newUserError)) $ do email <- either (throwE . InvalidEmail rawEmail) pure (validateEmail rawEmail) let emKey = userEmailKey email @@ -438,7 +438,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. -checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError AppIO () +checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError (AppIO r) () checkRestrictedUserCreation new = do restrictPlease <- lift . asks $ fromMaybe False . setRestrictUserCreation . view settings when @@ -451,7 +451,7 @@ checkRestrictedUserCreation new = do ------------------------------------------------------------------------------- -- Update Profile -updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError AppIO () +updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError (AppIO r) () updateUser uid mconn uu allowScim = do for_ (uupName uu) $ \newName -> do mbUser <- lift $ Data.lookupUser WithPendingInvitations uid @@ -469,7 +469,7 @@ updateUser uid mconn uu allowScim = do ------------------------------------------------------------------------------- -- Update Locale -changeLocale :: UserId -> ConnId -> LocaleUpdate -> AppIO () +changeLocale :: UserId -> ConnId -> LocaleUpdate -> (AppIO r) () changeLocale uid conn (LocaleUpdate loc) = do Data.updateLocale uid loc Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) @@ -477,7 +477,7 @@ changeLocale uid conn (LocaleUpdate loc) = do ------------------------------------------------------------------------------- -- Update ManagedBy -changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> AppIO () +changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> (AppIO r) () changeManagedBy uid conn (ManagedByUpdate mb) = do Data.updateManagedBy uid mb Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) @@ -485,7 +485,7 @@ changeManagedBy uid conn (ManagedByUpdate mb) = do -------------------------------------------------------------------------------- -- Change Handle -changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError AppIO () +changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError (AppIO r) () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid @@ -517,7 +517,7 @@ data CheckHandleResp | CheckHandleFound | CheckHandleNotFound -checkHandle :: Text -> API.Handler CheckHandleResp +checkHandle :: Text -> API.Handler r CheckHandleResp checkHandle uhandle = do xhandle <- validateHandle uhandle owner <- lift $ lookupHandle xhandle @@ -539,7 +539,7 @@ checkHandle uhandle = do -------------------------------------------------------------------------------- -- Check Handles -checkHandles :: [Handle] -> Word -> AppIO [Handle] +checkHandles :: [Handle] -> Word -> (AppIO r) [Handle] checkHandles check num = reverse <$> collectFree [] check num where collectFree free _ 0 = return free @@ -558,7 +558,7 @@ checkHandles check num = reverse <$> collectFree [] check num -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error AppIO ChangeEmailResponse +changeSelfEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error (AppIO r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -576,7 +576,7 @@ changeSelfEmail u email allowScim = do (userIdentity usr) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError AppIO ChangeEmailResult +changeEmail :: UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError (AppIO r) ChangeEmailResult changeEmail u email allowScim = do em <- either @@ -608,7 +608,7 @@ changeEmail u email allowScim = do ------------------------------------------------------------------------------- -- Change Phone -changePhone :: UserId -> Phone -> ExceptT ChangePhoneError AppIO (Activation, Phone) +changePhone :: UserId -> Phone -> ExceptT ChangePhoneError (AppIO r) (Activation, Phone) changePhone u phone = do canonical <- maybe @@ -633,7 +633,7 @@ changePhone u phone = do ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () +removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () removeEmail uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -647,7 +647,7 @@ removeEmail uid conn = do ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError AppIO () +removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppIO r) () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid case ident of @@ -665,7 +665,7 @@ removePhone uid conn = do ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity -revokeIdentity :: Either Email Phone -> AppIO () +revokeIdentity :: Either Email Phone -> (AppIO r) () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key mu <- Data.lookupKey uk @@ -697,7 +697,7 @@ revokeIdentity key = do ------------------------------------------------------------------------------- -- Change Account Status -changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError AppIO () +changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError (AppIO r) () changeAccountStatus usrs status = do e <- ask ev <- case status of @@ -708,12 +708,12 @@ changeAccountStatus usrs status = do PendingInvitation -> throwE InvalidAccountStatus liftIO $ mapConcurrently_ (runAppT e . (update ev)) usrs where - update :: (UserId -> UserEvent) -> UserId -> AppIO () + update :: (UserId -> UserEvent) -> UserId -> (AppIO r) () update ev u = do Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) -suspendAccount :: HasCallStack => List1 UserId -> AppIO () +suspendAccount :: HasCallStack => List1 UserId -> (AppIO r) () suspendAccount usrs = runExceptT (changeAccountStatus usrs Suspended) >>= \case Right _ -> pure () @@ -727,7 +727,7 @@ activate :: ActivationCode -> -- | The user for whom to activate the key. Maybe UserId -> - ExceptT ActivationError AppIO ActivationResult + ExceptT ActivationError (AppIO r) ActivationResult activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: @@ -738,7 +738,7 @@ activateWithCurrency :: -- | Potential currency update. -- ^ TODO: to be removed once billing supports currency changes after team creation Maybe Currency.Alpha -> - ExceptT ActivationError AppIO ActivationResult + ExceptT ActivationError (AppIO r) ActivationResult activateWithCurrency tgt code usr cur = do key <- mkActivationKey tgt Log.info $ @@ -759,12 +759,12 @@ activateWithCurrency tgt code usr cur = do tid <- Intra.getTeamId uid for_ tid $ \t -> Intra.changeTeamStatus t Team.Active cur -preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError AppIO () +preverify :: ActivationTarget -> ActivationCode -> ExceptT ActivationError (AppIO r) () preverify tgt code = do key <- mkActivationKey tgt void $ Data.verifyCode key code -onActivated :: ActivationEvent -> AppIO (UserId, Maybe UserIdentity, Bool) +onActivated :: ActivationEvent -> (AppIO r) (UserId, Maybe UserIdentity, Bool) onActivated (AccountActivated account) = do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") @@ -779,7 +779,7 @@ onActivated (PhoneActivated uid phone) = do return (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} -sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError AppIO () +sendActivationCode :: Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppIO r) () sendActivationCode emailOrPhone loc call = case emailOrPhone of Left email -> do ek <- @@ -861,7 +861,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of _otherwise -> sendActivationMail em name p loc' ident -mkActivationKey :: ActivationTarget -> ExceptT ActivationError AppIO ActivationKey +mkActivationKey :: ActivationTarget -> ExceptT ActivationError (AppIO r) ActivationKey mkActivationKey (ActivateKey k) = return k mkActivationKey (ActivateEmail e) = do ek <- @@ -881,7 +881,7 @@ mkActivationKey (ActivatePhone p) = do ------------------------------------------------------------------------------- -- Password Management -changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError AppIO () +changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError (AppIO r) () changePassword uid cp = do activated <- lift $ Data.isActivated uid unless activated $ @@ -898,7 +898,7 @@ changePassword uid cp = do throwE ChangePasswordMustDiffer lift $ Data.updatePassword uid newpw >> revokeAllCookies uid -beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError AppIO (UserId, PasswordResetPair) +beginPasswordReset :: Either Email Phone -> ExceptT PasswordResetError (AppIO r) (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target user <- lift (Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) return @@ -911,7 +911,7 @@ beginPasswordReset target = do throwE (PasswordResetInProgress Nothing) (user,) <$> lift (Data.createPasswordResetCode user target) -completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError AppIO () +completePasswordReset :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () completePasswordReset ident code pw = do key <- mkPasswordResetKey ident muid :: Maybe UserId <- lift $ Data.verifyPasswordResetCode (key, code) @@ -927,14 +927,14 @@ completePasswordReset ident code pw = do -- | Pull the current password of a user and compare it against the one about to be installed. -- If the two are the same, throw an error. If no current password can be found, do nothing. -checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError AppIO () +checkNewIsDifferent :: UserId -> PlainTextPassword -> ExceptT PasswordResetError (AppIO r) () checkNewIsDifferent uid pw = do mcurrpw <- lift $ Data.lookupPassword uid case mcurrpw of Just currpw | verifyPassword pw currpw -> throwE ResetPasswordMustDiffer _ -> pure () -mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError AppIO PasswordResetKey +mkPasswordResetKey :: PasswordResetIdentity -> ExceptT PasswordResetError (AppIO r) PasswordResetKey mkPasswordResetKey ident = case ident of PasswordResetIdentityKey k -> return k PasswordResetEmailIdentity e -> user (userEmailKey e) >>= liftIO . Data.mkPasswordResetKey @@ -953,7 +953,7 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. -deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError AppIO (Maybe Timeout) +deleteUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppIO r) (Maybe Timeout) deleteUser uid pwd = do account <- lift $ Data.lookupAccount uid case account of @@ -965,7 +965,7 @@ deleteUser uid pwd = do Ephemeral -> go a PendingInvitation -> go a where - ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT IO) () + ensureNotOwner :: UserAccount -> ExceptT DeleteUserError (AppT r IO) () ensureNotOwner acc = do case userTeam $ accountUser acc of Nothing -> pure () @@ -1026,7 +1026,7 @@ deleteUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. -verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError AppIO () +verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError (AppIO r) () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d @@ -1040,7 +1040,7 @@ verifyDeleteUser d = do -- via deleting self. -- Team owners can be deleted if the team is not orphaned, i.e. there is at least one -- other owner left. -deleteAccount :: UserAccount -> AppIO () +deleteAccount :: UserAccount -> (AppIO r) () deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") @@ -1081,14 +1081,14 @@ deleteAccount account@(accountUser -> user) = do ------------------------------------------------------------------------------- -- Lookups -lookupActivationCode :: Either Email Phone -> AppIO (Maybe ActivationPair) +lookupActivationCode :: Either Email Phone -> (AppIO r) (Maybe ActivationPair) lookupActivationCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone k <- liftIO $ Data.mkActivationKey uk c <- fmap snd <$> Data.lookupActivationCode uk return $ (k,) <$> c -lookupPasswordResetCode :: Either Email Phone -> AppIO (Maybe PasswordResetPair) +lookupPasswordResetCode :: Either Email Phone -> (AppIO r) (Maybe PasswordResetPair) lookupPasswordResetCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone usr <- Data.lookupKey uk @@ -1099,12 +1099,12 @@ lookupPasswordResetCode emailOrPhone = do c <- Data.lookupPasswordResetCode u return $ (k,) <$> c -deleteUserNoVerify :: UserId -> AppIO () +deleteUserNoVerify :: UserId -> (AppIO r) () deleteUserNoVerify uid = do queue <- view internalEvents Queue.enqueue queue (Internal.DeleteUser uid) -deleteUsersNoVerify :: [UserId] -> AppIO () +deleteUsersNoVerify :: [UserId] -> (AppIO r) () deleteUsersNoVerify uids = do for_ uids deleteUserNoVerify m <- view metrics @@ -1113,7 +1113,7 @@ deleteUsersNoVerify uids = do -- | Garbage collect users if they're ephemeral and they have expired. -- Always returns the user (deletion itself is delayed) -userGC :: User -> AppIO User +userGC :: User -> (AppIO r) User userGC u = case (userExpire u) of Nothing -> return u (Just (fromUTCTimeMillis -> e)) -> do @@ -1123,7 +1123,7 @@ userGC u = case (userExpire u) of deleteUserNoVerify (userId u) return u -lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError AppIO (Maybe UserProfile) +lookupProfile :: Local UserId -> Qualified UserId -> ExceptT FederationError (AppIO r) (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfilesFromDomain @@ -1140,7 +1140,7 @@ lookupProfiles :: Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> - ExceptT FederationError AppIO [UserProfile] + ExceptT FederationError (AppIO r) [UserProfile] lookupProfiles self others = fmap concat $ traverseConcurrentlyWithErrors @@ -1148,14 +1148,14 @@ lookupProfiles self others = (bucketQualified others) lookupProfilesFromDomain :: - Local UserId -> Qualified [UserId] -> ExceptT FederationError AppIO [UserProfile] + Local UserId -> Qualified [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] lookupProfilesFromDomain self = foldQualified self (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) lookupRemoteProfiles -lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError AppIO [UserProfile] +lookupRemoteProfiles :: Remote [UserId] -> ExceptT FederationError (AppIO r) [UserProfile] lookupRemoteProfiles (qUntagged -> Qualified uids domain) = Federation.getUsersByIds domain uids @@ -1167,7 +1167,7 @@ lookupLocalProfiles :: Maybe UserId -> -- | The users ('others') for which to obtain the profiles. [UserId] -> - AppIO [UserProfile] + (AppIO r) [UserProfile] lookupLocalProfiles requestingUser others = do users <- Data.lookupUsers NoPendingInvitations others >>= mapM userGC css <- case requestingUser of @@ -1186,7 +1186,7 @@ lookupLocalProfiles requestingUser others = do toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - getSelfInfo :: UserId -> AppIO (Maybe (TeamId, Team.TeamMember)) + getSelfInfo :: UserId -> (AppIO r) (Maybe (TeamId, Team.TeamMember)) getSelfInfo selfId = do -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') -- to return 'Nothing'. we could throw errors here if that happens, rather than just @@ -1206,10 +1206,10 @@ lookupLocalProfiles requestingUser others = do else publicProfile u userLegalHold in baseProfile {profileEmail = profileEmail'} -getLegalHoldStatus :: UserId -> AppIO (Maybe UserLegalHoldStatus) +getLegalHoldStatus :: UserId -> (AppIO r) (Maybe UserLegalHoldStatus) getLegalHoldStatus uid = traverse (getLegalHoldStatus' . accountUser) =<< lookupAccount uid -getLegalHoldStatus' :: User -> AppIO UserLegalHoldStatus +getLegalHoldStatus' :: User -> (AppIO r) UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus @@ -1241,7 +1241,7 @@ getEmailForProfile _ EmailVisibleToSelf' = Nothing -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> AppIO [UserAccount] +lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppIO r) [UserAccount] lookupAccountsByIdentity emailOrPhone includePendingInvitations = do let uk = either userEmailKey userPhoneKey emailOrPhone activeUid <- Data.lookupKey uk @@ -1251,26 +1251,26 @@ lookupAccountsByIdentity emailOrPhone includePendingInvitations = do then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result -isBlacklisted :: Either Email Phone -> AppIO Bool +isBlacklisted :: Either Email Phone -> (AppIO r) Bool isBlacklisted emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.exists uk -blacklistInsert :: Either Email Phone -> AppIO () +blacklistInsert :: Either Email Phone -> (AppIO r) () blacklistInsert emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.insert uk -blacklistDelete :: Either Email Phone -> AppIO () +blacklistDelete :: Either Email Phone -> (AppIO r) () blacklistDelete emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone Blacklist.delete uk -phonePrefixGet :: PhonePrefix -> AppIO [ExcludedPrefix] +phonePrefixGet :: PhonePrefix -> (AppIO r) [ExcludedPrefix] phonePrefixGet prefix = Blacklist.getAllPrefixes prefix -phonePrefixDelete :: PhonePrefix -> AppIO () +phonePrefixDelete :: PhonePrefix -> (AppIO r) () phonePrefixDelete = Blacklist.deletePrefix -phonePrefixInsert :: ExcludedPrefix -> AppIO () +phonePrefixInsert :: ExcludedPrefix -> (AppIO r) () phonePrefixInsert = Blacklist.insertPrefix diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 58d90d80c28..680b42fc6ae 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -50,14 +50,14 @@ import UnliftIO.Exception (throwIO, try) import Util.Logging (sha256String) import Wire.API.ErrorDescription -lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> Handler [UserProfile] +lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do selfTeam <- lift $ Data.lookupUserTeam self return $ case selfTeam of Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> AppIO (Maybe UserIdentity) +fetchUserIdentity :: UserId -> (AppIO r) (Maybe UserIdentity) fetchUserIdentity uid = lookupSelfProfile uid >>= maybe @@ -65,12 +65,12 @@ fetchUserIdentity uid = (return . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) +lookupSelfProfile :: UserId -> (AppIO r) (Maybe SelfProfile) lookupSelfProfile = fmap (fmap mk) . Data.lookupAccount where mk a = SelfProfile (accountUser a) -validateHandle :: Text -> Handler Handle +validateHandle :: Text -> (Handler r) Handle validateHandle = maybe (throwE (Error.StdError (errorDescriptionTypeToWai @InvalidHandle))) return . parseHandle logEmail :: Email -> (Msg -> Msg) @@ -83,9 +83,9 @@ logInvitationCode code = Log.field "invitation_code" (toText $ fromInvitationCod -- | Traverse concurrently and fail on first error. traverseConcurrentlyWithErrors :: (Traversable t, Exception e) => - (a -> ExceptT e AppIO b) -> + (a -> ExceptT e (AppIO r) b) -> t a -> - ExceptT e AppIO (t b) + ExceptT e (AppIO r) (t b) traverseConcurrentlyWithErrors f = ExceptT . try . (traverse (either throwIO pure) =<<) . pooledMapConcurrentlyN 8 (runExceptT . f) diff --git a/services/brig/src/Brig/AWS/SesNotification.hs b/services/brig/src/Brig/AWS/SesNotification.hs index 1bcdccfc829..f4b10a0180f 100644 --- a/services/brig/src/Brig/AWS/SesNotification.hs +++ b/services/brig/src/Brig/AWS/SesNotification.hs @@ -29,27 +29,27 @@ import Imports import System.Logger.Class (field, msg, (~~)) import qualified System.Logger.Class as Log -onEvent :: SESNotification -> AppIO () +onEvent :: SESNotification -> (AppIO r) () onEvent (MailBounce BouncePermanent es) = onPermanentBounce es onEvent (MailBounce BounceTransient es) = onTransientBounce es onEvent (MailBounce BounceUndetermined es) = onUndeterminedBounce es onEvent (MailComplaint es) = onComplaint es -onPermanentBounce :: [Email] -> AppIO () +onPermanentBounce :: [Email] -> (AppIO r) () onPermanentBounce = mapM_ $ \e -> do logEmailEvent "Permanent bounce" e Blacklist.insert (userEmailKey e) -onTransientBounce :: [Email] -> AppIO () +onTransientBounce :: [Email] -> (AppIO r) () onTransientBounce = mapM_ (logEmailEvent "Transient bounce") -onUndeterminedBounce :: [Email] -> AppIO () +onUndeterminedBounce :: [Email] -> (AppIO r) () onUndeterminedBounce = mapM_ (logEmailEvent "Undetermined bounce") -onComplaint :: [Email] -> AppIO () +onComplaint :: [Email] -> (AppIO r) () onComplaint = mapM_ $ \e -> do logEmailEvent "Complaint" e Blacklist.insert (userEmailKey e) -logEmailEvent :: Text -> Email -> AppIO () +logEmailEvent :: Text -> Email -> (AppIO r) () logEmailEvent t e = Log.info $ field "email" (fromEmail e) ~~ msg t diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index dc4c9ecc3e2..cb48e47c77f 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -419,13 +419,13 @@ initCredentials secretFile = do dat <- loadSecret secretFile return $ either (\e -> error $ "Could not load secrets from " ++ show secretFile ++ ": " ++ e) id dat -userTemplates :: Monad m => Maybe Locale -> AppT m (Locale, UserTemplates) +userTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, UserTemplates) userTemplates l = forLocale l <$> view usrTemplates -providerTemplates :: Monad m => Maybe Locale -> AppT m (Locale, ProviderTemplates) +providerTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, ProviderTemplates) providerTemplates l = forLocale l <$> view provTemplates -teamTemplates :: Monad m => Maybe Locale -> AppT m (Locale, TeamTemplates) +teamTemplates :: Monad m => Maybe Locale -> AppT r m (Locale, TeamTemplates) teamTemplates l = forLocale l <$> view tmTemplates closeEnv :: Env -> IO () @@ -437,7 +437,7 @@ closeEnv e = do ------------------------------------------------------------------------------- -- App Monad -newtype AppT m a = AppT +newtype AppT r m a = AppT { unAppT :: ReaderT Env m a } deriving newtype @@ -454,58 +454,58 @@ newtype AppT m a = AppT ( Semigroup, Monoid ) - via (Ap (AppT m) a) + via (Ap (AppT r m) a) -type AppIO = AppT IO +type AppIO r = AppT r IO -instance MonadIO m => MonadLogger (AppT m) where +instance MonadIO m => MonadLogger (AppT r m) where log l m = do g <- view applog r <- view requestId Log.log g l $ field "request" (unRequestId r) ~~ m -instance MonadIO m => MonadLogger (ExceptT err (AppT m)) where +instance MonadIO m => MonadLogger (ExceptT err (AppT r m)) where log l m = lift (LC.log l m) -instance (Monad m, MonadIO m) => MonadHttp (AppT m) where +instance (Monad m, MonadIO m) => MonadHttp (AppT r m) where handleRequestWithCont req handler = do manager <- view httpManager liftIO $ withResponse req manager handler -instance MonadIO m => MonadZAuth (AppT m) where +instance MonadIO m => MonadZAuth (AppT r m) where liftZAuth za = view zauthEnv >>= \e -> runZAuth e za -instance MonadIO m => MonadZAuth (ExceptT err (AppT m)) where +instance MonadIO m => MonadZAuth (ExceptT err (AppT r m)) where liftZAuth = lift . liftZAuth -instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT m) where +instance (MonadThrow m, MonadCatch m, MonadIO m) => MonadClient (AppT r m) where liftClient m = view casClient >>= \c -> runClient c m localState f = local (over casClient f) -instance MonadIndexIO AppIO where +instance MonadIndexIO (AppIO r) where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance (MonadIndexIO (AppT m), Monad m) => MonadIndexIO (ExceptT err (AppT m)) where +instance (MonadIndexIO (AppT r m), Monad m) => MonadIndexIO (ExceptT err (AppT r m)) where liftIndexIO m = view indexEnv >>= \e -> runIndexIO e m -instance Monad m => HasRequestId (AppT m) where +instance Monad m => HasRequestId (AppT r m) where getRequestId = view requestId -instance MonadUnliftIO m => MonadUnliftIO (AppT m) where +instance MonadUnliftIO m => MonadUnliftIO (AppT r m) where withRunInIO inner = AppT . ReaderT $ \r -> withRunInIO $ \run -> inner (run . flip runReaderT r . unAppT) -runAppT :: Env -> AppT m a -> m a +runAppT :: Env -> AppT r m a -> m a runAppT e (AppT ma) = runReaderT ma e -runAppResourceT :: ResourceT AppIO a -> AppIO a +runAppResourceT :: ResourceT (AppIO r) a -> (AppIO r) a runAppResourceT ma = do e <- ask liftIO . runResourceT $ transResourceT (runAppT e) ma -forkAppIO :: Maybe UserId -> AppIO a -> AppIO () +forkAppIO :: Maybe UserId -> (AppIO r) a -> (AppIO r) () forkAppIO u ma = do a <- ask g <- view applog diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 7234760e398..561e494c953 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -62,7 +62,7 @@ import Wire.API.Call.Config (SFTServer) import qualified Wire.API.Call.Config as Public import Wire.Network.DNS.SRV (srvTarget) -routesPublic :: Routes Doc.ApiBuilder Handler () +routesPublic :: Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Deprecated endpoint, but still used by old clients. -- See https://github.com/zinfra/backend-issues/issues/1616 for context @@ -94,12 +94,12 @@ routesPublic = do Doc.returns (Doc.ref Public.modelRtcConfiguration) Doc.response 200 "RTCConfiguration" Doc.end -getCallsConfigV2H :: JSON ::: UserId ::: ConnId ::: Maybe (Range 1 10 Int) -> Handler Response +getCallsConfigV2H :: JSON ::: UserId ::: ConnId ::: Maybe (Range 1 10 Int) -> (Handler r) Response getCallsConfigV2H (_ ::: uid ::: connid ::: limit) = json <$> getCallsConfigV2 uid connid limit -- | ('UserId', 'ConnId' are required as args here to make sure this is an authenticated end-point.) -getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> Handler Public.RTCConfiguration +getCallsConfigV2 :: UserId -> ConnId -> Maybe (Range 1 10 Int) -> (Handler r) Public.RTCConfiguration getCallsConfigV2 _ _ limit = do env <- liftIO . readIORef =<< view turnEnvV2 staticUrl <- view $ settings . Opt.sftStaticUrl @@ -113,11 +113,11 @@ getCallsConfigV2 _ _ limit = do . interpretSFT manager $ newConfig env staticUrl sftEnv' limit sftListAllServers CallsConfigV2 -getCallsConfigH :: JSON ::: UserId ::: ConnId -> Handler Response +getCallsConfigH :: JSON ::: UserId ::: ConnId -> (Handler r) Response getCallsConfigH (_ ::: uid ::: connid) = json <$> getCallsConfig uid connid -getCallsConfig :: UserId -> ConnId -> Handler Public.RTCConfiguration +getCallsConfig :: UserId -> ConnId -> (Handler r) Public.RTCConfiguration getCallsConfig _ _ = do env <- liftIO . readIORef =<< view turnEnv logger <- view applog diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 1f3b394214c..919f93df768 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -78,7 +78,7 @@ activateKey :: ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError AppIO (Maybe ActivationEvent) + ExceptT ActivationError (AppIO r) (Maybe ActivationEvent) activateKey k c u = verifyCode k c >>= pickUser >>= activate where pickUser (uk, u') = maybe (throwE invalidUser) (return . (uk,)) (u <|> u') @@ -129,7 +129,7 @@ newActivation :: Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> - AppIO Activation + (AppIO r) Activation newActivation uk timeout u = do (typ, key, code) <- liftIO $ @@ -148,7 +148,7 @@ newActivation uk timeout u = do <$> randIntegerZeroToNMinusOne 1000000 -- | Lookup an activation code and it's associated owner (if any) for a 'UserKey'. -lookupActivationCode :: UserKey -> AppIO (Maybe (Maybe UserId, ActivationCode)) +lookupActivationCode :: UserKey -> (AppIO r) (Maybe (Maybe UserId, ActivationCode)) lookupActivationCode k = liftIO (mkActivationKey k) >>= retry x1 . query1 codeSelect . params LocalQuorum . Identity @@ -157,7 +157,7 @@ lookupActivationCode k = verifyCode :: ActivationKey -> ActivationCode -> - ExceptT ActivationError AppIO (UserKey, Maybe UserId) + ExceptT ActivationError (AppIO r) (UserKey, Maybe UserId) verifyCode key code = do s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) case s of @@ -185,7 +185,7 @@ mkActivationKey k = do let bs = digestBS d' (T.encodeUtf8 $ keyText k) return . ActivationKey $ Ascii.encodeBase64Url bs -deleteActivationPair :: ActivationKey -> AppIO () +deleteActivationPair :: ActivationKey -> (AppIO r) () deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index b6178a0a8d5..7b4d9ed1909 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -94,7 +94,7 @@ addClient :: Int -> Maybe Location -> Maybe (Imports.Set ClientCapability) -> - ExceptT ClientDataError AppIO (Client, [Client], Word) + ExceptT ClientDataError (AppIO r) (Client, [Client], Word) addClient u newId c maxPermClients loc cps = do clients <- lookupClients u let typed = filter ((== newClientType c) . clientType) clients @@ -120,7 +120,7 @@ addClient u newId c maxPermClients loc cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: ExceptT ClientDataError AppIO Client + insert :: ExceptT ClientDataError (AppIO r) Client insert = do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) @@ -184,7 +184,7 @@ lookupPrekeyIds u c = hasClient :: MonadClient m => UserId -> ClientId -> m Bool hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) -rmClient :: UserId -> ClientId -> AppIO () +rmClient :: UserId -> ClientId -> (AppIO r) () rmClient u c = do retry x5 $ write removeClient (params LocalQuorum (u, c)) retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) @@ -212,7 +212,7 @@ updatePrekeys u c pks = do Success n -> return (CryptoBox.prekeyId n == keyId (prekeyId a)) _ -> return False -claimPrekey :: UserId -> ClientId -> AppIO (Maybe ClientPrekey) +claimPrekey :: UserId -> ClientId -> (AppIO r) (Maybe ClientPrekey) claimPrekey u c = view randomPrekeyLocalLock >>= \case -- Use random prekey selection strategy @@ -225,7 +225,7 @@ claimPrekey u c = prekey <- retry x1 $ query1 userPrekey (params LocalQuorum (u, c)) removeAndReturnPreKey prekey where - removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> AppIO (Maybe ClientPrekey) + removeAndReturnPreKey :: Maybe (PrekeyId, Text) -> (AppIO r) (Maybe ClientPrekey) removeAndReturnPreKey (Just (i, k)) = do if i /= lastPrekeyId then retry x1 $ write removePrekey (params LocalQuorum (u, c, i)) @@ -237,7 +237,7 @@ claimPrekey u c = return $ Just (ClientPrekey c (Prekey i k)) removeAndReturnPreKey Nothing = return Nothing - pickRandomPrekey :: [(PrekeyId, Text)] -> AppIO (Maybe (PrekeyId, Text)) + pickRandomPrekey :: [(PrekeyId, Text)] -> (AppIO r) (Maybe (PrekeyId, Text)) pickRandomPrekey [] = return Nothing -- unless we only have one key left pickRandomPrekey [pk] = return $ Just pk @@ -330,13 +330,13 @@ ddbKey u c = AWS.attributeValue & AWS.avS ?~ UUID.toText (toUUID u) <> "." <> cl key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue key u c = HashMap.singleton ddbClient (ddbKey u c) -deleteOptLock :: UserId -> ClientId -> AppIO () +deleteOptLock :: UserId -> ClientId -> (AppIO r) () deleteOptLock u c = do t <- view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) void $ exec e (AWS.deleteItem t & AWS.diKey .~ (key u c)) -withOptLock :: UserId -> ClientId -> AppIO a -> AppIO a +withOptLock :: forall effs a. UserId -> ClientId -> (AppIO effs) a -> (AppIO effs) a withOptLock u c ma = go (10 :: Int) where go !n = do @@ -372,30 +372,31 @@ withOptLock u c ma = go (10 :: Int) key u c toAttributeValue :: Word32 -> AWS.AttributeValue toAttributeValue w = AWS.attributeValue & AWS.avN ?~ AWS.toText (fromIntegral w :: Int) - reportAttemptFailure :: AppIO () + reportAttemptFailure :: (AppIO effs) () reportAttemptFailure = Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_grab_attempt_failed") =<< view metrics - reportFailureAndLogError :: AppIO () + reportFailureAndLogError :: (AppIO effs) () reportFailureAndLogError = do Log.err $ Log.field "user" (toByteString' u) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics - execDyn :: (AWS.AWSRequest r) => (AWS.Rs r -> Maybe a) -> (Text -> r) -> AppIO (Maybe a) + execDyn :: forall r x. (AWS.AWSRequest r) => (AWS.Rs r -> Maybe x) -> (Text -> r) -> (AppIO effs) (Maybe x) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) m <- view metrics - execDyn' e m cnv cmd + liftIO $ execDyn' e m cnv cmd where execDyn' :: - (AWS.AWSRequest r, MonadUnliftIO m, MonadMask m, MonadIO m, Typeable m) => + forall y p. + AWS.AWSRequest p => AWS.Env -> Metrics.Metrics -> - (AWS.Rs r -> Maybe a) -> - r -> - m (Maybe a) + (AWS.Rs p -> Maybe y) -> + p -> + IO (Maybe y) execDyn' e m conv cmd = recovering policy handlers (const run) where run = execCatch e cmd >>= either handleErr (return . conv) @@ -406,6 +407,6 @@ withOptLock u c ma = go (10 :: Int) return Nothing handleErr _ = return Nothing -withLocalLock :: MVar () -> AppIO a -> AppIO a +withLocalLock :: MVar () -> (AppIO r) a -> (AppIO r) a withLocalLock l ma = do (takeMVar l *> ma) `finally` putMVar l () diff --git a/services/brig/src/Brig/Data/Connection.hs b/services/brig/src/Brig/Data/Connection.hs index 949a458f57e..fe43894b4f4 100644 --- a/services/brig/src/Brig/Data/Connection.hs +++ b/services/brig/src/Brig/Data/Connection.hs @@ -73,7 +73,7 @@ insertConnection :: Qualified UserId -> RelationWithHistory -> Qualified ConvId -> - AppIO UserConnection + (AppIO r) UserConnection insertConnection self target rel qcnv@(Qualified cnv cdomain) = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -92,7 +92,7 @@ insertConnection self target rel qcnv@(Qualified cnv cdomain) = do ucConvId = Just qcnv } -updateConnection :: UserConnection -> RelationWithHistory -> AppIO UserConnection +updateConnection :: UserConnection -> RelationWithHistory -> (AppIO r) UserConnection updateConnection c status = do self <- qualifyLocal (ucFrom c) now <- updateConnectionStatus self (ucTo c) status @@ -102,7 +102,7 @@ updateConnection c status = do ucLastUpdate = now } -updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> AppIO UTCTimeMillis +updateConnectionStatus :: Local UserId -> Qualified UserId -> RelationWithHistory -> (AppIO r) UTCTimeMillis updateConnectionStatus self target status = do now <- toUTCTimeMillis <$> liftIO getCurrentTime let local (tUnqualified -> ltarget) = @@ -115,7 +115,7 @@ updateConnectionStatus self target status = do pure now -- | Lookup the connection from a user 'A' to a user 'B' (A -> B). -lookupConnection :: Local UserId -> Qualified UserId -> AppIO (Maybe UserConnection) +lookupConnection :: Local UserId -> Qualified UserId -> (AppIO r) (Maybe UserConnection) lookupConnection self target = runMaybeT $ do let local (tUnqualified -> ltarget) = do (_, _, rel, time, mcnv) <- @@ -143,7 +143,7 @@ lookupRelationWithHistory :: Local UserId -> -- | User 'B' Qualified UserId -> - AppIO (Maybe RelationWithHistory) + (AppIO r) (Maybe RelationWithHistory) lookupRelationWithHistory self target = do let local (tUnqualified -> ltarget) = query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) @@ -151,14 +151,14 @@ lookupRelationWithHistory self target = do query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) runIdentity <$$> retry x1 (foldQualified self local remote target) -lookupRelation :: Local UserId -> Qualified UserId -> AppIO Relation +lookupRelation :: Local UserId -> Qualified UserId -> (AppIO r) Relation lookupRelation self target = lookupRelationWithHistory self target <&> \case Nothing -> Cancelled Just relh -> (relationDropHistory relh) -- | For a given user 'A', lookup their outgoing connections (A -> X) to other users. -lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> AppIO (ResultPage UserConnection) +lookupLocalConnections :: Local UserId -> Maybe UserId -> Range 1 500 Int32 -> (AppIO r) (ResultPage UserConnection) lookupLocalConnections lfrom start (fromRange -> size) = toResult <$> case start of Just u -> @@ -196,48 +196,48 @@ lookupRemoteConnectionsPage self pagingState size = (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus :: [UserId] -> [UserId] -> AppIO [ConnectionStatus] +lookupConnectionStatus :: [UserId] -> [UserId] -> (AppIO r) [ConnectionStatus] lookupConnectionStatus from to = map toConnectionStatus <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) -- | Lookup all relations between two sets of users (cartesian product). -lookupConnectionStatus' :: [UserId] -> AppIO [ConnectionStatus] +lookupConnectionStatus' :: [UserId] -> (AppIO r) [ConnectionStatus] lookupConnectionStatus' from = map toConnectionStatus <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) -lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> AppIO [ConnectionStatusV2] +lookupLocalConnectionStatuses :: [UserId] -> Local [UserId] -> (AppIO r) [ConnectionStatusV2] lookupLocalConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) -lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> AppIO [ConnectionStatusV2] +lookupRemoteConnectionStatuses :: [UserId] -> Remote [UserId] -> (AppIO r) [ConnectionStatusV2] lookupRemoteConnectionStatuses froms tos = do concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms where - lookupStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain tos)) <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) -lookupAllStatuses :: Local [UserId] -> AppIO [ConnectionStatusV2] +lookupAllStatuses :: Local [UserId] -> (AppIO r) [ConnectionStatusV2] lookupAllStatuses lfroms = do let froms = tUnqualified lfroms concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms where - lookupAndCombine :: UserId -> AppIO [ConnectionStatusV2] + lookupAndCombine :: UserId -> (AppIO r) [ConnectionStatusV2] lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u - lookupLocalStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupLocalStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupLocalStatuses from = map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) - lookupRemoteStatuses :: UserId -> AppIO [ConnectionStatusV2] + lookupRemoteStatuses :: UserId -> (AppIO r) [ConnectionStatusV2] lookupRemoteStatuses from = map (\(d, u, r) -> toConnectionStatusV2 from d u r) <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) @@ -248,20 +248,20 @@ lookupRemoteConnectedUsersC u maxResults = .| C.map (map (uncurry toRemoteUnsafe)) -- | See 'lookupContactListWithRelation'. -lookupContactList :: UserId -> AppIO [UserId] +lookupContactList :: UserId -> (AppIO r) [UserId] lookupContactList u = fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelation u) -- | For a given user 'A', lookup the list of users that form his contact list, -- i.e. the users to whom 'A' has an outgoing 'Accepted' relation (A -> B). -lookupContactListWithRelation :: UserId -> AppIO [(UserId, RelationWithHistory)] +lookupContactListWithRelation :: UserId -> (AppIO r) [(UserId, RelationWithHistory)] lookupContactListWithRelation 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.) -- Note: The count is eventually consistent. -countConnections :: Local UserId -> [Relation] -> AppIO Int64 +countConnections :: Local UserId -> [Relation] -> (AppIO r) Int64 countConnections u r = do rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) @@ -277,7 +277,7 @@ countConnections u r = do count n (Identity s) | (relationDropHistory s) `elem` r = n + 1 count n _ = n -deleteConnections :: UserId -> AppIO () +deleteConnections :: UserId -> (AppIO r) () deleteConnections u = do runConduit $ paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 @@ -287,7 +287,7 @@ deleteConnections u = do where delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) -deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> AppIO () +deleteRemoteConnections :: Remote UserId -> Range 1 1000 [UserId] -> (AppIO r) () deleteRemoteConnections (qUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = pooledForConcurrentlyN_ 16 locals $ \u -> write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) diff --git a/services/brig/src/Brig/Data/LoginCode.hs b/services/brig/src/Brig/Data/LoginCode.hs index c4665d92324..d5627e7e81b 100644 --- a/services/brig/src/Brig/Data/LoginCode.hs +++ b/services/brig/src/Brig/Data/LoginCode.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 600 -createLoginCode :: UserId -> AppIO PendingLoginCode +createLoginCode :: UserId -> (AppIO r) PendingLoginCode createLoginCode u = do now <- liftIO =<< view currentTime code <- liftIO genCode @@ -57,7 +57,7 @@ createLoginCode u = do where genCode = LoginCode . T.pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -verifyLoginCode :: UserId -> LoginCode -> AppIO Bool +verifyLoginCode :: UserId -> LoginCode -> (AppIO r) Bool verifyLoginCode u c = do code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) now <- liftIO =<< view currentTime @@ -67,7 +67,7 @@ verifyLoginCode u c = do Just (_, _, _) -> deleteLoginCode u >> return False Nothing -> return False -lookupLoginCode :: UserId -> AppIO (Maybe PendingLoginCode) +lookupLoginCode :: UserId -> (AppIO r) (Maybe PendingLoginCode) lookupLoginCode u = do now <- liftIO =<< view currentTime validate now =<< retry x1 (query1 codeSelect (params LocalQuorum (Identity u))) @@ -77,10 +77,10 @@ lookupLoginCode u = do pending c now t = PendingLoginCode c (timeout now t) timeout now t = Timeout (t `diffUTCTime` now) -deleteLoginCode :: UserId -> AppIO () +deleteLoginCode :: UserId -> (AppIO r) () deleteLoginCode u = retry x5 . write codeDelete $ params LocalQuorum (Identity u) -insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> AppIO () +insertLoginCode :: UserId -> LoginCode -> Int32 -> UTCTime -> (AppIO r) () 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 98295204b17..942d14f4065 100644 --- a/services/brig/src/Brig/Data/PasswordReset.hs +++ b/services/brig/src/Brig/Data/PasswordReset.hs @@ -48,7 +48,7 @@ maxAttempts = 3 ttl :: NominalDiffTime ttl = 3600 -- 60 minutes -createPasswordResetCode :: UserId -> Either Email Phone -> AppIO PasswordResetPair +createPasswordResetCode :: UserId -> Either Email Phone -> (AppIO r) PasswordResetPair createPasswordResetCode u target = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -61,7 +61,7 @@ createPasswordResetCode u target = do PasswordResetCode . Ascii.unsafeFromText . pack . printf "%06d" <$> randIntegerZeroToNMinusOne 1000000 -lookupPasswordResetCode :: UserId -> AppIO (Maybe PasswordResetCode) +lookupPasswordResetCode :: UserId -> (AppIO r) (Maybe PasswordResetCode) lookupPasswordResetCode u = do key <- liftIO $ mkPasswordResetKey u now <- liftIO =<< view currentTime @@ -70,7 +70,7 @@ lookupPasswordResetCode u = do validate now (Just (c, _, _, Just t)) | t > now = return $ Just c validate _ _ = return Nothing -verifyPasswordResetCode :: PasswordResetPair -> AppIO (Maybe UserId) +verifyPasswordResetCode :: PasswordResetPair -> (AppIO r) (Maybe UserId) verifyPasswordResetCode (k, c) = do now <- liftIO =<< view currentTime code <- retry x1 (query1 codeSelect (params LocalQuorum (Identity k))) @@ -84,7 +84,7 @@ verifyPasswordResetCode (k, c) = do where countdown = retry x5 . write codeInsert . params LocalQuorum -deletePasswordResetCode :: PasswordResetKey -> AppIO () +deletePasswordResetCode :: PasswordResetKey -> (AppIO r) () deletePasswordResetCode k = retry x5 . write codeDelete $ params LocalQuorum (Identity k) mkPasswordResetKey :: (MonadIO m) => UserId -> m PasswordResetKey diff --git a/services/brig/src/Brig/Data/Properties.hs b/services/brig/src/Brig/Data/Properties.hs index 822df183aa2..5ec00292621 100644 --- a/services/brig/src/Brig/Data/Properties.hs +++ b/services/brig/src/Brig/Data/Properties.hs @@ -40,30 +40,30 @@ maxProperties = 16 data PropertiesDataError = TooManyProperties -insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError AppIO () +insertProperty :: UserId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppIO r) () insertProperty u k v = do 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 LocalQuorum (u, k, v)) -deleteProperty :: UserId -> PropertyKey -> AppIO () +deleteProperty :: UserId -> PropertyKey -> (AppIO r) () deleteProperty u k = retry x5 $ write propertyDelete (params LocalQuorum (u, k)) -clearProperties :: UserId -> AppIO () +clearProperties :: UserId -> (AppIO r) () clearProperties u = retry x5 $ write propertyReset (params LocalQuorum (Identity u)) -lookupProperty :: UserId -> PropertyKey -> AppIO (Maybe PropertyValue) +lookupProperty :: UserId -> PropertyKey -> (AppIO r) (Maybe PropertyValue) lookupProperty u k = fmap runIdentity <$> retry x1 (query1 propertySelect (params LocalQuorum (u, k))) -lookupPropertyKeys :: UserId -> AppIO [PropertyKey] +lookupPropertyKeys :: UserId -> (AppIO r) [PropertyKey] lookupPropertyKeys u = map runIdentity <$> retry x1 (query propertyKeysSelect (params LocalQuorum (Identity u))) -lookupPropertyKeysAndValues :: UserId -> AppIO PropertyKeysAndValues +lookupPropertyKeysAndValues :: UserId -> (AppIO r) PropertyKeysAndValues lookupPropertyKeysAndValues u = PropertyKeysAndValues <$> retry x1 (query propertyKeysValuesSelect (params LocalQuorum (Identity u))) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 55e4c7fd00e..3959dfc3fb0 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -116,7 +116,7 @@ data ReAuthError -- Condition (2.) is essential for maintaining handle uniqueness. It is guaranteed by the -- fact that we're setting getting @mbHandle@ from table @"user"@, and when/if it was added -- there, it was claimed properly. -newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> AppIO (UserAccount, Maybe Password) +newAccount :: NewUser -> Maybe InvitationId -> Maybe TeamId -> Maybe Handle -> (AppIO r) (UserAccount, Maybe Password) newAccount u inv tid mbHandle = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -152,7 +152,7 @@ newAccount u inv tid mbHandle = do managedBy = fromMaybe defaultManagedBy (newUserManagedBy u) user uid domain l e = User uid (Qualified uid domain) ident name pict assets colour False l Nothing mbHandle e tid managedBy -newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> AppIO UserAccount +newAccountInviteViaScim :: UserId -> TeamId -> Maybe Locale -> Name -> Email -> (AppIO r) UserAccount newAccountInviteViaScim uid tid locale name email = do defLoc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain @@ -176,7 +176,7 @@ newAccountInviteViaScim uid tid locale name email = do ManagedByScim -- | Mandatory password authentication. -authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError AppIO () +authenticate :: UserId -> PlainTextPassword -> ExceptT AuthError (AppIO r) () authenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE AuthInvalidUser @@ -217,7 +217,7 @@ insertAccount :: Maybe Password -> -- | Whether the user is activated Bool -> - AppIO () + (AppIO r) () insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -260,10 +260,10 @@ insertAccount (UserAccount u status) mbConv password activated = retry x5 . batc "INSERT INTO service_team (provider, service, user, conv, team) \ \VALUES (?, ?, ?, ?, ?)" -updateLocale :: UserId -> Locale -> AppIO () +updateLocale :: UserId -> Locale -> (AppIO r) () updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) -updateUser :: UserId -> UserUpdate -> AppIO () +updateUser :: UserId -> UserUpdate -> (AppIO r) () updateUser u UserUpdate {..} = retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum @@ -272,13 +272,13 @@ updateUser u UserUpdate {..} = retry x5 . batch $ do for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) -updateEmail :: UserId -> Email -> AppIO () +updateEmail :: UserId -> Email -> (AppIO r) () updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) -updatePhone :: UserId -> Phone -> AppIO () +updatePhone :: UserId -> Phone -> (AppIO r) () updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) -updateSSOId :: UserId -> Maybe UserSSOId -> AppIO Bool +updateSSOId :: UserId -> Maybe UserSSOId -> (AppIO r) Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u case mteamid of @@ -287,21 +287,21 @@ updateSSOId u ssoid = do pure True Nothing -> pure False -updateManagedBy :: UserId -> ManagedBy -> AppIO () +updateManagedBy :: UserId -> ManagedBy -> (AppIO r) () updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) -updateHandle :: UserId -> Handle -> AppIO () +updateHandle :: UserId -> Handle -> (AppIO r) () updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) -updatePassword :: UserId -> PlainTextPassword -> AppIO () +updatePassword :: UserId -> PlainTextPassword -> (AppIO r) () updatePassword u t = do p <- liftIO $ mkSafePassword t retry x5 $ write userPasswordUpdate (params LocalQuorum (p, u)) -updateRichInfo :: UserId -> RichInfoAssocList -> AppIO () +updateRichInfo :: UserId -> RichInfoAssocList -> (AppIO r) () updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) -updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> AppIO (Maybe ApiFt.TeamFeatureStatusNoConfig) +updateFeatureConferenceCalling :: UserId -> Maybe ApiFt.TeamFeatureStatusNoConfig -> (AppIO r) (Maybe ApiFt.TeamFeatureStatusNoConfig) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.tfwoStatus <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) @@ -310,13 +310,13 @@ updateFeatureConferenceCalling uid mbStatus = do update :: PrepQuery W (Maybe ApiFt.TeamFeatureStatusValue, UserId) () update = fromString $ "update user set feature_conference_calling = ? where id = ?" -deleteEmail :: UserId -> AppIO () +deleteEmail :: UserId -> (AppIO r) () deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) -deletePhone :: UserId -> AppIO () +deletePhone :: UserId -> (AppIO r) () deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) -deleteServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO () +deleteServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) () deleteServiceUser pid sid bid = do lookupServiceUser pid sid bid >>= \case Nothing -> pure () @@ -336,17 +336,17 @@ deleteServiceUser pid sid bid = do "DELETE FROM service_team \ \WHERE provider = ? AND service = ? AND team = ? AND user = ?" -updateStatus :: UserId -> AccountStatus -> AppIO () +updateStatus :: UserId -> AccountStatus -> (AppIO r) () 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 :: UserId -> (AppIO r) Bool isActivated u = (== Just (Identity True)) <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) -filterActive :: [UserId] -> AppIO [UserId] +filterActive :: [UserId] -> (AppIO r) [UserId] filterActive us = map (view _1) . filter isActiveUser <$> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity us))) @@ -355,46 +355,46 @@ filterActive us = isActiveUser (_, True, Just Active) = True isActiveUser _ = False -lookupUser :: HavePendingInvitations -> UserId -> AppIO (Maybe User) +lookupUser :: HavePendingInvitations -> UserId -> (AppIO r) (Maybe User) lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] -activateUser :: UserId -> UserIdentity -> AppIO () +activateUser :: UserId -> UserIdentity -> (AppIO r) () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) -deactivateUser :: UserId -> AppIO () +deactivateUser :: UserId -> (AppIO r) () deactivateUser u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) -lookupLocale :: UserId -> AppIO (Maybe Locale) +lookupLocale :: UserId -> (AppIO r) (Maybe Locale) lookupLocale u = do defLoc <- setDefaultUserLocale <$> view settings fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) -lookupName :: UserId -> AppIO (Maybe Name) +lookupName :: UserId -> (AppIO r) (Maybe Name) lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) -lookupPassword :: UserId -> AppIO (Maybe Password) +lookupPassword :: UserId -> (AppIO r) (Maybe Password) lookupPassword u = join . fmap runIdentity <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity u))) -lookupStatus :: UserId -> AppIO (Maybe AccountStatus) +lookupStatus :: UserId -> (AppIO r) (Maybe AccountStatus) lookupStatus u = join . fmap runIdentity <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity u))) -lookupRichInfo :: UserId -> AppIO (Maybe RichInfoAssocList) +lookupRichInfo :: UserId -> (AppIO r) (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) -- | Returned rich infos are in the same order as users -lookupRichInfoMultiUsers :: [UserId] -> AppIO [(UserId, RichInfo)] +lookupRichInfoMultiUsers :: [UserId] -> (AppIO r) [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do mapMaybe (\(uid, mbRi) -> (uid,) . RichInfo <$> mbRi) <$> retry x1 (query richInfoSelectMulti (params LocalQuorum (Identity users))) @@ -402,7 +402,7 @@ lookupRichInfoMultiUsers users = do -- | 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* -- successful login. -lookupUserTeam :: UserId -> AppIO (Maybe TeamId) +lookupUserTeam :: UserId -> (AppIO r) (Maybe TeamId) lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) @@ -415,22 +415,22 @@ lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Ident -- | Return users with given IDs. -- -- Skips nonexistent users. /Does not/ skip users who have been deleted. -lookupUsers :: HavePendingInvitations -> [UserId] -> AppIO [User] +lookupUsers :: HavePendingInvitations -> [UserId] -> (AppIO r) [User] lookupUsers hpi usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) -lookupAccount :: UserId -> AppIO (Maybe UserAccount) +lookupAccount :: UserId -> (AppIO r) (Maybe UserAccount) lookupAccount u = listToMaybe <$> lookupAccounts [u] -lookupAccounts :: [UserId] -> AppIO [UserAccount] +lookupAccounts :: [UserId] -> (AppIO r) [UserAccount] lookupAccounts usrs = do loc <- setDefaultUserLocale <$> view settings domain <- viewFederationDomain fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) -lookupServiceUser :: ProviderId -> ServiceId -> BotId -> AppIO (Maybe (ConvId, Maybe TeamId)) +lookupServiceUser :: ProviderId -> ServiceId -> BotId -> (AppIO r) (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) @@ -442,7 +442,7 @@ lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, s lookupServiceUsers :: ProviderId -> ServiceId -> - ConduitM () [(BotId, ConvId, Maybe TeamId)] AppIO () + ConduitM () [(BotId, ConvId, Maybe TeamId)] (AppIO r) () lookupServiceUsers pid sid = paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 where @@ -455,7 +455,7 @@ lookupServiceUsersForTeam :: ProviderId -> ServiceId -> TeamId -> - ConduitM () [(BotId, ConvId)] AppIO () + ConduitM () [(BotId, ConvId)] (AppIO r) () lookupServiceUsersForTeam pid sid tid = paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index c8e08659216..f4483c09b9b 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -124,7 +124,7 @@ claimKey :: UserKey -> -- | The user claiming the key. UserId -> - AppIO Bool + (AppIO r) Bool claimKey k u = do free <- keyAvailable k (Just u) when free (insertKey u k) @@ -138,7 +138,7 @@ keyAvailable :: UserKey -> -- | The user looking to claim the key, if any. Maybe UserId -> - AppIO Bool + (AppIO r) Bool keyAvailable k u = do o <- lookupKey k case (o, u) of @@ -146,32 +146,32 @@ keyAvailable k u = do (Just x, Just y) | x == y -> return True (Just x, _) -> not <$> User.isActivated x -lookupKey :: UserKey -> AppIO (Maybe UserId) +lookupKey :: UserKey -> (AppIO r) (Maybe UserId) lookupKey k = fmap runIdentity <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) -insertKey :: UserId -> UserKey -> AppIO () +insertKey :: UserId -> UserKey -> (AppIO r) () insertKey u k = do hk <- hashKey k let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) -deleteKey :: UserKey -> AppIO () +deleteKey :: UserKey -> (AppIO r) () deleteKey k = do hk <- hashKey k retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) -hashKey :: UserKey -> AppIO UserKeyHash +hashKey :: UserKey -> (AppIO r) UserKeyHash hashKey uk = do d <- view digestSHA256 let d' = digestBS d $ T.encodeUtf8 (keyText uk) return . UserKeyHash $ MH.MultihashDigest MH.SHA256 (B.length d') d' -lookupPhoneHashes :: [ByteString] -> AppIO [(ByteString, UserId)] +lookupPhoneHashes :: [ByteString] -> (AppIO r) [(ByteString, UserId)] lookupPhoneHashes hp = mapMaybe mk <$> retry x1 (query selectHashed (params One (Identity hashed))) where diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 4a11f83c1d6..2f1222194d7 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -38,14 +38,14 @@ data UserPendingActivation = UserPendingActivation } deriving stock (Eq, Show, Ord) -usersPendingActivationAdd :: UserPendingActivation -> AppIO () +usersPendingActivationAdd :: UserPendingActivation -> (AppIO r) () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do 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 :: (AppIO r) (Page UserPendingActivation) usersPendingActivationList = do uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params LocalQuorum ())) where @@ -53,10 +53,10 @@ usersPendingActivationList = do selectExpired = "SELECT user, expires_at FROM users_pending_activation" -usersPendingActivationRemove :: UserId -> AppIO () +usersPendingActivationRemove :: UserId -> (AppIO r) () usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] -usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () +usersPendingActivationRemoveMultiple :: [UserId] -> (AppIO r) () usersPendingActivationRemoveMultiple uids = retry x5 . write deleteExpired . params LocalQuorum $ (Identity uids) where diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index fa6253c1eb6..a411875b493 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -49,7 +49,7 @@ import Imports import Network.Mail.Mime ------------------------------------------------------------------------------- -sendMail :: Mail -> AppIO () +sendMail :: Mail -> (AppIO r) () sendMail m = view smtpEnv >>= \case Just smtp -> SMTP.sendMail smtp m diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 73cec62b241..ade024d4442 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -50,24 +51,24 @@ import Wire.API.User.Client (UserClientPrekeyMap) import Wire.API.User.Client.Prekey (ClientPrekey) import Wire.API.UserMap (UserMap) -type FederationAppIO = ExceptT FederationError AppIO +type FederationAppIO r = ExceptT FederationError (AppIO r) -getUserHandleInfo :: Remote Handle -> FederationAppIO (Maybe UserProfile) +getUserHandleInfo :: Remote Handle -> (FederationAppIO r) (Maybe UserProfile) getUserHandleInfo (qUntagged -> Qualified handle domain) = do Log.info $ Log.msg $ T.pack "Brig-federation: handle lookup call on remote backend" executeFederated @"get-user-by-handle" domain handle -getUsersByIds :: Domain -> [UserId] -> FederationAppIO [UserProfile] +getUsersByIds :: Domain -> [UserId] -> (FederationAppIO r) [UserProfile] getUsersByIds domain uids = do Log.info $ Log.msg ("Brig-federation: get users by ids on remote backends" :: ByteString) executeFederated @"get-users-by-ids" domain uids -claimPrekey :: Qualified UserId -> ClientId -> FederationAppIO (Maybe ClientPrekey) +claimPrekey :: Qualified UserId -> ClientId -> (FederationAppIO r) (Maybe ClientPrekey) claimPrekey (Qualified user domain) client = do Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey" executeFederated @"claim-prekey" domain (user, client) -claimPrekeyBundle :: Qualified UserId -> FederationAppIO PrekeyBundle +claimPrekeyBundle :: Qualified UserId -> (FederationAppIO r) PrekeyBundle claimPrekeyBundle (Qualified user domain) = do Log.info $ Log.msg @Text "Brig-federation: claiming remote prekey bundle" executeFederated @"claim-prekey-bundle" domain user @@ -75,17 +76,17 @@ claimPrekeyBundle (Qualified user domain) = do claimMultiPrekeyBundle :: Domain -> UserClients -> - FederationAppIO UserClientPrekeyMap + (FederationAppIO r) UserClientPrekeyMap claimMultiPrekeyBundle domain uc = do Log.info $ Log.msg @Text "Brig-federation: claiming remote multi-user prekey bundle" executeFederated @"claim-multi-prekey-bundle" domain uc -searchUsers :: Domain -> SearchRequest -> FederationAppIO [Public.Contact] +searchUsers :: Domain -> SearchRequest -> (FederationAppIO r) [Public.Contact] searchUsers domain searchTerm = do Log.info $ Log.msg $ T.pack "Brig-federation: search call on remote backend" executeFederated @"search-users" domain searchTerm -getUserClients :: Domain -> GetUserClients -> FederationAppIO (UserMap (Set PubClient)) +getUserClients :: Domain -> GetUserClients -> (FederationAppIO r) (UserMap (Set PubClient)) getUserClients domain guc = do Log.info $ Log.msg @Text "Brig-federation: get users' clients from remote backend" executeFederated @"get-user-clients" domain guc @@ -94,7 +95,7 @@ sendConnectionAction :: Local UserId -> Remote UserId -> RemoteConnectionAction -> - FederationAppIO NewConnectionResponse + (FederationAppIO r) NewConnectionResponse sendConnectionAction self (qUntagged -> other) action = do let req = NewConnectionRequest (tUnqualified self) (qUnqualified other) action Log.info $ Log.msg @Text "Brig-federation: sending connection action to remote backend" @@ -103,14 +104,14 @@ sendConnectionAction self (qUntagged -> other) action = do notifyUserDeleted :: Local UserId -> Remote (Range 1 1000 [UserId]) -> - FederationAppIO () + (FederationAppIO r) () notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes void $ executeFederated @"on-user-deleted-connections" (tDomain remotes) $ UserDeletedConnectionsNotification (tUnqualified self) remoteConnections -runBrigFederatorClient :: Domain -> FederatorClient 'Brig a -> FederationAppIO a +runBrigFederatorClient :: Domain -> FederatorClient 'Brig a -> (FederationAppIO r) a runBrigFederatorClient targetDomain action = do ownDomain <- viewFederationDomain endpoint <- view federator >>= maybe (throwE FederationNotConfigured) pure @@ -124,13 +125,13 @@ runBrigFederatorClient targetDomain action = do >>= either (throwE . FederationCallFailure) pure executeFederated :: - forall (name :: Symbol) api. + forall (name :: Symbol) api r. ( HasFedEndpoint 'Brig api name, HasClient ClientM api, HasClient (FederatorClient 'Brig) api ) => Domain -> - Client FederationAppIO api + Client (FederationAppIO r) api executeFederated domain = - hoistClient (Proxy @api) (runBrigFederatorClient domain) $ + hoistClient (Proxy @api) (runBrigFederatorClient @_ @r domain) $ clientIn (Proxy @api) (Proxy @(FederatorClient 'Brig)) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 5568bb9171a..2aa0c9cdd88 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -127,7 +127,7 @@ import qualified Wire.API.Team.Member as Member ----------------------------------------------------------------------------- -- Event Handlers -onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> AppIO () +onUserEvent :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () onUserEvent orig conn e = updateSearchIndex orig e *> dispatchNotifications orig conn e @@ -140,7 +140,7 @@ onConnectionEvent :: Maybe ConnId -> -- | The event. ConnectionEvent -> - AppIO () + (AppIO r) () onConnectionEvent orig conn evt = do let from = ucFrom (ucConn evt) notify @@ -156,7 +156,7 @@ onPropertyEvent :: -- | Client connection ID. ConnId -> PropertyEvent -> - AppIO () + (AppIO r) () onPropertyEvent orig conn e = notify (singleton $ PropertyEvent e) @@ -172,7 +172,7 @@ onClientEvent :: Maybe ConnId -> -- | The event. ClientEvent -> - AppIO () + (AppIO r) () onClientEvent orig conn e = do let events = singleton (ClientEvent e) let rcps = list1 orig [] @@ -181,7 +181,7 @@ onClientEvent orig conn e = do -- in the stream. push events rcps orig Push.RouteAny conn -updateSearchIndex :: UserId -> UserEvent -> AppIO () +updateSearchIndex :: UserId -> UserEvent -> (AppIO r) () updateSearchIndex orig e = case e of -- no-ops UserCreated {} -> return () @@ -206,7 +206,7 @@ updateSearchIndex orig e = case e of ] when interesting $ Search.reindex orig -journalEvent :: UserId -> UserEvent -> AppIO () +journalEvent :: UserId -> UserEvent -> (AppIO r) () journalEvent orig e = case e of UserActivated acc -> Journal.userActivate acc @@ -229,7 +229,7 @@ journalEvent orig e = case e of -- | Notify the origin user's contact list (first-level contacts), -- as well as his other clients about a change to his user account -- or profile. -dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> AppIO () +dispatchNotifications :: UserId -> Maybe ConnId -> UserEvent -> (AppIO r) () dispatchNotifications orig conn e = case e of UserCreated {} -> return () UserSuspended {} -> return () @@ -252,21 +252,21 @@ dispatchNotifications orig conn e = case e of where event = singleton $ UserEvent e -notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> AppIO () +notifyUserDeletionLocals :: UserId -> Maybe ConnId -> List1 Event -> (AppIO r) () notifyUserDeletionLocals deleted conn event = do recipients <- list1 deleted <$> lookupContactList deleted notify event deleted Push.RouteDirect conn (pure recipients) -notifyUserDeletionRemotes :: UserId -> AppIO () +notifyUserDeletionRemotes :: UserId -> (AppIO r) () notifyUserDeletionRemotes deleted = do runConduit $ Data.lookupRemoteConnectedUsersC deleted (fromInteger (natVal (Proxy @UserDeletedNotificationMaxConnections))) .| C.mapM_ fanoutNotifications where - fanoutNotifications :: [Remote UserId] -> AppIO () + fanoutNotifications :: [Remote UserId] -> (AppIO r) () fanoutNotifications = mapM_ notifyBackend . bucketRemote - notifyBackend :: Remote [UserId] -> AppIO () + notifyBackend :: Remote [UserId] -> (AppIO r) () notifyBackend uids = do case tUnqualified (checked <$> uids) of Nothing -> @@ -279,7 +279,7 @@ notifyUserDeletionRemotes deleted = do whenLeft eitherFErr $ logFederationError (tDomain uids) - logFederationError :: Domain -> FederationError -> AppT IO () + logFederationError :: Domain -> FederationError -> AppT r IO () logFederationError domain fErr = Log.err $ Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) @@ -299,7 +299,7 @@ push :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - AppIO () + (AppIO r) () push (toList -> events) usrs orig route conn = case mapMaybe toPushData events of [] -> pure () @@ -323,7 +323,7 @@ rawPush :: Push.Route -> -- | The originating device connection. Maybe ConnId -> - AppIO () + (AppIO r) () -- TODO: if we decide to have service whitelist events in Brig instead of -- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. rawPush (toList -> events) usrs orig route conn = do @@ -368,7 +368,7 @@ notify :: Maybe ConnId -> -- | Users to notify. IO (List1 UserId) -> - AppIO () + (AppIO r) () notify events orig route conn recipients = forkAppIO (Just orig) $ do rs <- liftIO recipients push events rs orig route conn @@ -381,7 +381,7 @@ notifySelf :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - AppIO () + (AppIO r) () notifySelf events orig route conn = notify events orig route conn (pure (singleton orig)) @@ -393,19 +393,19 @@ notifyContacts :: Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - AppIO () + (AppIO r) () notifyContacts events orig route conn = do env <- ask notify events orig route conn $ runAppT env $ list1 orig <$> liftA2 (++) contacts teamContacts where - contacts :: AppIO [UserId] + contacts :: (AppIO r) [UserId] contacts = lookupContactList orig - teamContacts :: AppIO [UserId] + teamContacts :: (AppIO r) [UserId] teamContacts = screenMemberList =<< getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts - screenMemberList :: Maybe Team.TeamMemberList -> AppIO [UserId] + screenMemberList :: Maybe Team.TeamMemberList -> (AppIO r) [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = return $ fmap (view Team.userId) (mems ^. Team.teamMembers) @@ -572,7 +572,7 @@ toApsData _ = Nothing -- Conversation Management -- | Calls 'Galley.API.createSelfConversationH'. -createSelfConv :: UserId -> AppIO () +createSelfConv :: UserId -> (AppIO r) () createSelfConv u = do debug $ remote "galley" @@ -590,7 +590,7 @@ createLocalConnectConv :: Local UserId -> Maybe Text -> Maybe ConnId -> - AppIO ConvId + (AppIO r) ConvId createLocalConnectConv from to cname conn = do debug $ logConnection (tUnqualified from) (qUntagged to) @@ -613,20 +613,20 @@ createConnectConv :: Qualified UserId -> Maybe Text -> Maybe ConnId -> - AppIO (Qualified ConvId) + (AppIO r) (Qualified ConvId) createConnectConv from to cname conn = do lfrom <- ensureLocal from lto <- ensureLocal to qUntagged . qualifyAs lfrom <$> createLocalConnectConv lfrom lto cname conn where - ensureLocal :: Qualified a -> AppIO (Local a) + ensureLocal :: Qualified a -> (AppIO r) (Local a) ensureLocal x = do loc <- qualifyLocal () foldQualified loc pure (\_ -> throwM federationNotImplemented) x -- | Calls 'Galley.API.acceptConvH'. -acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +acceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation acceptLocalConnectConv from conn cnv = do debug $ remote "galley" @@ -640,7 +640,7 @@ acceptLocalConnectConv from conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +acceptConnectConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation acceptConnectConv from conn = foldQualified from @@ -648,7 +648,7 @@ acceptConnectConv from conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.blockConvH'. -blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO () +blockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) () blockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -662,7 +662,7 @@ blockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO () +blockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) () blockConv lusr conn = foldQualified lusr @@ -670,7 +670,7 @@ blockConv lusr conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.unblockConvH'. -unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> AppIO Conversation +unblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> (AppIO r) Conversation unblockLocalConv lusr conn cnv = do debug $ remote "galley" @@ -684,7 +684,7 @@ unblockLocalConv lusr conn cnv = do . maybe id (header "Z-Connection" . fromConnId) conn . expect2xx -unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> AppIO Conversation +unblockConv :: Local UserId -> Maybe ConnId -> Qualified ConvId -> (AppIO r) Conversation unblockConv luid conn = foldQualified luid @@ -692,7 +692,7 @@ unblockConv luid conn = (const (throwM federationNotImplemented)) -- | Calls 'Galley.API.getConversationH'. -getConv :: UserId -> ConvId -> AppIO (Maybe Conversation) +getConv :: UserId -> ConvId -> (AppIO r) (Maybe Conversation) getConv usr cnv = do debug $ remote "galley" @@ -708,7 +708,7 @@ getConv usr cnv = do . zUser usr . expect [status200, status404] -upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> AppIO UpsertOne2OneConversationResponse +upsertOne2OneConversation :: UpsertOne2OneConversationRequest -> (AppIO r) UpsertOne2OneConversationResponse upsertOne2OneConversation urequest = do response <- galleyRequest POST req case Bilge.statusCode response of @@ -721,7 +721,7 @@ upsertOne2OneConversation urequest = do . lbytes (encode urequest) -- | Calls 'Galley.API.getTeamConversationH'. -getTeamConv :: UserId -> TeamId -> ConvId -> AppIO (Maybe Team.TeamConversation) +getTeamConv :: UserId -> TeamId -> ConvId -> (AppIO r) (Maybe Team.TeamConversation) getTeamConv usr tid cnv = do debug $ remote "galley" @@ -741,7 +741,7 @@ getTeamConv usr tid cnv = do -- User management -- | Calls 'Galley.API.rmUserH', as well as gundeck and cargohold. -rmUser :: UserId -> [Asset] -> AppIO () +rmUser :: UserId -> [Asset] -> (AppIO r) () rmUser usr asts = do debug $ remote "gundeck" @@ -767,7 +767,7 @@ rmUser usr asts = do -- Client management -- | Calls 'Galley.API.addClientH'. -newClient :: UserId -> ClientId -> AppIO () +newClient :: UserId -> ClientId -> (AppIO r) () newClient u c = do debug $ remote "galley" @@ -778,7 +778,7 @@ newClient u c = do void $ galleyRequest POST (p . zUser u . expect2xx) -- | Calls 'Galley.API.rmClientH', as well as gundeck. -rmClient :: UserId -> ClientId -> AppIO () +rmClient :: UserId -> ClientId -> (AppIO r) () rmClient u c = do let cid = toByteString' c debug $ @@ -808,7 +808,7 @@ rmClient u c = do where expected = [status200, status204, status404] -lookupPushToken :: UserId -> AppIO [Push.PushToken] +lookupPushToken :: UserId -> (AppIO r) [Push.PushToken] lookupPushToken uid = do g <- view gundeck rsp <- @@ -826,7 +826,7 @@ lookupPushToken uid = do -- Team Management -- | Calls 'Galley.API.canUserJoinTeamH'. -checkUserCanJoinTeam :: TeamId -> AppIO (Maybe Wai.Error) +checkUserCanJoinTeam :: TeamId -> (AppIO r) (Maybe Wai.Error) checkUserCanJoinTeam tid = do debug $ remote "galley" @@ -843,7 +843,7 @@ checkUserCanJoinTeam tid = do . header "Content-Type" "application/json" -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. -addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> AppIO Bool +addTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Team.Role) -> (AppIO r) Bool addTeamMember u tid (minvmeta, role) = do debug $ remote "galley" @@ -863,7 +863,7 @@ addTeamMember u tid (minvmeta, role) = do . lbytes (encode bdy) -- | Calls 'Galley.API.createBindingTeamH'. -createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> AppIO CreateUserTeam +createTeam :: UserId -> Team.BindingNewTeam -> TeamId -> (AppIO r) CreateUserTeam createTeam u t@(Team.BindingNewTeam bt) teamid = do debug $ remote "galley" @@ -883,7 +883,7 @@ createTeam u t@(Team.BindingNewTeam bt) teamid = do . lbytes (encode t) -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. -getTeamMember :: UserId -> TeamId -> AppIO (Maybe Team.TeamMember) +getTeamMember :: UserId -> TeamId -> (AppIO r) (Maybe Team.TeamMember) getTeamMember u tid = do debug $ remote "galley" @@ -903,7 +903,7 @@ getTeamMember u tid = do -- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which -- means that only the first 2000 members of a team (according to some arbitrary order) will -- be suspended, and the rest will remain active. -getTeamMembers :: TeamId -> AppIO Team.TeamMemberList +getTeamMembers :: TeamId -> (AppIO r) Team.TeamMemberList getTeamMembers tid = do debug $ remote "galley" . msg (val "Get team members") galleyRequest GET req >>= decodeBody "galley" @@ -912,7 +912,7 @@ getTeamMembers tid = do paths ["i", "teams", toByteString' tid, "members"] . expect2xx -memberIsTeamOwner :: TeamId -> UserId -> AppIO Bool +memberIsTeamOwner :: TeamId -> UserId -> (AppIO r) Bool memberIsTeamOwner tid uid = do r <- galleyRequest GET $ @@ -922,7 +922,7 @@ memberIsTeamOwner tid uid = do -- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. -- -- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: UserId -> AppIO (Maybe Team.TeamMemberList) +getTeamContacts :: UserId -> (AppIO r) (Maybe Team.TeamMemberList) getTeamContacts u = do debug $ remote "galley" . msg (val "Get team contacts") rs <- galleyRequest GET req @@ -935,7 +935,7 @@ getTeamContacts u = do . expect [status200, status404] -- | Calls 'Galley.API.getBindingTeamIdH'. -getTeamId :: UserId -> AppIO (Maybe TeamId) +getTeamId :: UserId -> (AppIO r) (Maybe TeamId) getTeamId u = do debug $ remote "galley" . msg (val "Get team from user") rs <- galleyRequest GET req @@ -948,7 +948,7 @@ getTeamId u = do . expect [status200, status404] -- | Calls 'Galley.API.getTeamInternalH'. -getTeam :: TeamId -> AppIO Team.TeamData +getTeam :: TeamId -> (AppIO r) Team.TeamData getTeam tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -958,7 +958,7 @@ getTeam tid = do . expect2xx -- | Calls 'Galley.API.getTeamInternalH'. -getTeamName :: TeamId -> AppIO Team.TeamName +getTeamName :: TeamId -> (AppIO r) Team.TeamName getTeamName tid = do debug $ remote "galley" . msg (val "Get team info") galleyRequest GET req >>= decodeBody "galley" @@ -968,7 +968,7 @@ getTeamName tid = do . expect2xx -- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: TeamId -> AppIO (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) +getTeamLegalHoldStatus :: TeamId -> (AppIO r) (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureLegalHold) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest GET req >>= decodeBody "galley" @@ -978,7 +978,7 @@ getTeamLegalHoldStatus tid = do . expect2xx -- | Calls 'Galley.API.getSearchVisibilityInternalH'. -getTeamSearchVisibility :: TeamId -> AppIO Team.TeamSearchVisibility +getTeamSearchVisibility :: TeamId -> (AppIO r) Team.TeamSearchVisibility getTeamSearchVisibility tid = coerce @Team.TeamSearchVisibilityView @Team.TeamSearchVisibility <$> do debug $ remote "galley" . msg (val "Get search visibility settings") @@ -989,7 +989,7 @@ getTeamSearchVisibility tid = . expect2xx -- | Calls 'Galley.API.updateTeamStatusH'. -changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> AppIO () +changeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> (AppIO r) () changeTeamStatus tid s cur = do debug $ remote "galley" . msg (val "Change Team status") void $ galleyRequest PUT req @@ -1000,7 +1000,7 @@ changeTeamStatus tid s cur = do . expect2xx . lbytes (encode $ Team.TeamStatusUpdate s cur) -guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError AppIO () +guardLegalhold :: LegalholdProtectee -> UserClients -> ExceptT ClientError (AppIO r) () guardLegalhold protectee userClients = do res <- lift $ galleyRequest PUT req case Bilge.statusCode res of diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs index 3a2aaf1d37b..7703eb03e36 100644 --- a/services/brig/src/Brig/IO/Journal.hs +++ b/services/brig/src/Brig/IO/Journal.hs @@ -47,19 +47,19 @@ import qualified Proto.UserEvents_Fields as U -- User journal operations to SQS are a no-op when the service is started -- without journaling arguments for user updates -userActivate :: User -> AppIO () +userActivate :: User -> (AppIO r) () userActivate u@User {..} = journalEvent UserEvent'USER_ACTIVATE userId (userEmail u) (Just userLocale) userTeam (Just userDisplayName) -userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> AppIO () +userUpdate :: UserId -> Maybe Email -> Maybe Locale -> Maybe Name -> (AppIO r) () userUpdate uid em loc nm = journalEvent UserEvent'USER_UPDATE uid em loc Nothing nm -userEmailRemove :: UserId -> Email -> AppIO () +userEmailRemove :: UserId -> Email -> (AppIO r) () userEmailRemove uid em = journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing -userDelete :: UserId -> AppIO () +userDelete :: UserId -> (AppIO r) () userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing -journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> AppIO () +journalEvent :: UserEvent'EventType -> UserId -> Maybe Email -> Maybe Locale -> Maybe TeamId -> Maybe Name -> (AppIO r) () journalEvent typ uid em loc tid nm = view awsEnv >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do ts <- now diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index c2b3b8109e6..60b3b8d92f1 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -36,7 +36,7 @@ import UnliftIO (timeout) -- | Handle an internal event. -- -- Has a one-minute timeout that should be enough for anything that it does. -onEvent :: InternalNotification -> AppIO () +onEvent :: InternalNotification -> (AppIO r) () onEvent n = handleTimeout $ case n of DeleteUser uid -> do Log.info $ diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index c3de7fe9508..81df86b45e1 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -73,7 +73,7 @@ data PhoneException instance Exception PhoneException -sendCall :: Nexmo.Call -> AppIO () +sendCall :: forall r. Nexmo.Call -> AppIO r () sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do m <- view httpManager cred <- view nexmoCreds @@ -99,9 +99,9 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do Nexmo.CallInternal -> True _ -> False ] - unreachable :: Nexmo.CallErrorResponse -> AppT IO () + unreachable :: Nexmo.CallErrorResponse -> AppT r IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Nexmo.CallErrorResponse -> AppT IO () + barred :: Nexmo.CallErrorResponse -> AppT r IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -109,7 +109,7 @@ sendCall call = unless (isTestPhone $ Nexmo.callTo call) $ do ~~ field "error" (show ex) ~~ field "phone" (Nexmo.callTo call) -sendSms :: Locale -> SMSMessage -> AppIO () +sendSms :: forall r. Locale -> SMSMessage -> (AppIO r) () sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do m <- view httpManager withSmsBudget smsTo $ do @@ -132,7 +132,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do _ -> throwM ex' Right () -> return () where - sendNexmoSms :: Manager -> AppIO () + sendNexmoSms :: Manager -> (AppIO r) () sendNexmoSms mgr = do crd <- view nexmoCreds void . liftIO . recovering x3 nexmoHandlers $ @@ -149,7 +149,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do ES -> Nexmo.UCS2 ZH -> Nexmo.UCS2 _ -> Nexmo.GSM7 - sendTwilioSms :: Manager -> AppIO () + sendTwilioSms :: Manager -> (AppIO r) () sendTwilioSms mgr = do crd <- view twilioCreds void . liftIO . recovering x3 twilioHandlers $ @@ -179,9 +179,9 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do 20503 -> True -- Temporarily Unavailable _ -> False ] - unreachable :: Twilio.ErrorResponse -> AppT IO () + unreachable :: Twilio.ErrorResponse -> AppT r IO () unreachable ex = warn (toException ex) >> throwM PhoneNumberUnreachable - barred :: Twilio.ErrorResponse -> AppT IO () + barred :: Twilio.ErrorResponse -> AppT r IO () barred ex = warn (toException ex) >> throwM PhoneNumberBarred warn ex = Log.warn $ @@ -194,7 +194,7 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do -- | Validate a phone number. Returns the canonical -- E.164 format of the given phone number on success. -validatePhone :: Phone -> AppIO (Maybe Phone) +validatePhone :: Phone -> (AppIO r) (Maybe Phone) validatePhone (Phone p) | isTestPhone p = return (Just (Phone p)) | otherwise = do @@ -223,7 +223,7 @@ smsBudget = budgetValue = 5 -- # of SMS within timeout } -withSmsBudget :: Text -> AppIO a -> AppIO a +withSmsBudget :: Text -> (AppIO r) a -> (AppIO r) a withSmsBudget phone go = do let k = BudgetKey ("sms#" <> phone) r <- withBudget k smsBudget go @@ -251,7 +251,7 @@ callBudget = budgetValue = 2 -- # of voice calls within timeout } -withCallBudget :: Text -> AppIO a -> AppIO a +withCallBudget :: Text -> (AppIO r) a -> (AppIO r) a withCallBudget phone go = do let k = BudgetKey ("call#" <> phone) r <- withBudget k callBudget go diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 774532db7f7..8c506996626 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -108,7 +108,7 @@ import qualified Wire.API.User.Client as Public (Client, ClientCapability (Clien import qualified Wire.API.User.Client.Prekey as Public (PrekeyId) import qualified Wire.API.User.Identity as Public (Email) -routesPublic :: Routes Doc.ApiBuilder Handler () +routesPublic :: Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Public API (Unauthenticated) -------------------------------------------- @@ -307,7 +307,7 @@ routesPublic = do .&> zauth ZAuthBot .&> capture "uid" -routesInternal :: Routes a Handler () +routesInternal :: Routes a (Handler r) () routesInternal = do get "/i/provider/activation-code" (continue getActivationCodeH) $ accept "application" "json" @@ -316,11 +316,11 @@ routesInternal = do -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccountH :: JsonRequest Public.NewProvider -> Handler Response +newAccountH :: JsonRequest Public.NewProvider -> (Handler r) Response newAccountH req = do setStatus status201 . json <$> (newAccount =<< parseJsonBody req) -newAccount :: Public.NewProvider -> Handler Public.NewProviderResponse +newAccount :: Public.NewProvider -> (Handler r) Public.NewProviderResponse newAccount new = do email <- case validateEmail (Public.newProviderEmail new) of Right em -> return em @@ -352,11 +352,11 @@ newAccount new = do lift $ sendActivationMail name email key val False return $ Public.NewProviderResponse pid newPass -activateAccountKeyH :: Code.Key ::: Code.Value -> Handler Response +activateAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response activateAccountKeyH (key ::: val) = do maybe (setStatus status204 empty) json <$> activateAccountKey key val -activateAccountKey :: Code.Key -> Code.Value -> Handler (Maybe Public.ProviderActivationResponse) +activateAccountKey :: Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do c <- Code.verify key Code.IdentityVerification val >>= maybeInvalidCode (pid, email) <- case (Code.codeAccount c, Code.codeForEmail c) of @@ -378,11 +378,11 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email return . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Public.Email -> Handler Response +getActivationCodeH :: Public.Email -> (Handler r) Response getActivationCodeH e = do json <$> getActivationCode e -getActivationCode :: Public.Email -> Handler FoundActivationCode +getActivationCode :: Public.Email -> (Handler r) FoundActivationCode getActivationCode e = do email <- case validateEmail e of Right em -> return em @@ -398,11 +398,11 @@ instance ToJSON FoundActivationCode where toJSON $ Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) -approveAccountKeyH :: Code.Key ::: Code.Value -> Handler Response +approveAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response approveAccountKeyH (key ::: val) = do empty <$ approveAccountKey key val -approveAccountKey :: Code.Key -> Code.Value -> Handler () +approveAccountKey :: Code.Key -> Code.Value -> (Handler r) () approveAccountKey key val = do c <- Code.verify key Code.AccountApproval val >>= maybeInvalidCode case (Code.codeAccount c, Code.codeForEmail c) of @@ -412,12 +412,12 @@ approveAccountKey key val = do lift $ sendApprovalConfirmMail name email _ -> throwErrorDescriptionType @InvalidCode -loginH :: JsonRequest Public.ProviderLogin -> Handler Response +loginH :: JsonRequest Public.ProviderLogin -> (Handler r) Response loginH req = do tok <- login =<< parseJsonBody req setProviderCookie tok empty -login :: Public.ProviderLogin -> Handler ZAuth.ProviderToken +login :: Public.ProviderLogin -> (Handler r) ZAuth.ProviderToken login l = do pid <- DB.lookupKey (mkEmailKey (providerLoginEmail l)) >>= maybeBadCredentials pass <- DB.lookupPassword pid >>= maybeBadCredentials @@ -425,11 +425,11 @@ login l = do throwErrorDescriptionType @BadCredentials ZAuth.newProviderToken pid -beginPasswordResetH :: JsonRequest Public.PasswordReset -> Handler Response +beginPasswordResetH :: JsonRequest Public.PasswordReset -> (Handler r) Response beginPasswordResetH req = do setStatus status201 empty <$ (beginPasswordReset =<< parseJsonBody req) -beginPasswordReset :: Public.PasswordReset -> Handler () +beginPasswordReset :: Public.PasswordReset -> (Handler r) () beginPasswordReset (Public.PasswordReset target) = do pid <- DB.lookupKey (mkEmailKey target) >>= maybeBadCredentials gen <- Code.mkGen (Code.ForEmail target) @@ -446,11 +446,11 @@ beginPasswordReset (Public.PasswordReset target) = do Code.insert code lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) -completePasswordResetH :: JsonRequest Public.CompletePasswordReset -> Handler Response +completePasswordResetH :: JsonRequest Public.CompletePasswordReset -> (Handler r) Response completePasswordResetH req = do empty <$ (completePasswordReset =<< parseJsonBody req) -completePasswordReset :: Public.CompletePasswordReset -> Handler () +completePasswordReset :: Public.CompletePasswordReset -> (Handler r) () completePasswordReset (Public.CompletePasswordReset key val newpwd) = do code <- Code.verify key Code.PasswordReset val >>= maybeInvalidCode case Id <$> Code.codeAccount code of @@ -465,21 +465,21 @@ completePasswordReset (Public.CompletePasswordReset key val newpwd) = do -------------------------------------------------------------------------------- -- Provider API -getAccountH :: ProviderId -> Handler Response +getAccountH :: ProviderId -> (Handler r) Response getAccountH pid = do getAccount pid <&> \case Just p -> json p Nothing -> setStatus status404 empty -getAccount :: ProviderId -> Handler (Maybe Public.Provider) +getAccount :: ProviderId -> (Handler r) (Maybe Public.Provider) getAccount pid = do DB.lookupAccount pid -updateAccountProfileH :: ProviderId ::: JsonRequest Public.UpdateProvider -> Handler Response +updateAccountProfileH :: ProviderId ::: JsonRequest Public.UpdateProvider -> (Handler r) Response updateAccountProfileH (pid ::: req) = do empty <$ (updateAccountProfile pid =<< parseJsonBody req) -updateAccountProfile :: ProviderId -> Public.UpdateProvider -> Handler () +updateAccountProfile :: ProviderId -> Public.UpdateProvider -> (Handler r) () updateAccountProfile pid upd = do _ <- DB.lookupAccount pid >>= maybeInvalidProvider DB.updateAccountProfile @@ -488,11 +488,11 @@ updateAccountProfile pid upd = do (updateProviderUrl upd) (updateProviderDescr upd) -updateAccountEmailH :: ProviderId ::: JsonRequest Public.EmailUpdate -> Handler Response +updateAccountEmailH :: ProviderId ::: JsonRequest Public.EmailUpdate -> (Handler r) Response updateAccountEmailH (pid ::: req) = do setStatus status202 empty <$ (updateAccountEmail pid =<< parseJsonBody req) -updateAccountEmail :: ProviderId -> Public.EmailUpdate -> Handler () +updateAccountEmail :: ProviderId -> Public.EmailUpdate -> (Handler r) () updateAccountEmail pid (Public.EmailUpdate new) = do email <- case validateEmail new of Right em -> return em @@ -510,11 +510,11 @@ updateAccountEmail pid (Public.EmailUpdate new) = do Code.insert code lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True -updateAccountPasswordH :: ProviderId ::: JsonRequest Public.PasswordChange -> Handler Response +updateAccountPasswordH :: ProviderId ::: JsonRequest Public.PasswordChange -> (Handler r) Response updateAccountPasswordH (pid ::: req) = do empty <$ (updateAccountPassword pid =<< parseJsonBody req) -updateAccountPassword :: ProviderId -> Public.PasswordChange -> Handler () +updateAccountPassword :: ProviderId -> Public.PasswordChange -> (Handler r) () updateAccountPassword pid upd = do pass <- DB.lookupPassword pid >>= maybeBadCredentials unless (verifyPassword (cpOldPassword upd) pass) $ @@ -523,11 +523,11 @@ updateAccountPassword pid upd = do throwStd newPasswordMustDiffer DB.updateAccountPassword pid (cpNewPassword upd) -addServiceH :: ProviderId ::: JsonRequest Public.NewService -> Handler Response +addServiceH :: ProviderId ::: JsonRequest Public.NewService -> (Handler r) Response addServiceH (pid ::: req) = do setStatus status201 . json <$> (addService pid =<< parseJsonBody req) -addService :: ProviderId -> Public.NewService -> Handler Public.NewServiceResponse +addService :: ProviderId -> Public.NewService -> (Handler r) Public.NewServiceResponse addService pid new = do _ <- DB.lookupAccount pid >>= maybeInvalidProvider let name = newServiceName new @@ -543,25 +543,25 @@ addService pid new = do let rstoken = maybe (Just token) (const Nothing) (newServiceToken new) return $ Public.NewServiceResponse sid rstoken -listServicesH :: ProviderId -> Handler Response +listServicesH :: ProviderId -> (Handler r) Response listServicesH pid = json <$> listServices pid -listServices :: ProviderId -> Handler [Public.Service] +listServices :: ProviderId -> (Handler r) [Public.Service] listServices = DB.listServices -getServiceH :: ProviderId ::: ServiceId -> Handler Response +getServiceH :: ProviderId ::: ServiceId -> (Handler r) Response getServiceH (pid ::: sid) = do json <$> getService pid sid -getService :: ProviderId -> ServiceId -> Handler Public.Service +getService :: ProviderId -> ServiceId -> (Handler r) Public.Service getService pid sid = do DB.lookupService pid sid >>= maybeServiceNotFound -updateServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateService -> Handler Response +updateServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateService -> (Handler r) Response updateServiceH (pid ::: sid ::: req) = do empty <$ (updateService pid sid =<< parseJsonBody req) -updateService :: ProviderId -> ServiceId -> Public.UpdateService -> Handler () +updateService :: ProviderId -> ServiceId -> Public.UpdateService -> (Handler r) () updateService pid sid upd = do _ <- DB.lookupAccount pid >>= maybeInvalidProvider -- Update service profile @@ -578,11 +578,11 @@ updateService pid sid upd = do -- Update service, tags/prefix index if the service is enabled DB.updateService pid sid name tags nameChange newSummary newDescr newAssets tagsChange (serviceEnabled svc) -updateServiceConnH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateServiceConn -> Handler Response +updateServiceConnH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateServiceConn -> (Handler r) Response updateServiceConnH (pid ::: sid ::: req) = do empty <$ (updateServiceConn pid sid =<< parseJsonBody req) -updateServiceConn :: ProviderId -> ServiceId -> Public.UpdateServiceConn -> Handler () +updateServiceConn :: ProviderId -> ServiceId -> Public.UpdateServiceConn -> (Handler r) () updateServiceConn pid sid upd = do pass <- DB.lookupPassword pid >>= maybeBadCredentials unless (verifyPassword (updateServiceConnPassword upd) pass) $ @@ -622,7 +622,7 @@ updateServiceConn pid sid upd = do -- Since deleting a service can be costly, it just marks the service as -- disabled and then creates an event that will, when processed, actually -- delete the service. See 'finishDeleteService'. -deleteServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.DeleteService -> Handler Response +deleteServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.DeleteService -> (Handler r) Response deleteServiceH (pid ::: sid ::: req) = do setStatus status202 empty <$ (deleteService pid sid =<< parseJsonBody req) @@ -631,7 +631,7 @@ deleteServiceH (pid ::: sid ::: req) = do -- Since deleting a service can be costly, it just marks the service as -- disabled and then creates an event that will, when processed, actually -- delete the service. See 'finishDeleteService'. -deleteService :: ProviderId -> ServiceId -> Public.DeleteService -> Handler () +deleteService :: ProviderId -> ServiceId -> Public.DeleteService -> (Handler r) () deleteService pid sid del = do pass <- DB.lookupPassword pid >>= maybeBadCredentials unless (verifyPassword (deleteServicePassword del) pass) $ @@ -643,7 +643,7 @@ deleteService pid sid del = do queue <- view internalEvents lift $ Queue.enqueue queue (Internal.DeleteService pid sid) -finishDeleteService :: ProviderId -> ServiceId -> AppIO () +finishDeleteService :: ProviderId -> ServiceId -> (AppIO r) () finishDeleteService pid sid = do mbSvc <- DB.lookupService pid sid for_ mbSvc $ \svc -> do @@ -657,11 +657,11 @@ finishDeleteService pid sid = do where kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid -deleteAccountH :: ProviderId ::: JsonRequest Public.DeleteProvider -> Handler Response +deleteAccountH :: ProviderId ::: JsonRequest Public.DeleteProvider -> (Handler r) Response deleteAccountH (pid ::: req) = do empty <$ (deleteAccount pid =<< parseJsonBody req) -deleteAccount :: ProviderId -> Public.DeleteProvider -> Handler () +deleteAccount :: ProviderId -> Public.DeleteProvider -> (Handler r) () deleteAccount pid del = do prov <- DB.lookupAccount pid >>= maybeInvalidProvider pass <- DB.lookupPassword pid >>= maybeBadCredentials @@ -680,31 +680,31 @@ deleteAccount pid del = do -------------------------------------------------------------------------------- -- User API -getProviderProfileH :: ProviderId -> Handler Response +getProviderProfileH :: ProviderId -> (Handler r) Response getProviderProfileH pid = do json <$> getProviderProfile pid -getProviderProfile :: ProviderId -> Handler Public.ProviderProfile +getProviderProfile :: ProviderId -> (Handler r) Public.ProviderProfile getProviderProfile pid = do DB.lookupAccountProfile pid >>= maybeProviderNotFound -listServiceProfilesH :: ProviderId -> Handler Response +listServiceProfilesH :: ProviderId -> (Handler r) Response listServiceProfilesH pid = do json <$> listServiceProfiles pid -listServiceProfiles :: ProviderId -> Handler [Public.ServiceProfile] +listServiceProfiles :: ProviderId -> (Handler r) [Public.ServiceProfile] listServiceProfiles pid = do DB.listServiceProfiles pid -getServiceProfileH :: ProviderId ::: ServiceId -> Handler Response +getServiceProfileH :: ProviderId ::: ServiceId -> (Handler r) Response getServiceProfileH (pid ::: sid) = do json <$> getServiceProfile pid sid -getServiceProfile :: ProviderId -> ServiceId -> Handler Public.ServiceProfile +getServiceProfile :: ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile getServiceProfile pid sid = do DB.lookupServiceProfile pid sid >>= maybeServiceNotFound -searchServiceProfilesH :: Maybe (Public.QueryAnyTags 1 3) ::: Maybe Text ::: Range 10 100 Int32 -> Handler Response +searchServiceProfilesH :: Maybe (Public.QueryAnyTags 1 3) ::: Maybe Text ::: Range 10 100 Int32 -> (Handler r) Response searchServiceProfilesH (qt ::: start ::: size) = do json <$> searchServiceProfiles qt start size @@ -712,7 +712,7 @@ searchServiceProfilesH (qt ::: start ::: size) = do -- pagination here, we need both 'start' and 'prefix'. -- -- Also see Note [buggy pagination]. -searchServiceProfiles :: Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Range 10 100 Int32 -> Handler Public.ServiceProfilePage +searchServiceProfiles :: Maybe (Public.QueryAnyTags 1 3) -> Maybe Text -> Range 10 100 Int32 -> (Handler r) Public.ServiceProfilePage searchServiceProfiles Nothing (Just start) size = do prefix :: Range 1 128 Text <- rangeChecked start DB.paginateServiceNames (Just prefix) (fromRange size) =<< setProviderSearchFilter <$> view settings @@ -723,7 +723,7 @@ searchServiceProfiles Nothing Nothing _ = do searchTeamServiceProfilesH :: UserId ::: TeamId ::: Maybe (Range 1 128 Text) ::: Bool ::: Range 10 100 Int32 -> - Handler Response + (Handler r) Response searchTeamServiceProfilesH (uid ::: tid ::: prefix ::: filterDisabled ::: size) = do json <$> searchTeamServiceProfiles uid tid prefix filterDisabled size @@ -734,7 +734,7 @@ searchTeamServiceProfiles :: Maybe (Range 1 128 Text) -> Bool -> Range 10 100 Int32 -> - Handler Public.ServiceProfilePage + (Handler r) Public.ServiceProfilePage searchTeamServiceProfiles uid tid prefix filterDisabled size = do -- Check that the user actually belong to the team they claim they -- belong to. (Note: the 'tid' team might not even exist but we'll throw @@ -745,7 +745,7 @@ searchTeamServiceProfiles uid tid prefix filterDisabled size = do -- Get search results DB.paginateServiceWhitelist tid prefix filterDisabled (fromRange size) -getServiceTagListH :: () -> Handler Response +getServiceTagListH :: () -> (Handler r) Response getServiceTagListH () = json <$> getServiceTagList () getServiceTagList :: () -> Monad m => m Public.ServiceTagList @@ -753,7 +753,7 @@ getServiceTagList () = return (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelistH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> Handler Response +updateServiceWhitelistH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> (Handler r) Response updateServiceWhitelistH (uid ::: con ::: tid ::: req) = do resp <- updateServiceWhitelist uid con tid =<< parseJsonBody req let status = case resp of @@ -765,7 +765,7 @@ data UpdateServiceWhitelistResp = UpdateServiceWhitelistRespChanged | UpdateServiceWhitelistRespUnchanged -updateServiceWhitelist :: UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> Handler UpdateServiceWhitelistResp +updateServiceWhitelist :: UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do let pid = updateServiceWhitelistProvider upd sid = updateServiceWhitelistService upd @@ -797,11 +797,11 @@ updateServiceWhitelist uid con tid upd = do DB.deleteServiceWhitelist (Just tid) pid sid return UpdateServiceWhitelistRespChanged -addBotH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> Handler Response +addBotH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> (Handler r) Response addBotH (zuid ::: zcon ::: cid ::: req) = do setStatus status201 . json <$> (addBot zuid zcon cid =<< parseJsonBody req) -addBot :: UserId -> ConnId -> ConvId -> Public.AddBot -> Handler Public.AddBotResponse +addBot :: UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse addBot zuid zcon cid add = do zusr <- lift (User.lookupUser NoPendingInvitations zuid) >>= maybeInvalidUser let pid = addBotProvider add @@ -875,11 +875,11 @@ addBot zuid zcon cid add = do Public.rsAddBotEvent = ev } -removeBotH :: UserId ::: ConnId ::: ConvId ::: BotId -> Handler Response +removeBotH :: UserId ::: ConnId ::: ConvId ::: BotId -> (Handler r) Response removeBotH (zusr ::: zcon ::: cid ::: bid) = do maybe (setStatus status204 empty) json <$> removeBot zusr zcon cid bid -removeBot :: UserId -> ConnId -> ConvId -> BotId -> Handler (Maybe Public.RemoveBotResponse) +removeBot :: UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) removeBot zusr zcon cid bid = do -- Get the conversation and check preconditions cnv <- lift (RPC.getConv zusr cid) >>= maybeConvNotFound @@ -897,38 +897,38 @@ removeBot zusr zcon cid bid = do -------------------------------------------------------------------------------- -- Bot API -botGetSelfH :: BotId -> Handler Response +botGetSelfH :: BotId -> (Handler r) Response botGetSelfH bot = json <$> botGetSelf bot -botGetSelf :: BotId -> Handler Public.UserProfile +botGetSelf :: BotId -> (Handler r) Public.UserProfile botGetSelf bot = do p <- lift $ User.lookupUser NoPendingInvitations (botUserId bot) maybe (throwErrorDescriptionType @UserNotFound) (return . (`Public.publicProfile` UserLegalHoldNoConsent)) p -botGetClientH :: BotId -> Handler Response +botGetClientH :: BotId -> (Handler r) Response botGetClientH bot = do maybe (throwErrorDescriptionType @ClientNotFound) (pure . json) =<< lift (botGetClient bot) -botGetClient :: BotId -> AppIO (Maybe Public.Client) +botGetClient :: BotId -> (AppIO r) (Maybe Public.Client) botGetClient bot = do listToMaybe <$> User.lookupClients (botUserId bot) -botListPrekeysH :: BotId -> Handler Response +botListPrekeysH :: BotId -> (Handler r) Response botListPrekeysH bot = do json <$> botListPrekeys bot -botListPrekeys :: BotId -> Handler [Public.PrekeyId] +botListPrekeys :: BotId -> (Handler r) [Public.PrekeyId] botListPrekeys bot = do clt <- lift $ listToMaybe <$> User.lookupClients (botUserId bot) case clientId <$> clt of Nothing -> return [] Just ci -> lift (User.lookupPrekeyIds (botUserId bot) ci) -botUpdatePrekeysH :: BotId ::: JsonRequest Public.UpdateBotPrekeys -> Handler Response +botUpdatePrekeysH :: BotId ::: JsonRequest Public.UpdateBotPrekeys -> (Handler r) Response botUpdatePrekeysH (bot ::: req) = do empty <$ (botUpdatePrekeys bot =<< parseJsonBody req) -botUpdatePrekeys :: BotId -> Public.UpdateBotPrekeys -> Handler () +botUpdatePrekeys :: BotId -> Public.UpdateBotPrekeys -> (Handler r) () botUpdatePrekeys bot upd = do clt <- lift $ listToMaybe <$> User.lookupClients (botUserId bot) case clt of @@ -937,41 +937,41 @@ botUpdatePrekeys bot upd = do let pks = updateBotPrekeyList upd User.updatePrekeys (botUserId bot) (clientId c) pks !>> clientDataError -botClaimUsersPrekeysH :: JsonRequest Public.UserClients -> Handler Response +botClaimUsersPrekeysH :: JsonRequest Public.UserClients -> (Handler r) Response botClaimUsersPrekeysH req = do json <$> (botClaimUsersPrekeys =<< parseJsonBody req) -botClaimUsersPrekeys :: Public.UserClients -> Handler Public.UserClientPrekeyMap +botClaimUsersPrekeys :: Public.UserClients -> (Handler r) Public.UserClientPrekeyMap botClaimUsersPrekeys body = do maxSize <- fromIntegral . setMaxConvSize <$> view settings when (Map.size (Public.userClients body) > maxSize) $ throwErrorDescriptionType @TooManyClients Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError -botListUserProfilesH :: List UserId -> Handler Response +botListUserProfilesH :: List UserId -> (Handler r) Response botListUserProfilesH uids = do json <$> botListUserProfiles uids -botListUserProfiles :: List UserId -> Handler [Public.BotUserView] +botListUserProfiles :: List UserId -> (Handler r) [Public.BotUserView] botListUserProfiles uids = do us <- lift $ User.lookupUsers NoPendingInvitations (fromList uids) return (map mkBotUserView us) -botGetUserClientsH :: UserId -> Handler Response +botGetUserClientsH :: UserId -> (Handler r) Response botGetUserClientsH uid = do json <$> lift (botGetUserClients uid) -botGetUserClients :: UserId -> AppIO [Public.PubClient] +botGetUserClients :: UserId -> (AppIO r) [Public.PubClient] botGetUserClients uid = do pubClient <$$> User.lookupClients uid where pubClient c = Public.PubClient (clientId c) (clientClass c) -botDeleteSelfH :: BotId ::: ConvId -> Handler Response +botDeleteSelfH :: BotId ::: ConvId -> (Handler r) Response botDeleteSelfH (bid ::: cid) = do empty <$ botDeleteSelf bid cid -botDeleteSelf :: BotId -> ConvId -> Handler () +botDeleteSelf :: BotId -> ConvId -> (Handler r) () botDeleteSelf bid cid = do bot <- lift $ User.lookupUser NoPendingInvitations (botUserId bid) _ <- maybeInvalidBot (userService =<< bot) @@ -984,7 +984,7 @@ botDeleteSelf bid cid = do minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) -activate :: ProviderId -> Maybe Public.Email -> Public.Email -> Handler () +activate :: ProviderId -> Maybe Public.Email -> Public.Email -> (Handler r) () activate pid old new = do let emailKey = mkEmailKey new taken <- maybe False (/= pid) <$> DB.lookupKey emailKey @@ -992,7 +992,7 @@ activate pid old new = do throwStd emailExists DB.insertKey pid (mkEmailKey <$> old) emailKey -deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> AppIO (Maybe Public.Event) +deleteBot :: UserId -> Maybe ConnId -> BotId -> ConvId -> (AppIO r) (Maybe Public.Event) deleteBot zusr zcon bid cid = do -- Remove the bot from the conversation ev <- RPC.removeBotMember zusr zcon cid bid @@ -1041,7 +1041,7 @@ mkBotUserView u = Ext.botUserViewTeam = userTeam u } -setProviderCookie :: ZAuth.ProviderToken -> Response -> Handler Response +setProviderCookie :: ZAuth.ProviderToken -> Response -> (Handler r) Response setProviderCookie t r = do s <- view settings let hdr = toByteString' (Cookie.renderSetCookie (cookie s)) @@ -1057,34 +1057,34 @@ setProviderCookie t r = do Cookie.setCookieHttpOnly = True } -maybeInvalidProvider :: Maybe a -> Handler a +maybeInvalidProvider :: Maybe a -> (Handler r) a maybeInvalidProvider = maybe (throwStd invalidProvider) return -maybeInvalidCode :: Maybe a -> Handler a +maybeInvalidCode :: Maybe a -> (Handler r) a maybeInvalidCode = maybe (throwErrorDescriptionType @InvalidCode) return -maybeServiceNotFound :: Maybe a -> Handler a +maybeServiceNotFound :: Maybe a -> (Handler r) a maybeServiceNotFound = maybe (throwStd (notFound "Service not found")) return -maybeProviderNotFound :: Maybe a -> Handler a +maybeProviderNotFound :: Maybe a -> (Handler r) a maybeProviderNotFound = maybe (throwStd (notFound "Provider not found")) return -maybeConvNotFound :: Maybe a -> Handler a +maybeConvNotFound :: Maybe a -> (Handler r) a maybeConvNotFound = maybe (throwStd (notFound "Conversation not found")) return -maybeBadCredentials :: Maybe a -> Handler a +maybeBadCredentials :: Maybe a -> (Handler r) a maybeBadCredentials = maybe (throwErrorDescriptionType @BadCredentials) return -maybeInvalidServiceKey :: Maybe a -> Handler a +maybeInvalidServiceKey :: Maybe a -> (Handler r) a maybeInvalidServiceKey = maybe (throwStd invalidServiceKey) return -maybeInvalidBot :: Maybe a -> Handler a +maybeInvalidBot :: Maybe a -> (Handler r) a maybeInvalidBot = maybe (throwStd invalidBot) return -maybeInvalidUser :: Maybe a -> Handler a +maybeInvalidUser :: Maybe a -> (Handler r) a maybeInvalidUser = maybe (throwStd (errorDescriptionTypeToWai @InvalidUser)) return -rangeChecked :: Within a n m => a -> Handler (Range n m a) +rangeChecked :: Within a n m => a -> (Handler r) (Range n m a) rangeChecked = either (throwStd . invalidRange . fromString) return . checkedEither invalidServiceKey :: Wai.Error diff --git a/services/brig/src/Brig/Provider/Email.hs b/services/brig/src/Brig/Provider/Email.hs index f0b88831a8d..b0d5f76b44f 100644 --- a/services/brig/src/Brig/Provider/Email.hs +++ b/services/brig/src/Brig/Provider/Email.hs @@ -44,7 +44,7 @@ import Imports ------------------------------------------------------------------------------- -- Activation Email -sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> AppIO () +sendActivationMail :: Name -> Email -> Code.Key -> Code.Value -> Bool -> (AppIO r) () sendActivationMail name email key code update = do tpl <- selectTemplate update . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -96,7 +96,7 @@ renderActivationUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Request Email -sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> AppIO () +sendApprovalRequestMail :: Name -> Email -> HttpsUrl -> Text -> Code.Key -> Code.Value -> (AppIO r) () sendApprovalRequestMail name email url descr key val = do tpl <- approvalRequestEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -147,7 +147,7 @@ renderApprovalUrl t (Code.Key k) (Code.Value v) branding = -------------------------------------------------------------------------------- -- Approval Confirmation Email -sendApprovalConfirmMail :: Name -> Email -> AppIO () +sendApprovalConfirmMail :: Name -> Email -> (AppIO r) () sendApprovalConfirmMail name email = do tpl <- approvalConfirmEmail . snd <$> providerTemplates Nothing branding <- view templateBranding @@ -183,7 +183,7 @@ renderApprovalConfirmMail ApprovalConfirmEmail {..} ApprovalConfirmEmailTemplate -------------------------------------------------------------------------------- -- Password Reset Email -sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> AppIO () +sendPasswordResetMail :: Email -> Code.Key -> Code.Value -> (AppIO r) () sendPasswordResetMail to key code = do tpl <- passwordResetEmail . snd <$> providerTemplates Nothing branding <- view templateBranding diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 03ce6c2f9a6..d2dca30b6c2 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -65,7 +65,7 @@ data ServiceError -- -- If the external service is unavailable, returns a specific error -- or the response body cannot be parsed, a 'ServiceError' is returned. -createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError AppIO NewBotResponse +createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppIO r) NewBotResponse createBot scon new = do let fprs = toList (sconFingerprints scon) (man, verifyFingerprints) <- view extGetManager @@ -130,7 +130,7 @@ extLogError scon e = -- Internal RPC -- | Set service connection information in galley. -setServiceConn :: ServiceConn -> AppIO () +setServiceConn :: ServiceConn -> (AppIO r) () setServiceConn scon = do Log.debug $ remote "galley" @@ -155,7 +155,7 @@ setServiceConn scon = do & set Galley.serviceEnabled (sconEnabled scon) -- | Remove service connection information from galley. -removeServiceConn :: ProviderId -> ServiceId -> AppIO () +removeServiceConn :: ProviderId -> ServiceId -> (AppIO r) () removeServiceConn pid sid = do Log.debug $ remote "galley" @@ -179,7 +179,7 @@ addBotMember :: ClientId -> ProviderId -> ServiceId -> - AppIO Event + (AppIO r) Event addBotMember zusr zcon conv bot clt pid sid = do Log.debug $ remote "galley" @@ -205,7 +205,7 @@ removeBotMember :: Maybe ConnId -> ConvId -> BotId -> - AppIO (Maybe Event) + (AppIO r) (Maybe Event) removeBotMember zusr zcon conv bot = do Log.debug $ remote "galley" diff --git a/services/brig/src/Brig/Queue.hs b/services/brig/src/Brig/Queue.hs index 9e03c45cf65..c4c811853e3 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/services/brig/src/Brig/Queue.hs @@ -63,7 +63,7 @@ import System.Logger.Class as Log hiding (settings) -- | Enqueue a message. -- -- Throws an error in case of failure. -enqueue :: ToJSON a => Queue -> a -> AppIO () +enqueue :: ToJSON a => Queue -> a -> (AppIO r) () enqueue (StompQueue queue) message = view stompEnv >>= \case Just env -> Stomp.enqueue (Stomp.broker env) queue message @@ -93,7 +93,7 @@ enqueue (SqsQueue queue) message = -- -- See documentation of underlying functions (e.g. 'Stomp.listen') for -- extra details. -listen :: (Show a, FromJSON a) => Queue -> (a -> AppIO ()) -> AppIO () +listen :: (Show a, FromJSON a) => Queue -> (a -> (AppIO r) ()) -> (AppIO r) () listen (StompQueue queue) callback = view stompEnv >>= \case Just env -> Stomp.listen (Stomp.broker env) queue callback diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 645abc530ed..a9268ca9b9f 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -62,19 +62,19 @@ expect ss rq = rq {checkResponse = check} cargoholdRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) cargoholdRequest = serviceRequest "cargohold" cargohold galleyRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) galleyRequest = serviceRequest "galley" galley gundeckRequest :: StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) gundeckRequest = serviceRequest "gundeck" gundeck serviceRequest :: @@ -82,7 +82,7 @@ serviceRequest :: Control.Lens.Getting Request Env Request -> StdMethod -> (Request -> Request) -> - AppIO (Response (Maybe BL.ByteString)) + (AppIO r) (Response (Maybe BL.ByteString)) serviceRequest nm svc m r = do service <- view svc recovering x3 rpcHandlers $ diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index dce7a876161..ed77926081e 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -107,7 +107,7 @@ mkApp o = do e <- newEnv o return (middleware e $ \reqId -> servantApp (e & requestId .~ reqId), e) where - rtree :: Tree (App Handler) + rtree :: Tree (App (Handler r)) rtree = compile sitemap middleware :: Env -> (RequestId -> Wai.Application) -> Wai.Application @@ -169,7 +169,7 @@ bodyParserErrorFormatter _ _ errMsg = Servant.errHeaders = [(HTTP.hContentType, HTTPMedia.renderHeader (Servant.contentType (Proxy @Servant.JSON)))] } -pendingActivationCleanup :: AppIO () +pendingActivationCleanup :: forall r. (AppIO r) () pendingActivationCleanup = do safeForever "pendingActivationCleanup" $ do now <- liftIO =<< view currentTime @@ -206,17 +206,17 @@ pendingActivationCleanup = do -- pause to keep worst-case noise in logs manageable threadDelay 60_000_000 - forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () + forExpirationsPaged :: ([UserPendingActivation] -> (AppIO r) ()) -> (AppIO r) () forExpirationsPaged f = do go =<< usersPendingActivationList where - go :: (Page UserPendingActivation) -> AppIO () + go :: (Page UserPendingActivation) -> (AppIO r) () go (Page hasMore result nextPage) = do f result when hasMore $ go =<< liftClient nextPage - threadDelayRandom :: AppIO () + threadDelayRandom :: (AppIO r) () threadDelayRandom = do cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings let d = realToFrac cleanupTimeout diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 5f770008b65..4ebdb9c2f9c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -70,7 +70,7 @@ import qualified Wire.API.Team.Role as Public import qualified Wire.API.Team.Size as Public import qualified Wire.API.User as Public -routesPublic :: Routes Doc.ApiBuilder Handler () +routesPublic :: Routes Doc.ApiBuilder (Handler r) () routesPublic = do post "/teams/:tid/invitations" (continue createInvitationPublicH) $ accept "application" "json" @@ -180,7 +180,7 @@ routesPublic = do Doc.response 200 "Invitation successful." Doc.end Doc.response 403 "No permission (not admin or owner of this team)." Doc.end -routesInternal :: Routes a Handler () +routesInternal :: Routes a (Handler r) () routesInternal = do get "/i/teams/invitations/by-email" (continue getInvitationByEmailH) $ accept "application" "json" @@ -207,25 +207,25 @@ routesInternal = do accept "application" "json" .&. jsonRequest @NewUserScimInvitation -teamSizePublicH :: JSON ::: UserId ::: TeamId -> Handler Response +teamSizePublicH :: JSON ::: UserId ::: TeamId -> (Handler r) Response teamSizePublicH (_ ::: uid ::: tid) = json <$> teamSizePublic uid tid -teamSizePublic :: UserId -> TeamId -> Handler TeamSize +teamSizePublic :: UserId -> TeamId -> (Handler r) TeamSize teamSizePublic uid tid = do ensurePermissions uid tid [Team.AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks teamSize tid -teamSizeH :: JSON ::: TeamId -> Handler Response +teamSizeH :: JSON ::: TeamId -> (Handler r) Response teamSizeH (_ ::: t) = json <$> teamSize t -teamSize :: TeamId -> Handler TeamSize +teamSize :: TeamId -> (Handler r) TeamSize teamSize t = lift $ TeamSize.teamSize t -getInvitationCodeH :: JSON ::: TeamId ::: InvitationId -> Handler Response +getInvitationCodeH :: JSON ::: TeamId ::: InvitationId -> (Handler r) Response getInvitationCodeH (_ ::: t ::: r) = do json <$> getInvitationCode t r -getInvitationCode :: TeamId -> InvitationId -> Handler FoundInvitationCode +getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode getInvitationCode t r = do code <- lift $ DB.lookupInvitationCode t r maybe (throwStd invalidInvitationCode) (return . FoundInvitationCode) code @@ -236,7 +236,7 @@ data FoundInvitationCode = FoundInvitationCode InvitationCode instance ToJSON FoundInvitationCode where toJSON (FoundInvitationCode c) = object ["code" .= c] -createInvitationPublicH :: JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> Handler Response +createInvitationPublicH :: JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> (Handler r) Response createInvitationPublicH (_ ::: uid ::: tid ::: req) = do body <- parseJsonBody req newInv <- createInvitationPublic uid tid body @@ -252,7 +252,7 @@ data CreateInvitationInviter = CreateInvitationInviter } deriving (Eq, Show) -createInvitationPublic :: UserId -> TeamId -> Public.InvitationRequest -> Handler Public.Invitation +createInvitationPublic :: UserId -> TeamId -> Public.InvitationRequest -> (Handler r) Public.Invitation createInvitationPublic uid tid body = do let inviteeRole = fromMaybe Team.defaultRole . irRole $ body inviter <- do @@ -272,12 +272,12 @@ createInvitationPublic uid tid body = do context (createInvitation' tid inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body) -createInvitationViaScimH :: JSON ::: JsonRequest NewUserScimInvitation -> Handler Response +createInvitationViaScimH :: JSON ::: JsonRequest NewUserScimInvitation -> (Handler r) Response createInvitationViaScimH (_ ::: req) = do body <- parseJsonBody req setStatus status201 . json <$> createInvitationViaScim body -createInvitationViaScim :: NewUserScimInvitation -> Handler UserAccount +createInvitationViaScim :: NewUserScimInvitation -> (Handler r) UserAccount createInvitationViaScim newUser@(NewUserScimInvitation tid loc name email) = do env <- ask let inviteeRole = Team.defaultRole @@ -303,7 +303,7 @@ createInvitationViaScim newUser@(NewUserScimInvitation tid loc name email) = do createUserInviteViaScim uid newUser -logInvitationRequest :: (Msg -> Msg) -> Handler (Invitation, InvitationCode) -> Handler (Invitation, InvitationCode) +logInvitationRequest :: (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> (Handler r) (Invitation, InvitationCode) logInvitationRequest context action = flip mapExceptT action $ \action' -> do eith <- action' @@ -315,7 +315,7 @@ logInvitationRequest context action = Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) -createInvitation' :: TeamId -> Public.Role -> Maybe UserId -> Email -> Public.InvitationRequest -> Handler (Public.Invitation, Public.InvitationCode) +createInvitation' :: TeamId -> Public.Role -> Maybe UserId -> Email -> Public.InvitationRequest -> (Handler r) (Public.Invitation, Public.InvitationCode) createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- FUTUREWORK: These validations are nearly copy+paste from accountCreation and -- sendActivationCode. Refactor this to a single place @@ -366,47 +366,47 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do timeout (newInv, code) <$ sendInvitationMail inviteeEmail tid fromEmail code locale -deleteInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> Handler Response +deleteInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response deleteInvitationH (_ ::: uid ::: tid ::: iid) = do empty <$ deleteInvitation uid tid iid -deleteInvitation :: UserId -> TeamId -> InvitationId -> Handler () +deleteInvitation :: UserId -> TeamId -> InvitationId -> (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [Team.AddTeamMember] DB.deleteInvitation tid iid -listInvitationsH :: JSON ::: UserId ::: TeamId ::: Maybe InvitationId ::: Range 1 500 Int32 -> Handler Response +listInvitationsH :: JSON ::: UserId ::: TeamId ::: Maybe InvitationId ::: Range 1 500 Int32 -> (Handler r) Response listInvitationsH (_ ::: uid ::: tid ::: start ::: size) = do json <$> listInvitations uid tid start size -listInvitations :: UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> Handler Public.InvitationList +listInvitations :: UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> (Handler r) Public.InvitationList listInvitations uid tid start size = do ensurePermissions uid tid [Team.AddTeamMember] rs <- lift $ DB.lookupInvitations tid start size return $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) -getInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> Handler Response +getInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response getInvitationH (_ ::: uid ::: tid ::: iid) = do inv <- getInvitation uid tid iid return $ case inv of Just i -> json i Nothing -> setStatus status404 empty -getInvitation :: UserId -> TeamId -> InvitationId -> Handler (Maybe Public.Invitation) +getInvitation :: UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [Team.AddTeamMember] lift $ DB.lookupInvitation tid iid -getInvitationByCodeH :: JSON ::: Public.InvitationCode -> Handler Response +getInvitationByCodeH :: JSON ::: Public.InvitationCode -> (Handler r) Response getInvitationByCodeH (_ ::: c) = do json <$> getInvitationByCode c -getInvitationByCode :: Public.InvitationCode -> Handler Public.Invitation +getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation getInvitationByCode c = do inv <- lift $ DB.lookupInvitationByCode c maybe (throwStd invalidInvitationCode) return inv -headInvitationByEmailH :: JSON ::: Email -> Handler Response +headInvitationByEmailH :: JSON ::: Email -> (Handler r) Response headInvitationByEmailH (_ ::: e) = do inv <- lift $ DB.lookupInvitationInfoByEmail e return $ case inv of @@ -417,30 +417,30 @@ headInvitationByEmailH (_ ::: e) = do -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and -- 'getInvitationByEmailH' are almost the same thing. -getInvitationByEmailH :: JSON ::: Email -> Handler Response +getInvitationByEmailH :: JSON ::: Email -> (Handler r) Response getInvitationByEmailH (_ ::: email) = json <$> getInvitationByEmail email -getInvitationByEmail :: Email -> Handler Public.Invitation +getInvitationByEmail :: Email -> (Handler r) Public.Invitation getInvitationByEmail email = do inv <- lift $ DB.lookupInvitationByEmail email maybe (throwStd (notFound "Invitation not found")) return inv -suspendTeamH :: JSON ::: TeamId -> Handler Response +suspendTeamH :: JSON ::: TeamId -> (Handler r) Response suspendTeamH (_ ::: tid) = do empty <$ suspendTeam tid -suspendTeam :: TeamId -> Handler () +suspendTeam :: TeamId -> (Handler r) () suspendTeam tid = do changeTeamAccountStatuses tid Suspended lift $ DB.deleteInvitations tid lift $ Intra.changeTeamStatus tid Team.Suspended Nothing -unsuspendTeamH :: JSON ::: TeamId -> Handler Response +unsuspendTeamH :: JSON ::: TeamId -> (Handler r) Response unsuspendTeamH (_ ::: tid) = do empty <$ unsuspendTeam tid -unsuspendTeam :: TeamId -> Handler () +unsuspendTeam :: TeamId -> (Handler r) () unsuspendTeam tid = do changeTeamAccountStatuses tid Active lift $ Intra.changeTeamStatus tid Team.Active Nothing @@ -448,7 +448,7 @@ unsuspendTeam tid = do ------------------------------------------------------------------------------- -- Internal -changeTeamAccountStatuses :: TeamId -> AccountStatus -> Handler () +changeTeamAccountStatuses :: TeamId -> AccountStatus -> (Handler r) () changeTeamAccountStatuses tid s = do team <- Team.tdTeam <$> (lift $ Intra.getTeam tid) unless (team ^. Team.teamBinding == Team.Binding) $ diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 6b44547527a..20189b98fab 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -42,21 +42,21 @@ import Imports ------------------------------------------------------------------------------- -- Invitation Email -sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> AppIO () +sendInvitationMail :: Email -> TeamId -> Email -> InvitationCode -> Maybe Locale -> (AppIO r) () sendInvitationMail to tid from code loc = do tpl <- invitationEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = InvitationEmail to tid code from Email.sendMail $ renderInvitationEmail mail tpl branding -sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () +sendCreatorWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () sendCreatorWelcomeMail to tid teamName loc = do tpl <- creatorWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding let mail = CreatorWelcomeEmail to tid teamName Email.sendMail $ renderCreatorWelcomeMail mail tpl branding -sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> AppIO () +sendMemberWelcomeMail :: Email -> TeamId -> Text -> Maybe Locale -> (AppIO r) () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplates loc branding <- view templateBranding diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 64279ec00c5..bd530c489c4 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -27,7 +27,7 @@ import qualified Data.Set as Set import Galley.Types.Teams import Imports -ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error AppIO () +ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error (AppIO r) () ensurePermissions u t perms = do m <- lift $ Intra.getTeamMember u t unless (check m) $ @@ -40,7 +40,7 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error AppIO () +ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error (AppIO r) () ensurePermissionToAddUser u t inviteePerms = do minviter <- lift $ Intra.getTeamMember u t unless (check minviter) $ diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index e25ae0a82ae..fdd67fd5fd2 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -59,7 +59,7 @@ import qualified Wire.API.User as Public import Wire.API.User.Auth as Public import Wire.Swagger as Doc (pendingLoginError) -routesPublic :: Routes Doc.ApiBuilder Handler () +routesPublic :: Routes Doc.ApiBuilder (Handler r) () routesPublic = do post "/access" (continue renewH) $ accept "application" "json" @@ -182,7 +182,7 @@ routesPublic = do Doc.body (Doc.ref Public.modelRemoveCookies) Doc.end Doc.errorResponse (errorDescriptionTypeToWai @BadCredentials) -routesInternal :: Routes a Handler () +routesInternal :: Routes a (Handler r) () routesInternal = do -- galley can query this endpoint at the right moment in the LegalHold flow post "/i/legalhold-login" (continue legalHoldLoginH) $ @@ -204,68 +204,68 @@ routesInternal = do -- Handlers -sendLoginCodeH :: JsonRequest Public.SendLoginCode -> Handler Response +sendLoginCodeH :: JsonRequest Public.SendLoginCode -> (Handler r) Response sendLoginCodeH req = do json <$> (sendLoginCode =<< parseJsonBody req) -sendLoginCode :: Public.SendLoginCode -> Handler Public.LoginCodeTimeout +sendLoginCode :: Public.SendLoginCode -> (Handler r) Public.LoginCodeTimeout sendLoginCode (Public.SendLoginCode phone call force) = do checkWhitelist (Right phone) c <- Auth.sendLoginCode phone call force !>> sendLoginCodeError return $ Public.LoginCodeTimeout (pendingLoginTimeout c) -getLoginCodeH :: JSON ::: Phone -> Handler Response +getLoginCodeH :: JSON ::: Phone -> (Handler r) Response getLoginCodeH (_ ::: phone) = json <$> getLoginCode phone -getLoginCode :: Phone -> Handler Public.PendingLoginCode +getLoginCode :: Phone -> (Handler r) Public.PendingLoginCode getLoginCode phone = do code <- lift $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) return code -reAuthUserH :: UserId ::: JsonRequest ReAuthUser -> Handler Response +reAuthUserH :: UserId ::: JsonRequest ReAuthUser -> (Handler r) Response reAuthUserH (uid ::: req) = do reAuthUser uid =<< parseJsonBody req return empty -reAuthUser :: UserId -> ReAuthUser -> Handler () +reAuthUser :: UserId -> ReAuthUser -> (Handler r) () reAuthUser uid body = do User.reauthenticate uid (reAuthPassword body) !>> reauthError -loginH :: JsonRequest Public.Login ::: Bool ::: JSON -> Handler Response +loginH :: JsonRequest Public.Login ::: Bool ::: JSON -> (Handler r) Response loginH (req ::: persist ::: _) = do lift . tokenResponse =<< flip login persist =<< parseJsonBody req -login :: Public.Login -> Bool -> Handler (Auth.Access ZAuth.User) +login :: Public.Login -> Bool -> (Handler r) (Auth.Access ZAuth.User) login l persist = do let typ = if persist then PersistentCookie else SessionCookie Auth.login l typ !>> loginError -ssoLoginH :: JsonRequest SsoLogin ::: Bool ::: JSON -> Handler Response +ssoLoginH :: JsonRequest SsoLogin ::: Bool ::: JSON -> (Handler r) Response ssoLoginH (req ::: persist ::: _) = do lift . tokenResponse =<< flip ssoLogin persist =<< parseJsonBody req -ssoLogin :: SsoLogin -> Bool -> Handler (Auth.Access ZAuth.User) +ssoLogin :: SsoLogin -> Bool -> (Handler r) (Auth.Access ZAuth.User) ssoLogin l persist = do let typ = if persist then PersistentCookie else SessionCookie Auth.ssoLogin l typ !>> loginError -legalHoldLoginH :: JsonRequest LegalHoldLogin ::: JSON -> Handler Response +legalHoldLoginH :: JsonRequest LegalHoldLogin ::: JSON -> (Handler r) Response legalHoldLoginH (req ::: _) = do lift . tokenResponse =<< legalHoldLogin =<< parseJsonBody req -legalHoldLogin :: LegalHoldLogin -> Handler (Auth.Access ZAuth.LegalHoldUser) +legalHoldLogin :: LegalHoldLogin -> (Handler r) (Auth.Access ZAuth.LegalHoldUser) legalHoldLogin l = do let typ = PersistentCookie -- Session cookie isn't a supported use case here Auth.legalHoldLogin l typ !>> legalHoldLoginError -logoutH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> Handler Response +logoutH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> (Handler r) Response logoutH (_ ::: ut ::: at) = empty <$ logout ut at -- TODO: add legalhold test checking cookies are revoked (/access/logout is called) when legalhold device is deleted. logout :: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - Handler () + (Handler r) () logout Nothing Nothing = throwStd authMissingCookieAndToken logout Nothing (Just _) = throwStd authMissingCookie logout (Just _) Nothing = throwStd authMissingToken @@ -279,7 +279,7 @@ changeSelfEmailH :: ::: JsonRequest Public.EmailUpdate ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - Handler Response + (Handler r) Response changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do usr <- validateCredentials ckies toks email <- Public.euEmail <$> parseJsonBody req @@ -290,7 +290,7 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do validateCredentials :: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - Handler UserId + (Handler r) UserId validateCredentials = \case Nothing -> const $ throwStd authMissingCookie @@ -305,22 +305,22 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do Just (Left userTokens) -> fst <$> (Auth.validateTokens userCookies (Just userTokens) !>> zauthError) -listCookiesH :: UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> Handler Response +listCookiesH :: UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> (Handler r) Response listCookiesH (u ::: ll ::: _) = json <$> lift (listCookies u ll) -listCookies :: UserId -> Maybe (List Public.CookieLabel) -> AppIO Public.CookieList +listCookies :: UserId -> Maybe (List Public.CookieLabel) -> (AppIO r) Public.CookieList listCookies u ll = do Public.CookieList <$> Auth.listCookies u (maybe [] fromList ll) -rmCookiesH :: UserId ::: JsonRequest Public.RemoveCookies -> Handler Response +rmCookiesH :: UserId ::: JsonRequest Public.RemoveCookies -> (Handler r) Response rmCookiesH (uid ::: req) = do empty <$ (rmCookies uid =<< parseJsonBody req) -rmCookies :: UserId -> Public.RemoveCookies -> Handler () +rmCookies :: UserId -> Public.RemoveCookies -> (Handler r) () rmCookies uid (Public.RemoveCookies pw lls ids) = do Auth.revokeAccess uid pw ids lls !>> authError -renewH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> Handler Response +renewH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> (Handler r) Response renewH (_ ::: ut ::: at) = lift . either tokenResponse tokenResponse =<< renew ut at -- | renew access for either: @@ -331,7 +331,7 @@ renewH (_ ::: ut ::: at) = lift . either tokenResponse tokenResponse =<< renew u renew :: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - Handler (Either (Auth.Access ZAuth.User) (Auth.Access ZAuth.LegalHoldUser)) + (Handler r) (Either (Auth.Access ZAuth.User) (Auth.Access ZAuth.LegalHoldUser)) renew = \case Nothing -> const $ throwStd authMissingCookie @@ -344,7 +344,7 @@ renew = \case where renewAccess uts mat = Auth.renewAccess uts mat !>> zauthError - matchingOrNone :: (a -> Maybe b) -> Maybe a -> Handler (Maybe b) + matchingOrNone :: (a -> Maybe b) -> Maybe a -> (Handler r) (Maybe b) matchingOrNone matching = traverse $ \accessToken -> case matching accessToken of Just m -> pure m @@ -406,7 +406,7 @@ tokenRequest = opt (userToken ||| legalHoldUserToken) .&. opt (accessToken ||| l ) Just t -> return t -tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> AppIO Response +tokenResponse :: ZAuth.UserTokenLike u => Auth.Access u -> (AppIO r) Response tokenResponse (Auth.Access t Nothing) = pure $ json t tokenResponse (Auth.Access t (Just c)) = Auth.setResponseCookie c (json t) diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 7cf8ad8f0e1..82dc56f4c33 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -42,7 +42,7 @@ import qualified Wire.API.User as Public import Wire.API.User.Search import qualified Wire.API.User.Search as Public -getHandleInfo :: UserId -> Qualified Handle -> Handler (Maybe Public.UserProfile) +getHandleInfo :: UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -51,14 +51,14 @@ getHandleInfo self handle = do getRemoteHandleInfo handle -getRemoteHandleInfo :: Remote Handle -> Handler (Maybe Public.UserProfile) +getRemoteHandleInfo :: Remote Handle -> (Handler r) (Maybe Public.UserProfile) getRemoteHandleInfo handle = do Log.info $ Log.msg (Log.val "getHandleInfo - remote lookup") . Log.field "domain" (show (tDomain handle)) Federation.getUserHandleInfo handle !>> fedError -getLocalHandleInfo :: Local UserId -> Handle -> Handler (Maybe Public.UserProfile) +getLocalHandleInfo :: Local UserId -> Handle -> (Handler r) (Maybe Public.UserProfile) getLocalHandleInfo self handle = do Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" maybeOwnerId <- lift $ API.lookupHandle handle @@ -71,7 +71,7 @@ getLocalHandleInfo self handle = do return $ listToMaybe owner -- | Checks search permissions and filters accordingly -filterHandleResults :: Local UserId -> [Public.UserProfile] -> Handler [Public.UserProfile] +filterHandleResults :: Local UserId -> [Public.UserProfile] -> (Handler r) [Public.UserProfile] filterHandleResults searchingUser us = do sameTeamSearchOnly <- fromMaybe False <$> view (settings . searchSameTeamOnly) if sameTeamSearchOnly diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index ee4170bd29e..4a3124c1ed9 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -60,7 +60,7 @@ import qualified Wire.API.Team.Permission as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility) import qualified Wire.API.User.Search as Public -routesPublic :: Routes Doc.ApiBuilder Handler () +routesPublic :: Routes Doc.ApiBuilder (Handler r) () routesPublic = do get "/teams/:tid/search" (continue teamUserSearchH) $ accept "application" "json" @@ -94,7 +94,7 @@ routesPublic = do Doc.returns (Doc.ref $ Public.modelSearchResult Public.modelTeamContact) Doc.response 200 "The list of hits." Doc.end -routesInternal :: Routes a Handler () +routesInternal :: Routes a (Handler r) () routesInternal = do -- make index updates visible (e.g. for integration testing) post @@ -121,7 +121,7 @@ routesInternal = do -- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles -- for all results. This is tracked in https://wearezeta.atlassian.net/browse/SQCORE-599 -search :: UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> Handler (Public.SearchResult Public.Contact) +search :: UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) search searcherId searchTerm maybeDomain maybeMaxResults = do federationDomain <- viewFederationDomain let queryDomain = fromMaybe federationDomain maybeDomain @@ -129,7 +129,7 @@ search searcherId searchTerm maybeDomain maybeMaxResults = do then searchLocally searcherId searchTerm maybeMaxResults else searchRemotely queryDomain searchTerm -searchRemotely :: Domain -> Text -> Handler (Public.SearchResult Public.Contact) +searchRemotely :: Domain -> Text -> (Handler r) (Public.SearchResult Public.Contact) searchRemotely domain searchTerm = do Log.info $ msg (val "searchRemotely") @@ -145,7 +145,7 @@ searchRemotely domain searchTerm = do searchTook = 0 } -searchLocally :: UserId -> Text -> Maybe (Range 1 500 Int32) -> Handler (Public.SearchResult Public.Contact) +searchLocally :: UserId -> Text -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) searchLocally searcherId searchTerm maybeMaxResults = do let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults teamSearchInfo <- mkTeamSearchInfo @@ -172,7 +172,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do handleTeamVisibility t Team.SearchVisibilityStandard = Search.TeamAndNonMembers t handleTeamVisibility t Team.SearchVisibilityNoNameOutsideTeam = Search.TeamOnly t - mkTeamSearchInfo :: Handler TeamSearchInfo + mkTeamSearchInfo :: (Handler r) TeamSearchInfo mkTeamSearchInfo = lift $ do searcherTeamId <- DB.lookupUserTeam searcherId sameTeamSearchOnly <- fromMaybe False <$> view (settings . Opts.searchSameTeamOnly) @@ -186,7 +186,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do -- For team users, we need to check the visibility flag handleTeamVisibility t <$> Intra.getTeamSearchVisibility t - exactHandleSearch :: TeamSearchInfo -> Handler (Maybe Contact) + exactHandleSearch :: TeamSearchInfo -> (Handler r) (Maybe Contact) exactHandleSearch teamSearchInfo = do lsearcherId <- qualifyLocal searcherId let searchedHandleMaybe = parseHandle searchTerm @@ -213,7 +213,7 @@ teamUserSearchH :: ::: Maybe TeamUserSearchSortOrder ::: Range 1 500 Int32 ) -> - Handler Response + (Handler r) Response teamUserSearchH (_ ::: uid ::: tid ::: mQuery ::: mRoleFilter ::: mSortBy ::: mSortOrder ::: size) = do json <$> teamUserSearch uid tid mQuery mRoleFilter mSortBy mSortOrder size @@ -225,7 +225,7 @@ teamUserSearch :: Maybe TeamUserSearchSortBy -> Maybe TeamUserSearchSortOrder -> Range 1 500 Int32 -> - Handler (Public.SearchResult Public.TeamContact) + (Handler r) (Public.SearchResult Public.TeamContact) teamUserSearch uid tid mQuery mRoleFilter mSortBy mSortOrder size = do ensurePermissions uid tid [Public.AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks. (also, this way we don't need to worry about revealing confidential user data to other team members.) Q.teamUserSearch tid mQuery mRoleFilter mSortBy mSortOrder size diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index e11fb2cf127..f0977ce66e4 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -78,7 +78,7 @@ data Access u = Access accessCookie :: !(Maybe (Cookie (ZAuth.Token u))) } -sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError AppIO PendingLoginCode +sendLoginCode :: Phone -> Bool -> Bool -> ExceptT SendLoginCodeError (AppIO r) PendingLoginCode sendLoginCode phone call force = do pk <- maybe @@ -102,7 +102,7 @@ sendLoginCode phone call force = do else sendLoginSms ph (pendingLoginCode c) l return c -lookupLoginCode :: Phone -> AppIO (Maybe PendingLoginCode) +lookupLoginCode :: Phone -> (AppIO r) (Maybe PendingLoginCode) lookupLoginCode phone = Data.lookupKey (userPhoneKey phone) >>= \case Nothing -> return Nothing @@ -110,7 +110,7 @@ lookupLoginCode phone = Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") Data.lookupLoginCode u -login :: Login -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) +login :: Login -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) login (PasswordLogin li pw label _) typ = do case TeamFeatureSndFPasswordChallengeNotImplemented of -- mark this place to implement handling verification codes later @@ -135,19 +135,19 @@ login (SmsLogin phone code label) typ = do loginFailed uid newAccess @ZAuth.User @ZAuth.Access uid typ label -loginFailed :: UserId -> ExceptT LoginError AppIO () +loginFailed :: UserId -> ExceptT LoginError (AppIO r) () loginFailed uid = decrRetryLimit uid >> throwE LoginFailed -decrRetryLimit :: UserId -> ExceptT LoginError AppIO () +decrRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () decrRetryLimit = withRetryLimit (\k b -> withBudget k b $ pure ()) -checkRetryLimit :: UserId -> ExceptT LoginError AppIO () +checkRetryLimit :: UserId -> ExceptT LoginError (AppIO r) () checkRetryLimit = withRetryLimit checkBudget withRetryLimit :: - (BudgetKey -> Budget -> ExceptT LoginError AppIO (Budgeted ())) -> + (BudgetKey -> Budget -> ExceptT LoginError (AppIO r) (Budgeted ())) -> UserId -> - ExceptT LoginError AppIO () + ExceptT LoginError (AppIO r) () withRetryLimit action uid = do mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) forM_ mLimitFailedLogins $ \opts -> do @@ -161,7 +161,7 @@ withRetryLimit action uid = do BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl BudgetedValue () _ -> pure () -logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure AppIO () +logout :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> ZAuth.Token a -> ExceptT ZAuth.Failure (AppIO r) () logout uts at = do (u, ck) <- validateTokens uts (Just at) lift $ revokeCookies u [cookieId ck] [] @@ -170,7 +170,7 @@ renewAccess :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (Access u) + ExceptT ZAuth.Failure (AppIO r) (Access u) renewAccess uts at = do (uid, ck) <- validateTokens uts at Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.renewAccess") @@ -184,7 +184,7 @@ revokeAccess :: PlainTextPassword -> [CookieId] -> [CookieLabel] -> - ExceptT AuthError AppIO () + ExceptT AuthError (AppIO r) () revokeAccess u pw cc ll = do Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") Data.authenticate u pw @@ -193,7 +193,7 @@ revokeAccess u pw cc ll = do -------------------------------------------------------------------------------- -- Internal -catchSuspendInactiveUser :: UserId -> e -> ExceptT e AppIO () +catchSuspendInactiveUser :: UserId -> e -> ExceptT e (AppIO r) () catchSuspendInactiveUser uid errval = do mustsuspend <- lift $ mustSuspendInactiveUser uid when mustsuspend $ do @@ -204,7 +204,7 @@ catchSuspendInactiveUser uid errval = do lift $ suspendAccount (List1.singleton uid) throwE errval -newAccess :: forall u a. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError AppIO (Access u) +newAccess :: forall u a r. ZAuth.TokenPair u a => UserId -> CookieType -> Maybe CookieLabel -> ExceptT LoginError (AppIO r) (Access u) newAccess uid ct cl = do catchSuspendInactiveUser uid LoginSuspended r <- lift $ newCookieLimited uid ct cl @@ -214,7 +214,7 @@ newAccess uid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing return $ Access t (Just ck) -resolveLoginId :: LoginId -> ExceptT LoginError AppIO UserId +resolveLoginId :: LoginId -> ExceptT LoginError (AppIO r) UserId resolveLoginId li = do usr <- validateLoginId li >>= lift . either lookupKey lookupHandle case usr of @@ -226,7 +226,7 @@ resolveLoginId li = do else LoginFailed Just uid -> return uid -validateLoginId :: LoginId -> ExceptT LoginError AppIO (Either UserKey Handle) +validateLoginId :: LoginId -> ExceptT LoginError (AppIO r) (Either UserKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) @@ -240,7 +240,7 @@ validateLoginId (LoginByPhone phone) = validateLoginId (LoginByHandle h) = return (Right h) -isPendingActivation :: LoginId -> AppIO Bool +isPendingActivation :: LoginId -> (AppIO r) Bool isPendingActivation ident = case ident of (LoginByHandle _) -> return False (LoginByEmail e) -> checkKey (userEmailKey e) @@ -274,13 +274,13 @@ validateTokens :: ZAuth.TokenPair u a => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) validateTokens uts at = do tokens <- forM uts $ \ut -> lift $ runExceptT (validateToken ut at) getFirstSuccessOrFirstFail tokens where -- FUTUREWORK: There is surely a better way to do this - getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + getFirstSuccessOrFirstFail :: List1 (Either ZAuth.Failure (UserId, Cookie (ZAuth.Token u))) -> ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) getFirstSuccessOrFirstFail tks = case (lefts $ NE.toList $ List1.toNonEmpty tks, rights $ NE.toList $ List1.toNonEmpty tks) of (_, (suc : _)) -> return suc ((e : _), _) -> throwE e @@ -290,7 +290,7 @@ validateToken :: ZAuth.TokenPair u a => ZAuth.Token u -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure AppIO (UserId, Cookie (ZAuth.Token u)) + ExceptT ZAuth.Failure (AppIO r) (UserId, Cookie (ZAuth.Token u)) validateToken ut at = do unless (maybe True ((ZAuth.userTokenOf ut ==) . ZAuth.accessTokenOf) at) $ throwE ZAuth.Invalid @@ -303,7 +303,7 @@ validateToken ut at = do return (ZAuth.userTokenOf ut, ck) -- | Allow to login as any user without having the credentials. -ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError AppIO (Access ZAuth.User) +ssoLogin :: SsoLogin -> CookieType -> ExceptT LoginError (AppIO r) (Access ZAuth.User) ssoLogin (SsoLogin uid label) typ = do Data.reauthenticate uid Nothing `catchE` \case ReAuthMissingPassword -> pure () @@ -316,7 +316,7 @@ ssoLogin (SsoLogin uid label) typ = do newAccess @ZAuth.User @ZAuth.Access uid typ label -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. -legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError AppIO (Access ZAuth.LegalHoldUser) +legalHoldLogin :: LegalHoldLogin -> CookieType -> ExceptT LegalHoldLoginError (AppIO r) (Access ZAuth.LegalHoldUser) legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do Data.reauthenticate uid plainTextPassword !>> LegalHoldReAuthError -- legalhold login is only possible if @@ -330,7 +330,7 @@ legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid typ label !>> LegalHoldLoginError -assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError AppIO () +assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError (AppIO r) () assertLegalHoldEnabled tid = do stat <- lift $ Intra.getTeamLegalHoldStatus tid case tfwoStatus stat of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 1bb09328eaf..28023f58636 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -68,7 +68,7 @@ newCookie :: UserId -> CookieType -> Maybe CookieLabel -> - AppIO (Cookie (ZAuth.Token u)) + (AppIO r) (Cookie (ZAuth.Token u)) newCookie uid typ label = do now <- liftIO =<< view currentTime tok <- @@ -90,7 +90,7 @@ newCookie uid typ label = do -- | Renew the given cookie with a fresh token, if its age -- exceeds the configured minimum threshold. -nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Maybe (Cookie (ZAuth.Token u))) +nextCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) nextCookie c = do s <- view settings now <- liftIO =<< view currentTime @@ -116,7 +116,7 @@ nextCookie c = do return c' {cookieValue = t} -- | Renew the given cookie with a fresh token. -renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> AppIO (Cookie (ZAuth.Token u)) +renewCookie :: ZAuth.UserTokenLike u => Cookie (ZAuth.Token u) -> (AppIO r) (Cookie (ZAuth.Token u)) renewCookie old = do let t = cookieValue old let uid = ZAuth.userTokenOf t @@ -134,7 +134,7 @@ renewCookie old = do -- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', -- 'newCookieLimited' if there is a chance that the user should be suspended (we don't do it -- implicitly because of cyclical dependencies). -mustSuspendInactiveUser :: UserId -> AppIO Bool +mustSuspendInactiveUser :: UserId -> (AppIO r) Bool mustSuspendInactiveUser uid = view (settings . to setSuspendInactiveUsers) >>= \case Nothing -> pure False @@ -151,7 +151,7 @@ mustSuspendInactiveUser uid = | otherwise = True pure mustSuspend -newAccessToken :: forall u a. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> AppIO AccessToken +newAccessToken :: forall u a r. ZAuth.TokenPair u a => Cookie (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> (AppIO r) AccessToken newAccessToken c mt = do t' <- case mt of Nothing -> ZAuth.newAccessToken (cookieValue c) @@ -166,7 +166,7 @@ newAccessToken c mt = do -- | Lookup the stored cookie associated with a user token, -- if one exists. -lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> AppIO (Maybe (Cookie (ZAuth.Token u))) +lookupCookie :: ZAuth.UserTokenLike u => ZAuth.Token u -> (AppIO r) (Maybe (Cookie (ZAuth.Token u))) lookupCookie t = do let user = ZAuth.userTokenOf t let rand = ZAuth.userTokenRand t @@ -175,16 +175,16 @@ lookupCookie t = do where setToken c = c {cookieValue = t} -listCookies :: UserId -> [CookieLabel] -> AppIO [Cookie ()] +listCookies :: UserId -> [CookieLabel] -> (AppIO r) [Cookie ()] listCookies u [] = DB.listCookies u listCookies u ll = filter byLabel <$> DB.listCookies u where byLabel c = maybe False (`elem` ll) (cookieLabel c) -revokeAllCookies :: UserId -> AppIO () +revokeAllCookies :: UserId -> (AppIO r) () revokeAllCookies u = revokeCookies u [] [] -revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> AppIO () +revokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> (AppIO r) () revokeCookies u [] [] = DB.deleteAllCookies u revokeCookies u ids labels = do cc <- filter matching <$> DB.listCookies u @@ -202,7 +202,7 @@ newCookieLimited :: UserId -> CookieType -> Maybe CookieLabel -> - AppIO (Either RetryAfter (Cookie (ZAuth.Token t))) + (AppIO r) (Either RetryAfter (Cookie (ZAuth.Token t))) newCookieLimited u typ label = do cs <- filter ((typ ==) . cookieType) <$> DB.listCookies u now <- liftIO =<< view currentTime @@ -246,7 +246,7 @@ setResponseCookie c r = do -------------------------------------------------------------------------------- -- Tracking -trackSuperseded :: UserId -> CookieId -> AppIO () +trackSuperseded :: UserId -> CookieId -> (AppIO r) () trackSuperseded u c = do m <- view metrics Metrics.counterIncr (Metrics.path "user.auth.cookie.superseded") m diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 1a089b56da7..b1c4d49c730 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -40,19 +40,19 @@ import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (EJPDRequestBody), EJ import qualified Wire.API.Team.Member as Team import Wire.API.User (User, userDisplayName, userEmail, userHandle, userId, userPhone, userTeam) -ejpdRequest :: Maybe Bool -> EJPDRequestBody -> Handler EJPDResponseBody +ejpdRequest :: Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where -- find uid given handle - go1 :: Bool -> Handle -> AppIO (Maybe EJPDResponseItem) + go1 :: Bool -> Handle -> (AppIO r) (Maybe EJPDResponseItem) go1 includeContacts' handle = do mbUid <- lookupHandle handle mbUsr <- maybe (pure Nothing) (lookupUser NoPendingInvitations) mbUid maybe (pure Nothing) (fmap Just . go2 includeContacts') mbUsr -- construct response item given uid - go2 :: Bool -> User -> AppIO EJPDResponseItem + go2 :: Bool -> User -> (AppIO r) EJPDResponseItem go2 includeContacts' target = do let uid = userId target diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs index 1a58f57285e..b1c3e11c6a0 100644 --- a/services/brig/src/Brig/User/Email.hs +++ b/services/brig/src/Brig/User/Email.hs @@ -45,14 +45,14 @@ import qualified Data.Text.Ascii as Ascii import Data.Text.Lazy (toStrict) import Imports -sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> AppIO () +sendVerificationMail :: Email -> ActivationPair -> Maybe Locale -> (AppIO r) () sendVerificationMail to pair loc = do tpl <- verificationEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = VerificationEmail to pair Email.sendMail $ renderVerificationMail mail tpl branding -sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> AppIO () +sendActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Maybe UserIdentity -> (AppIO r) () sendActivationMail to name pair loc ident = do tpl <- selectTemplate . snd <$> userTemplates loc branding <- view templateBranding @@ -64,26 +64,26 @@ sendActivationMail to name pair loc ident = do then activationEmail else activationEmailUpdate -sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> AppIO () +sendPasswordResetMail :: Email -> PasswordResetPair -> Maybe Locale -> (AppIO r) () sendPasswordResetMail to pair loc = do tpl <- passwordResetEmail . snd <$> userTemplates loc branding <- view templateBranding let mail = PasswordResetEmail to pair Email.sendMail $ renderPwResetMail mail tpl branding -sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> AppIO () +sendDeletionEmail :: Name -> Email -> Code.Key -> Code.Value -> Locale -> (AppIO r) () sendDeletionEmail name email key code locale = do tpl <- deletionEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderDeletionEmail tpl (DeletionEmail email name key code) branding -sendNewClientEmail :: Name -> Email -> Client -> Locale -> AppIO () +sendNewClientEmail :: Name -> Email -> Client -> Locale -> (AppIO r) () sendNewClientEmail name email client locale = do tpl <- newClientEmail . snd <$> userTemplates (Just locale) branding <- view templateBranding Email.sendMail $ renderNewClientEmail tpl (NewClientEmail locale email name client) branding -sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> AppIO () +sendTeamActivationMail :: Email -> Name -> ActivationPair -> Maybe Locale -> Text -> (AppIO r) () sendTeamActivationMail to name pair loc team = do tpl <- teamActivationEmail . snd <$> userTemplates loc let mail = TeamActivationEmail to name team pair diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 1f53d68492d..5616c5efb85 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -34,7 +34,7 @@ import Data.Id import Imports -- | Claim a new handle for an existing 'User'. -claimHandle :: UserId -> Maybe Handle -> Handle -> AppIO Bool +claimHandle :: UserId -> Maybe Handle -> Handle -> (AppIO r) Bool claimHandle uid oldHandle newHandle = isJust <$> do owner <- lookupHandle newHandle @@ -56,19 +56,19 @@ claimHandle uid oldHandle newHandle = return result -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: UserId -> Handle -> AppIO () +freeHandle :: UserId -> Handle -> (AppIO r) () freeHandle uid h = do 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 :: Handle -> (AppIO r) (Maybe UserId) lookupHandle = lookupHandleWithPolicy LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. -glimpseHandle :: Handle -> AppIO (Maybe UserId) +glimpseHandle :: Handle -> (AppIO r) (Maybe UserId) glimpseHandle = lookupHandleWithPolicy One {-# INLINE lookupHandleWithPolicy #-} @@ -78,7 +78,7 @@ glimpseHandle = lookupHandleWithPolicy One -- -- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' -- and only allowing it to be parsed. -lookupHandleWithPolicy :: Consistency -> Handle -> AppIO (Maybe UserId) +lookupHandleWithPolicy :: Consistency -> Handle -> (AppIO r) (Maybe UserId) lookupHandleWithPolicy policy h = do join . fmap runIdentity <$> retry x1 (query1 handleSelect (params policy (Identity h))) diff --git a/services/brig/src/Brig/User/Phone.hs b/services/brig/src/Brig/User/Phone.hs index 31ab888f2ac..a172780d083 100644 --- a/services/brig/src/Brig/User/Phone.hs +++ b/services/brig/src/Brig/User/Phone.hs @@ -52,37 +52,37 @@ import Data.Text.Lazy (toStrict) import Imports import qualified Ropes.Nexmo as Nexmo -sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> AppIO () +sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () sendActivationSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) branding -sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> AppIO () +sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> (AppIO r) () sendPasswordResetSms to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) branding -sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> AppIO () +sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () sendLoginSms to code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) branding -sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> AppIO () +sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> (AppIO r) () sendDeletionSms to key code loc = do branding <- view templateBranding (loc', tpl) <- userTemplates (Just loc) sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) branding -sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> AppIO () +sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> (AppIO r) () sendActivationCall to (_, c) loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' branding -sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> AppIO () +sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> (AppIO r) () sendLoginCall to c loc = do branding <- view templateBranding (loc', tpl) <- userTemplates loc From 5a71262a92a36a49486286ea9fee1acf83bc88b1 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 18 Feb 2022 11:31:30 +0100 Subject: [PATCH 56/58] Changelog --- CHANGELOG.md | 61 +++++++++++++++++++ changelog.d/0-release-notes/TR-02102-2 | 1 - .../0-release-notes/api-version-prefix | 1 - changelog.d/0-release-notes/pr-2076 | 1 - changelog.d/0-release-notes/pr-2117 | 2 - changelog.d/0-release-notes/pr-2124 | 1 - .../0-release-notes/team-settings-upgrade | 1 - changelog.d/0-release-notes/webapp-upgrade | 1 - .../1-api-changes/api-version-endpoint | 1 - changelog.d/1-api-changes/delete-self-name | 1 - changelog.d/1-api-changes/pr-2124 | 1 - .../2-features/federated-freetext-search | 1 - changelog.d/3-bug-fixes/PR-2103 | 1 - .../3-bug-fixes/fix-respond-empty-swagger | 1 - changelog.d/3-bug-fixes/pr-2084 | 1 - changelog.d/3-bug-fixes/pr-2096 | 1 - changelog.d/5-internal/brig-named-routes | 1 - changelog.d/5-internal/brig-polysemy-row | 1 - changelog.d/5-internal/cabal-builds | 1 - changelog.d/5-internal/cabal-oci-build | 1 - changelog.d/5-internal/drop-managed-convs | 1 - changelog.d/5-internal/gundeck-debug-logs | 4 -- changelog.d/5-internal/i-tests | 1 - .../5-internal/move-internal-endpoints | 1 - changelog.d/5-internal/nix-fix-build-shell | 1 - changelog.d/5-internal/pr-2099 | 1 - changelog.d/5-internal/pr-2138 | 2 - .../prometheus-ignore-raw-responses | 1 - .../5-internal/refactor-proteus-conv-create | 1 - changelog.d/5-internal/servantification | 1 - .../5-internal/servantify-cannon-internal-api | 1 - .../5-internal/servantify-conversations | 1 - ...pecify-sending-to-deleted-legalhold-device | 1 - changelog.d/6-federation/pr-2139 | 1 - changelog.d/6-federation/restund | 1 - 35 files changed, 61 insertions(+), 39 deletions(-) delete mode 100644 changelog.d/0-release-notes/TR-02102-2 delete mode 100644 changelog.d/0-release-notes/api-version-prefix delete mode 100644 changelog.d/0-release-notes/pr-2076 delete mode 100644 changelog.d/0-release-notes/pr-2117 delete mode 100644 changelog.d/0-release-notes/pr-2124 delete mode 100644 changelog.d/0-release-notes/team-settings-upgrade delete mode 100644 changelog.d/0-release-notes/webapp-upgrade delete mode 100644 changelog.d/1-api-changes/api-version-endpoint delete mode 100644 changelog.d/1-api-changes/delete-self-name delete mode 100644 changelog.d/1-api-changes/pr-2124 delete mode 100644 changelog.d/2-features/federated-freetext-search delete mode 100644 changelog.d/3-bug-fixes/PR-2103 delete mode 100644 changelog.d/3-bug-fixes/fix-respond-empty-swagger delete mode 100644 changelog.d/3-bug-fixes/pr-2084 delete mode 100644 changelog.d/3-bug-fixes/pr-2096 delete mode 100644 changelog.d/5-internal/brig-named-routes delete mode 100644 changelog.d/5-internal/brig-polysemy-row delete mode 100644 changelog.d/5-internal/cabal-builds delete mode 100644 changelog.d/5-internal/cabal-oci-build delete mode 100644 changelog.d/5-internal/drop-managed-convs delete mode 100644 changelog.d/5-internal/gundeck-debug-logs delete mode 100644 changelog.d/5-internal/i-tests delete mode 100644 changelog.d/5-internal/move-internal-endpoints delete mode 100644 changelog.d/5-internal/nix-fix-build-shell delete mode 100644 changelog.d/5-internal/pr-2099 delete mode 100644 changelog.d/5-internal/pr-2138 delete mode 100644 changelog.d/5-internal/prometheus-ignore-raw-responses delete mode 100644 changelog.d/5-internal/refactor-proteus-conv-create delete mode 100644 changelog.d/5-internal/servantification delete mode 100644 changelog.d/5-internal/servantify-cannon-internal-api delete mode 100644 changelog.d/5-internal/servantify-conversations delete mode 100644 changelog.d/5-internal/specify-sending-to-deleted-legalhold-device delete mode 100644 changelog.d/6-federation/pr-2139 delete mode 100644 changelog.d/6-federation/restund diff --git a/CHANGELOG.md b/CHANGELOG.md index 171867e5223..1b04ef75bbd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,64 @@ +# [2022-02-21] + +## Release notes + +* For wire.com operators: to enable versioned API paths, make sure that nginz is deployed. (#2116) +* Enforce conversation access roles more tightly on the backend: if a guests or non-team-members are not allowed, block guest link creation (new behavior) as well as ephemeral users joining (old behavior). (#2076) +* Optional team feature config `validateSAMLEmails` added to galley.yaml. + The feature was disabled by default before this release and is now enabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#validate-saml-emails](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#validate-saml-emails) (#2117) +* This change requires an nginz upgrade to expose the newly added endpoint for sending a verification code. (#2124) +* Upgrade team-settings version to 4.6.1-v0.29.3-0-28cbbd7 (#2106) +* Change the default set of TLS ciphers (both for the client and the federation APIs) to be compliant to the recommendations of [TR-02102-2](https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html). (#2112) +* Upgrade webapp version to 2022-02-08-production.0-v0.29.2-0-4d437bb (#2107) + +## API changes + +* Added minimal API version support: a list of supported API versions can be found at the endpoint `GET /api-version`. Versions can be selected by adding a prefix of the form `/vN` to every route, where `N` is the desired version number (so for example `/v1/conversations` to access version 1 of the `/conversations` endpoint). (#2116) +* Delete `GET /self/name` endpoint (#2101) +* New endpoint (`POST /verification-code/send`) for generating and sending a verification code for 2nd factor authentication actions. (#2124) + +## Features + +* Add freetext search results to "search-users" federation endpoint (#2085) + +## Bug fixes and other updates + +* Ensure empty responses show up without a schema in swagger. They were shown as empty arrays before. (#2104) +* Ensure the guest links feature is enabled when someone joins by code. (#2084) +* Escape disallowed characters at the beginning of CSV cells to prevent CSV injection vulnerability. (#2096) +* The field `icon` in the body of the `PUT /team/:tid` endpoint is now typed to prevent potential injection attacks. (#2103) + +## Internal changes + +* Remove uses of servant-generics from brig (#2100) +* Introduce the row type variable in Brig monads (#2140) +* Build ubuntu20 docker images with cabal instead of stack (#2119) +* Add cabal build caches to ubuntu20 prebuilder and builder images (#2060) +* Drop managed conversations (#2125) +* To investigate issues related to push notifications, adjust Gundeck `Debug` + leveled logs to not print the message itself. So, that it can safely be turned + on in production environments. Add a log entry when a bulk notification is + pushed to Cannon. (#2053) +* Add integration tests for scim/saml user creation (#2123) +* Remove servant-generic from internal endpoints and remove them from Swagger (#2086) +* Wrap stack with NIX_BUILD_SHELL set to LD_LIBRARY_PATH compatible shell (#2105) +* Removed redundant `setDefaultTemplateLocale` config from the brig helm template. (#2099) +* [not done yet, please do not enable] Optional team feature config `sndFactorPasswordChallenge` added to galley.yaml. + The feature is disabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#2nd-factor-password-challenge](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#2nd-factor-password-challenge) (#2138) +* Prometheus: Ignore RawResponses (e.g. cannon's await responses) from metrics (#2108) +* Refactor internal handlers for Proteus conversation creation (#2125) +* Servantify /self/* endpoints in brig. (#2091) +* Migrate the internal API of Cannon to Servant. (#2081) +* Convert galley conversation endpoints to Servant (#2016) +* Specify (in a test) how a message to a deleted legalhold device is refused to be sent. (#2131) + +## Federation changes + +* Add `setSftListAllServers` config flag to brig (#2139) +* Revert restund to 0.4.17. (#2114) + + + # [2022-02-02] ## Release notes diff --git a/changelog.d/0-release-notes/TR-02102-2 b/changelog.d/0-release-notes/TR-02102-2 deleted file mode 100644 index 5693a4acf0f..00000000000 --- a/changelog.d/0-release-notes/TR-02102-2 +++ /dev/null @@ -1 +0,0 @@ -Change the default set of TLS ciphers (both for the client and the federation APIs) to be compliant to the recommendations of [TR-02102-2](https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html). diff --git a/changelog.d/0-release-notes/api-version-prefix b/changelog.d/0-release-notes/api-version-prefix deleted file mode 100644 index 0622cdb3d2a..00000000000 --- a/changelog.d/0-release-notes/api-version-prefix +++ /dev/null @@ -1 +0,0 @@ -For wire.com operators: to enable versioned API paths, make sure that nginz is deployed. diff --git a/changelog.d/0-release-notes/pr-2076 b/changelog.d/0-release-notes/pr-2076 deleted file mode 100644 index 0c4c7832c97..00000000000 --- a/changelog.d/0-release-notes/pr-2076 +++ /dev/null @@ -1 +0,0 @@ -Enforce conversation access roles more tightly on the backend: if a guests or non-team-members are not allowed, block guest link creation (new behavior) as well as ephemeral users joining (old behavior). diff --git a/changelog.d/0-release-notes/pr-2117 b/changelog.d/0-release-notes/pr-2117 deleted file mode 100644 index e585c88b8c8..00000000000 --- a/changelog.d/0-release-notes/pr-2117 +++ /dev/null @@ -1,2 +0,0 @@ -Optional team feature config `validateSAMLEmails` added to galley.yaml. -The feature was disabled by default before this release and is now enabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#validate-saml-emails](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#validate-saml-emails) diff --git a/changelog.d/0-release-notes/pr-2124 b/changelog.d/0-release-notes/pr-2124 deleted file mode 100644 index 7e2b460e70c..00000000000 --- a/changelog.d/0-release-notes/pr-2124 +++ /dev/null @@ -1 +0,0 @@ -This change requires an nginz upgrade to expose the newly added endpoint for sending a verification code. diff --git a/changelog.d/0-release-notes/team-settings-upgrade b/changelog.d/0-release-notes/team-settings-upgrade deleted file mode 100644 index 1d65468f4de..00000000000 --- a/changelog.d/0-release-notes/team-settings-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade team-settings version to 4.6.1-v0.29.3-0-28cbbd7 diff --git a/changelog.d/0-release-notes/webapp-upgrade b/changelog.d/0-release-notes/webapp-upgrade deleted file mode 100644 index 48ab8b478fc..00000000000 --- a/changelog.d/0-release-notes/webapp-upgrade +++ /dev/null @@ -1 +0,0 @@ -Upgrade webapp version to 2022-02-08-production.0-v0.29.2-0-4d437bb diff --git a/changelog.d/1-api-changes/api-version-endpoint b/changelog.d/1-api-changes/api-version-endpoint deleted file mode 100644 index b41a413a2fd..00000000000 --- a/changelog.d/1-api-changes/api-version-endpoint +++ /dev/null @@ -1 +0,0 @@ -Added minimal API version support: a list of supported API versions can be found at the endpoint `GET /api-version`. Versions can be selected by adding a prefix of the form `/vN` to every route, where `N` is the desired version number (so for example `/v1/conversations` to access version 1 of the `/conversations` endpoint). diff --git a/changelog.d/1-api-changes/delete-self-name b/changelog.d/1-api-changes/delete-self-name deleted file mode 100644 index 312f54d95d3..00000000000 --- a/changelog.d/1-api-changes/delete-self-name +++ /dev/null @@ -1 +0,0 @@ -Delete `GET /self/name` endpoint \ No newline at end of file diff --git a/changelog.d/1-api-changes/pr-2124 b/changelog.d/1-api-changes/pr-2124 deleted file mode 100644 index 9cebece307e..00000000000 --- a/changelog.d/1-api-changes/pr-2124 +++ /dev/null @@ -1 +0,0 @@ -New endpoint (`POST /verification-code/send`) for generating and sending a verification code for 2nd factor authentication actions. diff --git a/changelog.d/2-features/federated-freetext-search b/changelog.d/2-features/federated-freetext-search deleted file mode 100644 index 15f2de58796..00000000000 --- a/changelog.d/2-features/federated-freetext-search +++ /dev/null @@ -1 +0,0 @@ -Add freetext search results to "search-users" federation endpoint diff --git a/changelog.d/3-bug-fixes/PR-2103 b/changelog.d/3-bug-fixes/PR-2103 deleted file mode 100644 index d534ec93f05..00000000000 --- a/changelog.d/3-bug-fixes/PR-2103 +++ /dev/null @@ -1 +0,0 @@ -The field `icon` in the body of the `PUT /team/:tid` endpoint is now typed to prevent potential injection attacks. diff --git a/changelog.d/3-bug-fixes/fix-respond-empty-swagger b/changelog.d/3-bug-fixes/fix-respond-empty-swagger deleted file mode 100644 index dcfc45e28ac..00000000000 --- a/changelog.d/3-bug-fixes/fix-respond-empty-swagger +++ /dev/null @@ -1 +0,0 @@ -Ensure empty responses show up without a schema in swagger. They were shown as empty arrays before. \ No newline at end of file diff --git a/changelog.d/3-bug-fixes/pr-2084 b/changelog.d/3-bug-fixes/pr-2084 deleted file mode 100644 index 315f6ce5156..00000000000 --- a/changelog.d/3-bug-fixes/pr-2084 +++ /dev/null @@ -1 +0,0 @@ -Ensure the guest links feature is enabled when someone joins by code. diff --git a/changelog.d/3-bug-fixes/pr-2096 b/changelog.d/3-bug-fixes/pr-2096 deleted file mode 100644 index e9342d70fcc..00000000000 --- a/changelog.d/3-bug-fixes/pr-2096 +++ /dev/null @@ -1 +0,0 @@ -Escape disallowed characters at the beginning of CSV cells to prevent CSV injection vulnerability. diff --git a/changelog.d/5-internal/brig-named-routes b/changelog.d/5-internal/brig-named-routes deleted file mode 100644 index 1d7179a9047..00000000000 --- a/changelog.d/5-internal/brig-named-routes +++ /dev/null @@ -1 +0,0 @@ -Remove uses of servant-generics from brig diff --git a/changelog.d/5-internal/brig-polysemy-row b/changelog.d/5-internal/brig-polysemy-row deleted file mode 100644 index cdad27dcaaf..00000000000 --- a/changelog.d/5-internal/brig-polysemy-row +++ /dev/null @@ -1 +0,0 @@ -Introduce the row type variable in Brig monads diff --git a/changelog.d/5-internal/cabal-builds b/changelog.d/5-internal/cabal-builds deleted file mode 100644 index 18ff94be6bf..00000000000 --- a/changelog.d/5-internal/cabal-builds +++ /dev/null @@ -1 +0,0 @@ -Build ubuntu20 docker images with cabal instead of stack diff --git a/changelog.d/5-internal/cabal-oci-build b/changelog.d/5-internal/cabal-oci-build deleted file mode 100644 index acaea8d576f..00000000000 --- a/changelog.d/5-internal/cabal-oci-build +++ /dev/null @@ -1 +0,0 @@ -Add cabal build caches to ubuntu20 prebuilder and builder images diff --git a/changelog.d/5-internal/drop-managed-convs b/changelog.d/5-internal/drop-managed-convs deleted file mode 100644 index b854d6bd4d2..00000000000 --- a/changelog.d/5-internal/drop-managed-convs +++ /dev/null @@ -1 +0,0 @@ -Drop managed conversations diff --git a/changelog.d/5-internal/gundeck-debug-logs b/changelog.d/5-internal/gundeck-debug-logs deleted file mode 100644 index 3d5ca38b103..00000000000 --- a/changelog.d/5-internal/gundeck-debug-logs +++ /dev/null @@ -1,4 +0,0 @@ -To investigate issues related to push notifications, adjust Gundeck `Debug` -leveled logs to not print the message itself. So, that it can safely be turned -on in production environments. Add a log entry when a bulk notification is -pushed to Cannon. diff --git a/changelog.d/5-internal/i-tests b/changelog.d/5-internal/i-tests deleted file mode 100644 index 0744635755c..00000000000 --- a/changelog.d/5-internal/i-tests +++ /dev/null @@ -1 +0,0 @@ -Add integration tests for scim/saml user creation \ No newline at end of file diff --git a/changelog.d/5-internal/move-internal-endpoints b/changelog.d/5-internal/move-internal-endpoints deleted file mode 100644 index e92adfa6aa9..00000000000 --- a/changelog.d/5-internal/move-internal-endpoints +++ /dev/null @@ -1 +0,0 @@ -Remove servant-generic from internal endpoints and remove them from Swagger diff --git a/changelog.d/5-internal/nix-fix-build-shell b/changelog.d/5-internal/nix-fix-build-shell deleted file mode 100644 index b76550e9643..00000000000 --- a/changelog.d/5-internal/nix-fix-build-shell +++ /dev/null @@ -1 +0,0 @@ -Wrap stack with NIX_BUILD_SHELL set to LD_LIBRARY_PATH compatible shell diff --git a/changelog.d/5-internal/pr-2099 b/changelog.d/5-internal/pr-2099 deleted file mode 100644 index 22d10b62f50..00000000000 --- a/changelog.d/5-internal/pr-2099 +++ /dev/null @@ -1 +0,0 @@ -Removed redundant `setDefaultTemplateLocale` config from the brig helm template. diff --git a/changelog.d/5-internal/pr-2138 b/changelog.d/5-internal/pr-2138 deleted file mode 100644 index 9e632da4a3a..00000000000 --- a/changelog.d/5-internal/pr-2138 +++ /dev/null @@ -1,2 +0,0 @@ -[not done yet, please do not enable] Optional team feature config `sndFactorPasswordChallenge` added to galley.yaml. -The feature is disabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#2nd-factor-password-challenge](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#2nd-factor-password-challenge) diff --git a/changelog.d/5-internal/prometheus-ignore-raw-responses b/changelog.d/5-internal/prometheus-ignore-raw-responses deleted file mode 100644 index 760a55f92a9..00000000000 --- a/changelog.d/5-internal/prometheus-ignore-raw-responses +++ /dev/null @@ -1 +0,0 @@ -Prometheus: Ignore RawResponses (e.g. cannon's await responses) from metrics diff --git a/changelog.d/5-internal/refactor-proteus-conv-create b/changelog.d/5-internal/refactor-proteus-conv-create deleted file mode 100644 index 6e85b41cd57..00000000000 --- a/changelog.d/5-internal/refactor-proteus-conv-create +++ /dev/null @@ -1 +0,0 @@ -Refactor internal handlers for Proteus conversation creation diff --git a/changelog.d/5-internal/servantification b/changelog.d/5-internal/servantification deleted file mode 100644 index 90e81600ed9..00000000000 --- a/changelog.d/5-internal/servantification +++ /dev/null @@ -1 +0,0 @@ -Servantify /self/* endpoints in brig. \ No newline at end of file diff --git a/changelog.d/5-internal/servantify-cannon-internal-api b/changelog.d/5-internal/servantify-cannon-internal-api deleted file mode 100644 index ee053807a07..00000000000 --- a/changelog.d/5-internal/servantify-cannon-internal-api +++ /dev/null @@ -1 +0,0 @@ -Migrate the internal API of Cannon to Servant. diff --git a/changelog.d/5-internal/servantify-conversations b/changelog.d/5-internal/servantify-conversations deleted file mode 100644 index 44171f8c7ee..00000000000 --- a/changelog.d/5-internal/servantify-conversations +++ /dev/null @@ -1 +0,0 @@ -Convert galley conversation endpoints to Servant diff --git a/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device b/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device deleted file mode 100644 index d4eccbc8486..00000000000 --- a/changelog.d/5-internal/specify-sending-to-deleted-legalhold-device +++ /dev/null @@ -1 +0,0 @@ -Specify (in a test) how a message to a deleted legalhold device is refused to be sent. diff --git a/changelog.d/6-federation/pr-2139 b/changelog.d/6-federation/pr-2139 deleted file mode 100644 index f3324ee9f48..00000000000 --- a/changelog.d/6-federation/pr-2139 +++ /dev/null @@ -1 +0,0 @@ -Add `setSftListAllServers` config flag to brig diff --git a/changelog.d/6-federation/restund b/changelog.d/6-federation/restund deleted file mode 100644 index 03249717b65..00000000000 --- a/changelog.d/6-federation/restund +++ /dev/null @@ -1 +0,0 @@ -Revert restund to 0.4.17. From c4f0f578161f4eee4a047d492e8e140b39ccdc6e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 18 Feb 2022 13:54:34 +0100 Subject: [PATCH 57/58] hi ci From 60a85034722eb8e8b1e44b291a956fb09aee6c7a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 18 Feb 2022 17:40:00 +0100 Subject: [PATCH 58/58] Edit Changelog. --- CHANGELOG.md | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1b04ef75bbd..dcc5938707f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,14 +2,12 @@ ## Release notes -* For wire.com operators: to enable versioned API paths, make sure that nginz is deployed. (#2116) -* Enforce conversation access roles more tightly on the backend: if a guests or non-team-members are not allowed, block guest link creation (new behavior) as well as ephemeral users joining (old behavior). (#2076) -* Optional team feature config `validateSAMLEmails` added to galley.yaml. - The feature was disabled by default before this release and is now enabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#validate-saml-emails](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#validate-saml-emails) (#2117) -* This change requires an nginz upgrade to expose the newly added endpoint for sending a verification code. (#2124) * Upgrade team-settings version to 4.6.1-v0.29.3-0-28cbbd7 (#2106) -* Change the default set of TLS ciphers (both for the client and the federation APIs) to be compliant to the recommendations of [TR-02102-2](https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html). (#2112) * Upgrade webapp version to 2022-02-08-production.0-v0.29.2-0-4d437bb (#2107) +* Change the default set of TLS ciphers (both for the client and the federation APIs) to be compliant to the recommendations of [TR-02102-2](https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html). (#2112) +* For wire.com operators: make sure that nginz is deployed. (#2116, #2124) +* Optional team feature config `validateSAMLEmails` added to galley.yaml. + The feature was disabled by default before this release and is now enabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#validate-saml-emails](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#validate-saml-emails) (#2117) ## API changes @@ -24,32 +22,26 @@ ## Bug fixes and other updates * Ensure empty responses show up without a schema in swagger. They were shown as empty arrays before. (#2104) -* Ensure the guest links feature is enabled when someone joins by code. (#2084) +* Require the guest links feature is enabled when someone joins by code. (#2084) * Escape disallowed characters at the beginning of CSV cells to prevent CSV injection vulnerability. (#2096) * The field `icon` in the body of the `PUT /team/:tid` endpoint is now typed to prevent potential injection attacks. (#2103) ## Internal changes -* Remove uses of servant-generics from brig (#2100) +* Enforce conversation access roles more tightly on the backend (was previously only enforce on client): if a guests or non-team-members are not allowed, block guest link creation (new behavior) as well as ephemeral users joining (old behavior). (#2076) +* Remove uses of servant-generics from brig (#2100, #2086) +* Migrate more API end-points to servant. (#2016, #2081, #2091) * Introduce the row type variable in Brig monads (#2140) -* Build ubuntu20 docker images with cabal instead of stack (#2119) -* Add cabal build caches to ubuntu20 prebuilder and builder images (#2060) +* Build ubuntu20 docker images with cabal instead of stack (#2119, #2060) * Drop managed conversations (#2125) -* To investigate issues related to push notifications, adjust Gundeck `Debug` - leveled logs to not print the message itself. So, that it can safely be turned - on in production environments. Add a log entry when a bulk notification is - pushed to Cannon. (#2053) +* To investigate issues related to push notifications, adjust Gundeck `Debug` leveled logs to not print the message itself. So, that it can safely be turned on in production environments. Add a log entry when a bulk notification is pushed to Cannon. (#2053) * Add integration tests for scim/saml user creation (#2123) -* Remove servant-generic from internal endpoints and remove them from Swagger (#2086) * Wrap stack with NIX_BUILD_SHELL set to LD_LIBRARY_PATH compatible shell (#2105) * Removed redundant `setDefaultTemplateLocale` config from the brig helm template. (#2099) * [not done yet, please do not enable] Optional team feature config `sndFactorPasswordChallenge` added to galley.yaml. The feature is disabled by default. The server wide default can be changed in galley.yaml. Please refer to [/docs/reference/config-options.md#2nd-factor-password-challenge](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#2nd-factor-password-challenge) (#2138) * Prometheus: Ignore RawResponses (e.g. cannon's await responses) from metrics (#2108) * Refactor internal handlers for Proteus conversation creation (#2125) -* Servantify /self/* endpoints in brig. (#2091) -* Migrate the internal API of Cannon to Servant. (#2081) -* Convert galley conversation endpoints to Servant (#2016) * Specify (in a test) how a message to a deleted legalhold device is refused to be sent. (#2131) ## Federation changes