From 840758bf52c14e755227e49dcce2f65c8929a8df Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 13 Oct 2025 09:12:54 +0200 Subject: [PATCH 01/30] Add Spar.Scim.Group module. Create scim user group in subsystem. createScimGroupImpl (wip) Unit tests, mostly. More unit test stuff. Test works: create scim user group, get it back. Add failing unit test (no non-scim users in scim groups). Make unit test pass (wip). Add pending test case for getScimGroup. Tweak probability distribution over test cases. Fix typo Better name for effect action. Connect scim subsystem to api in spar. (wip) rm unused library import in spar.cabal update obsolete comment hook scim subsystem into spar. (wip) Extend spar env to handle scim subsystem. (wip) drive-by refactoring. ScimSubsystem error handling in spar. Fixup Add effects to spar: GalleyAPIAccess, TeamSubsystem Removed TODO (this is not what we should focus on!) Fill in more effects in Spar.CanonicalInterpreter. Add {user,auth}subsystem to spar. Entire code base: rework error handling [WIP] fixup check point: spar compiles with undefineds fix: complete most of the interpreters Blindly fix some compiler errors. Transplanting AWS code out of brig into wire-subsystems [WIP] fix: Wire.EmailSending.Core fail with strategy fix: Wire.EmailSending.Core & Wire.AWSSubsystem.AWS fix: bind AWSSubsystem refactor: migrate Queue/DeleteQueue refactor: move Events refactor: move more stuff and complete the interpreters stack start fetching options (missing ES) ES binding fix: missing config fix: integration test config fix: deduplicate resources ... --- charts/spar/templates/configmap.yaml | 13 + charts/spar/values.yaml | 15 + integration/test/API/Spar.hs | 6 + integration/test/Test/Spar.hs | 23 +- libs/hscim/default.nix | 4 + libs/hscim/hscim.cabal | 2 + libs/hscim/src/Web/Scim/Schema/Common.hs | 7 + libs/hscim/src/Web/Scim/Schema/Error.hs | 18 +- libs/types-common/src/Data/Id.hs | 4 + .../src/Wire/API/Routes/Public/Spar.hs | 8 +- libs/wire-api/src/Wire/API/User/Scim.hs | 2 +- libs/wire-subsystems/default.nix | 21 + libs/wire-subsystems/src/Wire/AWSSubsystem.hs | 64 +++ .../src/Wire/AWSSubsystem}/AWS.hs | 135 +++--- .../src/Wire/ConnectionStore.hs | 145 ++++++ .../src/Wire/ConnectionStore/Cassandra.hs | 450 ++++++++++++++++++ .../src/Wire/ConnectionStore/Types.hs | 44 +- .../src/Wire}/DeleteQueue/Interpreter.hs | 21 +- .../src/Wire/DeleteQueue/Listen.hs | 29 +- .../src/Wire/DeleteQueue}/Types.hs | 21 +- .../src/Wire/EmailSending/Core.hs | 24 + libs/wire-subsystems/src/Wire/Error.hs | 12 + .../src/Wire/Events/Interpreter.hs | 188 ++++++++ .../src/Wire/Events/Journal.hs | 144 ++++++ .../src/Wire/Events/Notifications.hs | 291 +++++++++++ .../src/Wire/GalleyAPIAccess.hs | 3 + .../src/Wire/GalleyAPIAccess/Rpc.hs | 24 + .../src/Wire/ParseException.hs | 4 + .../wire-subsystems/src/Wire/ScimSubsystem.hs | 13 + .../src/Wire/ScimSubsystem/Interpreter.hs | 118 +++++ .../src/Wire/StompSubsystem.hs | 25 +- .../src/Wire/StompSubsystem}/Stomp.hs | 156 ++++-- .../src/Wire/UserGroupSubsystem.hs | 2 + .../Wire/UserGroupSubsystem/Interpreter.hs | 30 +- .../test/resources/internal-notification.json | 0 .../Wire/MockInterpreters/GalleyAPIAccess.hs | 1 + .../Wire/MockInterpreters/UserSubsystem.hs | 2 + .../Wire/ScimSubsystem/InterpreterSpec.hs | 113 +++++ .../UserGroupSubsystem/InterpreterSpec.hs | 15 +- libs/wire-subsystems/wire-subsystems.cabal | 25 + services/brig/brig.cabal | 16 - services/brig/default.nix | 12 - services/brig/src/Brig/API/Handler.hs | 4 +- services/brig/src/Brig/API/Public.hs | 14 +- services/brig/src/Brig/API/User.hs | 14 +- services/brig/src/Brig/App.hs | 27 +- .../brig/src/Brig/CanonicalInterpreter.hs | 24 +- services/brig/src/Brig/Data/Client.hs | 23 +- services/brig/src/Brig/IO/Intra.hs | 318 +------------ services/brig/src/Brig/IO/Journal.hs | 80 ---- services/brig/src/Brig/Options.hs | 58 +-- services/brig/src/Brig/Run.hs | 14 +- services/brig/test/integration/API/User.hs | 2 +- .../brig/test/integration/API/User/Account.hs | 12 +- services/brig/test/integration/Run.hs | 8 +- services/brig/test/integration/Util/AWS.hs | 2 +- .../unit/Test/Brig/InternalNotification.hs | 2 +- services/spar/default.nix | 16 + services/spar/spar.cabal | 11 + services/spar/spar.integration.yaml | 89 ++++ services/spar/src/Spar/API.hs | 4 + services/spar/src/Spar/App.hs | 77 ++- .../spar/src/Spar/CanonicalInterpreter.hs | 344 +++++++++++-- services/spar/src/Spar/Data/Instances.hs | 2 - services/spar/src/Spar/Error.hs | 151 +++--- services/spar/src/Spar/Options.hs | 159 ++++++- services/spar/src/Spar/Run.hs | 194 +++++++- services/spar/src/Spar/Scim.hs | 13 +- services/spar/src/Spar/Scim/Group.hs | 96 ++++ .../src/Spar/Sem/DefaultSsoCode/Cassandra.hs | 1 + services/spar/src/Spar/Sem/GalleyAccess.hs | 2 +- .../src/Spar/Sem/IdPConfigStore/Cassandra.hs | 1 + .../Spar/Sem/IdPRawMetadataStore/Cassandra.hs | 1 + .../src/Spar/Sem/ScimTokenStore/Cassandra.hs | 1 + services/spar/test-integration/Util/Core.hs | 18 + 75 files changed, 3171 insertions(+), 861 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/AWSSubsystem.hs rename {services/brig/src/Brig => libs/wire-subsystems/src/Wire/AWSSubsystem}/AWS.hs (67%) create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore.hs create mode 100644 libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs rename services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs => libs/wire-subsystems/src/Wire/ConnectionStore/Types.hs (54%) rename {services/brig/src/Brig => libs/wire-subsystems/src/Wire}/DeleteQueue/Interpreter.hs (79%) rename services/brig/src/Brig/Queue.hs => libs/wire-subsystems/src/Wire/DeleteQueue/Listen.hs (65%) rename {services/brig/src/Brig/Queue => libs/wire-subsystems/src/Wire/DeleteQueue}/Types.hs (68%) create mode 100644 libs/wire-subsystems/src/Wire/EmailSending/Core.hs create mode 100644 libs/wire-subsystems/src/Wire/Events/Interpreter.hs create mode 100644 libs/wire-subsystems/src/Wire/Events/Journal.hs create mode 100644 libs/wire-subsystems/src/Wire/Events/Notifications.hs create mode 100644 libs/wire-subsystems/src/Wire/ScimSubsystem.hs create mode 100644 libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs rename services/brig/src/Brig/Effects/ConnectionStore.hs => libs/wire-subsystems/src/Wire/StompSubsystem.hs (59%) rename {services/brig/src/Brig/Queue => libs/wire-subsystems/src/Wire/StompSubsystem}/Stomp.hs (61%) rename {services/brig => libs/wire-subsystems}/test/resources/internal-notification.json (100%) create mode 100644 libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs delete mode 100644 services/brig/src/Brig/IO/Journal.hs create mode 100644 services/spar/src/Spar/Scim/Group.hs diff --git a/charts/spar/templates/configmap.yaml b/charts/spar/templates/configmap.yaml index df546f05ea..39d33db4ca 100644 --- a/charts/spar/templates/configmap.yaml +++ b/charts/spar/templates/configmap.yaml @@ -29,6 +29,19 @@ data: tlsCa: /etc/wire/spar/cassandra/{{- (include "tlsSecretRef" . | fromYaml).key }} {{- end }} + elasticsearch: + url: {{ .elasticsearch.scheme }}://{{ .elasticsearch.host }}:{{ .elasticsearch.port }} + index: {{ .elasticsearch.index }} + insecureSkipVerifyTls: {{ .elasticsearch.insecureSkipVerifyTls }} + {{- if $.Values.secrets.elasticsearch }} + credentials: /etc/wire/spar/secrets/elasticsearch-credentials.yaml + {{- end }} + {{- if .elasticsearch.tlsCa }} + caCert: /etc/wire/spar/elasticsearch/ca.pem + {{- else if .elasticsearch.tlsCaSecretRef }} + caCert: /etc/wire/spar/elasticsearch/{{- .elasticsearch.tlsCaSecretRef.key }} + {{- end }} + maxttlAuthreq: {{ .maxttlAuthreq }} maxttlAuthresp: {{ .maxttlAuthresp }} diff --git a/charts/spar/values.yaml b/charts/spar/values.yaml index 93f7ee0aca..e1fb9e1007 100644 --- a/charts/spar/values.yaml +++ b/charts/spar/values.yaml @@ -24,6 +24,21 @@ config: # tlsCaSecretRef: # name: # key: + + elasticsearch: + scheme: http + host: elasticsearch-client + port: 9200 + index: directory_spar + insecureSkipVerifyTls: false +# To configure custom TLS CA, please provide one of these: +# tlsCa: +# +# Or refer to an existing secret (containing the CA): +# tlsCaSecretRef: +# name: +# key: + richInfoLimit: 5000 maxScimTokens: 0 logLevel: Info diff --git a/integration/test/API/Spar.hs b/integration/test/API/Spar.hs index 01006c1c19..fca9706e52 100644 --- a/integration/test/API/Spar.hs +++ b/integration/test/API/Spar.hs @@ -91,6 +91,12 @@ updateScimUser domain scimToken userId scimUser = do & addJSON body . addHeader "Authorization" ("Bearer " <> scimToken) & addHeader "Accept" "application/scim+json" +createScimUserGroup :: (HasCallStack, MakesValue domain, MakesValue scimUserGroup) => domain -> String -> scimUserGroup -> App Response +createScimUserGroup domain token scimUserGroup = do + req <- baseRequest domain Spar Versioned "/scim/v2/Groups" + body <- make scimUserGroup + submit "POST" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token) + -- | https://staging-nginz-https.zinfra.io/v12/api/swagger-ui/#/default/idp-create createIdp :: (HasCallStack, MakesValue user) => user -> SAML.IdPMetadata -> App Response createIdp user metadata = do diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index f23ec9ee6f..adf8c240e0 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-ambiguous-fields #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-ambiguous-fields #-} module Test.Spar where @@ -362,6 +362,27 @@ testSparCreateScimTokenWithName = do assoc <- token %. "id" token %. "name" `shouldMatch` Just assoc +---------------------------------------------------------------------- +-- scim group stuff + +testSparScimCreateUserGroup :: (HasCallStack) => App () +testSparScimCreateUserGroup = do + (owner, _, _) <- createTeam OwnDomain 1 + tok <- createScimTokenV6 owner def >>= \resp -> resp.json %. "token" >>= asString + let scimUserGroup = + object + [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"], + "displayName" .= "ze groop", + "members" + .= [ object + [ "typ" .= "User", + "$ref" .= "https://...", -- TODO: we should probably validate these? or just ignore them? + "value" .= "ea2e4bf0-aa5e-11f0-96ad-e776a606779b" + ] + ] + ] + createScimUserGroup OwnDomain tok scimUserGroup >>= assertSuccess + ---------------------------------------------------------------------- -- saml stuff diff --git a/libs/hscim/default.nix b/libs/hscim/default.nix index 61e531ab08..b5ef996525 100644 --- a/libs/hscim/default.nix +++ b/libs/hscim/default.nix @@ -41,9 +41,11 @@ , template-haskell , text , time +, utf8-string , uuid , wai , wai-extra +, wai-utilities , warp }: mkDerivation { @@ -85,9 +87,11 @@ mkDerivation { template-haskell text time + utf8-string uuid wai wai-extra + wai-utilities ]; executableHaskellDepends = [ base diff --git a/libs/hscim/hscim.cabal b/libs/hscim/hscim.cabal index d352ac4014..4e192b31cd 100644 --- a/libs/hscim/hscim.cabal +++ b/libs/hscim/hscim.cabal @@ -115,9 +115,11 @@ library , template-haskell , text , time + , utf8-string , uuid , wai , wai-extra + , wai-utilities default-language: Haskell2010 diff --git a/libs/hscim/src/Web/Scim/Schema/Common.hs b/libs/hscim/src/Web/Scim/Schema/Common.hs index 4bceab55c0..c0adb84c21 100644 --- a/libs/hscim/src/Web/Scim/Schema/Common.hs +++ b/libs/hscim/src/Web/Scim/Schema/Common.hs @@ -29,6 +29,7 @@ import qualified Data.CaseInsensitive as CI import Data.List (nub, (\\)) import Data.String.Conversions (cs) import Data.Text (Text, pack, unpack) +import qualified Data.Text as Text import qualified Network.URI as Network data WithId id a = WithId @@ -49,6 +50,12 @@ instance (FromJSON id, FromJSON a) => FromJSON (WithId id a) where newtype URI = URI {unURI :: Network.URI} deriving (Show, Eq) +uriToString :: URI -> String +uriToString = (\uri -> Network.uriToString Prelude.id uri "") . unURI + +uriToText :: URI -> Text +uriToText = Text.pack . uriToString + instance FromJSON URI where parseJSON = withText "URI" $ \uri -> case Network.parseURI (unpack uri) of Nothing -> fail "Invalid URI" diff --git a/libs/hscim/src/Web/Scim/Schema/Error.hs b/libs/hscim/src/Web/Scim/Schema/Error.hs index e40be8f541..cd441b13b2 100644 --- a/libs/hscim/src/Web/Scim/Schema/Error.hs +++ b/libs/hscim/src/Web/Scim/Schema/Error.hs @@ -30,15 +30,21 @@ module Web.Scim.Schema.Error forbidden, serverError, - -- * Servant interoperability + -- * Servant/Wai interoperability scimToServerError, + scimToWaiError, ) where import Control.Exception import Data.Aeson hiding (Error) +import Data.ByteString.UTF8 (fromString) import Data.Text (Text, pack) +import qualified Data.Text.Lazy.Encoding as LText import GHC.Generics (Generic) +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.Wai.Utilities.Error as Wai import Servant (ServerError (..)) import Web.Scim.Schema.Common import Web.Scim.Schema.Schema @@ -175,6 +181,16 @@ serverError details = ---------------------------------------------------------------------------- -- Servant +-- | Convert a SCIM 'Error' to a Servant one by encoding it with the +-- appropriate headers. +-- We would like to use Wire.Error.HttpError from wire-subsystems, +-- but hscim can't depend on that. +scimToWaiError :: ScimError -> (Wai.Error, [HTTP.Header]) +scimToWaiError err = (Wai.mkError e "scim-error" (LText.decodeUtf8 $ encode err), hs) + where + e = HTTP.Status (unStatus (status err)) (fromString $ reasonPhrase (status err)) + hs = [("Content-Type", "application/scim+json;charset=utf-8")] + -- | Convert a SCIM 'Error' to a Servant one by encoding it with the -- appropriate headers. scimToServerError :: ScimError -> ServerError diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index ebd24fc53b..6caa61804d 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -39,6 +39,7 @@ module Data.Id ScimTokenId, parseIdFromText, idToText, + idToString, idObjectSchema, IdObject (..), @@ -263,6 +264,9 @@ parseIdFromText = maybe (Left "UUID.fromText failed") (Right . Id) . UUID.fromTe idToText :: Id a -> Text idToText = UUID.toText . toUUID +idToString :: Id a -> String +idToString = UUID.toString . toUUID + instance Cql (Id a) where ctype = retag (ctype :: Tagged UUID ColumnType) toCql = toCql . toUUID 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 1701e2d0fc..09020317e3 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -34,6 +34,7 @@ import Servant.Server.Experimental.Auth import URI.ByteString qualified as URI import Web.Scim.Capabilities.MetaSchema as Scim.Meta import Web.Scim.Class.Auth as Scim.Auth +import Web.Scim.Class.Group as Scim.Group import Web.Scim.Class.User as Scim.User import Wire.API.Deprecated (Deprecated) import Wire.API.Error @@ -260,7 +261,12 @@ data ScimSite tag route = ScimSite route :- Header "Authorization" (Scim.Auth.AuthData tag) :> "Users" - :> ToServantApi (Scim.User.UserSite tag) + :> ToServantApi (Scim.User.UserSite tag), + groups :: + route + :- Header "Authorization" (Scim.Auth.AuthData tag) + :> "Groups" + :> ToServantApi (Scim.Group.GroupSite tag) } deriving (Generic) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index fdb8e1396f..1c83919a1b 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -220,7 +220,7 @@ instance Scim.User.UserTypes SparTag where supportedSchemas = userSchemas instance Scim.Group.GroupTypes SparTag where - type GroupId SparTag = () + type GroupId SparTag = UserGroupId instance Scim.Auth.AuthTypes SparTag where type AuthData SparTag = ScimToken diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 167aee9899..1f3f362676 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -7,7 +7,9 @@ , aeson-pretty , amazonka , amazonka-core +, amazonka-dynamodb , amazonka-ses +, amazonka-sqs , amqp , async , attoparsec @@ -45,6 +47,7 @@ , hasql-th , hasql-transaction , hex +, hscim , HsOpenSSL , hspec , hspec-discover @@ -62,8 +65,10 @@ , memory , mime , mime-mail +, mmorph , network , network-conduit-tls +, network-uri , polysemy , polysemy-conc , polysemy-plugin @@ -72,6 +77,7 @@ , postgresql-error-codes , profunctors , prometheus-client +, proto-lens , QuickCheck , quickcheck-instances , random @@ -99,6 +105,7 @@ , token-bucket , transformers , types-common +, types-common-journal , unliftio , unordered-containers , uri-bytestring @@ -121,7 +128,9 @@ mkDerivation { aeson-pretty amazonka amazonka-core + amazonka-dynamodb amazonka-ses + amazonka-sqs amqp async attoparsec @@ -158,6 +167,7 @@ mkDerivation { hasql-th hasql-transaction hex + hscim HsOpenSSL hspec html-entities @@ -173,8 +183,10 @@ mkDerivation { memory mime mime-mail + mmorph network network-conduit-tls + network-uri polysemy polysemy-conc polysemy-plugin @@ -183,6 +195,7 @@ mkDerivation { postgresql-error-codes profunctors prometheus-client + proto-lens QuickCheck raw-strings-qq resource-pool @@ -206,6 +219,7 @@ mkDerivation { token-bucket transformers types-common + types-common-journal unliftio unordered-containers uri-bytestring @@ -223,7 +237,9 @@ mkDerivation { aeson-pretty amazonka amazonka-core + amazonka-dynamodb amazonka-ses + amazonka-sqs amqp async attoparsec @@ -259,6 +275,7 @@ mkDerivation { hasql-th hasql-transaction hex + hscim HsOpenSSL hspec html-entities @@ -273,8 +290,10 @@ mkDerivation { memory mime mime-mail + mmorph network network-conduit-tls + network-uri polysemy polysemy-conc polysemy-plugin @@ -282,6 +301,7 @@ mkDerivation { polysemy-wire-zoo profunctors prometheus-client + proto-lens QuickCheck quickcheck-instances random @@ -309,6 +329,7 @@ mkDerivation { token-bucket transformers types-common + types-common-journal unliftio unordered-containers uri-bytestring diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem.hs new file mode 100644 index 0000000000..7df83ea0ed --- /dev/null +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2025 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.AWSSubsystem where + +import Amazonka qualified as AWS +import Amazonka.SQS qualified as SQS +import Control.Monad.Catch +import Data.Aeson hiding ((.=)) +import Data.ByteString.Lazy qualified as BL +import Data.UUID hiding (null) +import Imports hiding (group) +import Polysemy (makeSem) + +data AWSSubsystem m r where + RunAwsRequest :: + forall a m. + ( AWS.AWSRequest a, + Typeable a, + Typeable (AWS.AWSResponse a) + ) => + a -> + AWSSubsystem m (Either AWS.Error (AWS.AWSResponse a)) + RunAwsRequestThrow :: + forall a m. + ( AWS.AWSRequest a, + Typeable a, + Typeable (AWS.AWSResponse a) + ) => + a -> + AWSSubsystem m (AWS.AWSResponse a) + GetQueueUrl :: Text -> AWSSubsystem m Text + Listen :: forall a m. (FromJSON a, Show a) => Int -> Text -> (a -> m ()) -> AWSSubsystem m () + EnqueueStandard :: Text -> BL.ByteString -> AWSSubsystem m SQS.SendMessageResponse + EnqueueFIFO :: Text -> Text -> UUID -> BL.ByteString -> AWSSubsystem m SQS.SendMessageResponse + +makeSem ''AWSSubsystem + +data AWSSubsystemError where + GeneralError :: (Show e, AWS.AsError e) => e -> AWSSubsystemError + SESInvalidDomain :: AWSSubsystemError + +deriving instance Show AWSSubsystemError + +deriving instance Typeable AWSSubsystemError + +instance Exception AWSSubsystemError diff --git a/services/brig/src/Brig/AWS.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs similarity index 67% rename from services/brig/src/Brig/AWS.hs rename to libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs index cce8eb2b8f..4607c7fb13 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoFieldSelectors #-} -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2022 Wire Swiss GmbH +-- Copyright (C) 2025 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 @@ -18,29 +21,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.AWS - ( -- * Monad - Env (..), - mkEnv, - Amazon, - amazonkaEnv, - execute, - sesQueue, - userJournalQueue, - prekeyTable, - Error (..), - - -- * SQS - listen, - enqueueFIFO, - enqueueStandard, - getQueueUrl, - - -- * AWS - exec, - execCatch, - ) -where +module Wire.AWSSubsystem.AWS where import Amazonka (AWSRequest, AWSResponse) import Amazonka qualified as AWS @@ -48,7 +29,6 @@ import Amazonka.DynamoDB qualified as DDB import Amazonka.SES qualified as SES import Amazonka.SQS qualified as SQS import Amazonka.SQS.Lens qualified as SQS -import Brig.Options qualified as Opt import Control.Lens hiding ((.=)) import Control.Monad.Catch import Control.Monad.Trans.Resource @@ -60,7 +40,8 @@ import Data.Text.Encoding qualified as Text import Data.UUID hiding (null) import Imports hiding (group) import Network.HTTP.Client (Manager) -import Polysemy (runM) +import Polysemy hiding (send) +import Polysemy.Final import Polysemy.Input (runInputConst) import System.Logger qualified as Logger import System.Logger.Class @@ -68,6 +49,7 @@ import UnliftIO.Async import UnliftIO.Exception import Util.Options import Wire.AWS +import Wire.AWSSubsystem (AWSSubsystem (..), AWSSubsystemError (..)) data Env = Env { _logger :: !Logger, @@ -82,7 +64,7 @@ makeLenses ''Env newtype Amazon a = Amazon { unAmazon :: ReaderT Env (ResourceT IO) a } - deriving + deriving newtype ( Functor, Applicative, Monad, @@ -98,27 +80,53 @@ newtype Amazon a = Amazon instance MonadLogger Amazon where log l m = view logger >>= \g -> Logger.log g l m -mkEnv :: Logger -> Opt.AWSOpts -> Maybe Opt.EmailAWSOpts -> Manager -> IO Env +data AWSOpts = AWSOpts + { -- | Event journal queue for user events + -- (e.g. user deletion) + userJournalQueue :: !(Maybe Text), + -- | Dynamo table for storing prekey data + prekeyTable :: !Text, + -- | AWS SQS endpoint + sqsEndpoint :: !AWSEndpoint, + -- | DynamoDB endpoint + dynamoDBEndpoint :: !(Maybe AWSEndpoint) + } + deriving (Show, Generic) + deriving anyclass (FromJSON) + +data EmailAWSOpts = EmailAWSOpts + { -- | Event feedback queue for SES + -- (e.g. for email bounces and complaints) + sesQueue :: !Text, + -- | AWS SES endpoint + sesEndpoint :: !AWSEndpoint + } + deriving (Show, Generic) + deriving anyclass (FromJSON) + +mkEnv :: Logger -> AWSOpts -> Maybe EmailAWSOpts -> Manager -> IO Env mkEnv lgr opts emailOpts mgr = do let g = Logger.clone (Just "aws.brig") lgr - let pk = Opt.prekeyTable opts - let sesEndpoint = mkEndpoint SES.defaultService . Opt.sesEndpoint <$> emailOpts - let dynamoEndpoint = mkEndpoint DDB.defaultService <$> Opt.dynamoDBEndpoint opts + let pk = opts.prekeyTable + let sesEndpoint = mkEndpoint SES.defaultService . (.sesEndpoint) <$> emailOpts + let dynamoEndpoint = mkEndpoint DDB.defaultService <$> opts.dynamoDBEndpoint e <- mkAwsEnv g sesEndpoint dynamoEndpoint - (mkEndpoint SQS.defaultService (Opt.sqsEndpoint opts)) - sq <- maybe (pure Nothing) (fmap Just . getQueueUrl e . Opt.sesQueue) emailOpts - jq <- maybe (pure Nothing) (fmap Just . getQueueUrl e) (Opt.userJournalQueue opts) + (mkEndpoint SQS.defaultService opts.sqsEndpoint) + sq <- maybe (pure Nothing) (fmap Just . getQueueUrl e . (.sesQueue)) emailOpts + jq <- maybe (pure Nothing) (fmap Just . getQueueUrl e) opts.userJournalQueue pure (Env g sq jq pk e) where mkEndpoint svc e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) svc mkAwsEnv g ses dyn sqs = do baseEnv <- AWS.newEnv AWS.discover - <&> AWS.configureService sqs . maybe id AWS.configureService dyn . maybe id AWS.configureService ses + <&> AWS.configureService sqs + . maybe id AWS.configureService dyn + . maybe id AWS.configureService ses pure $ baseEnv { AWS.logger = awsLogger g, @@ -139,30 +147,16 @@ mkEnv lgr opts emailOpts mgr = do -- they are still revealed on debug level. mapLevel AWS.Error = Logger.Debug +--------------------------------------------------------- + getQueueUrl :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Text -> m Text -getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> exec e (SQS.newGetQueueUrl q) - -execute :: (MonadIO m) => Env -> Amazon a -> m a -execute e m = liftIO $ runResourceT (runReaderT (unAmazon m) e) - -data Error where - GeneralError :: (Show e, AWS.AsError e) => e -> Error - SESInvalidDomain :: Error - -deriving instance Show Error +getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> runAwsRequestThrow e (SQS.newGetQueueUrl q) -deriving instance Typeable Error - -instance Exception Error - --------------------------------------------------------------------------------- --- SQS - -listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO ()) -> Amazon () +listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO x) -> Amazon y listen throttleMillis url callback = forever . handleAny unexpectedError $ do msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> send receive void $ mapConcurrently onMessage msgs @@ -178,7 +172,7 @@ listen throttleMillis url callback = forever . handleAny unexpectedError $ do Left e -> err $ msg (val "Failed to parse SQS event") . field "error" e . field "message" (show m) Right n -> do debug $ msg (val "Received SQS event") . field "event" (show n) - liftIO $ callback n + liftIO $ void $ callback n for_ (m ^. SQS.message_receiptHandle) (void . send . SQS.newDeleteMessage url) unexpectedError x = do err $ "error" .= show x ~~ msg (val "Failed to read or process message from SQS") @@ -216,7 +210,7 @@ sendCatchAmazon req = do throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) pure -execCatch :: +runAwsRequest :: ( AWSRequest a, Typeable a, MonadUnliftIO m, @@ -226,12 +220,12 @@ execCatch :: AWS.Env -> a -> m (Either AWS.Error (AWSResponse a)) -execCatch e cmd = +runAwsRequest e cmd = runResourceT $ AWS.trying AWS._Error $ AWS.send e cmd -exec :: +runAwsRequestThrow :: ( AWSRequest a, Typeable a, Typeable (AWSResponse a), @@ -241,7 +235,32 @@ exec :: AWS.Env -> a -> m (AWSResponse a) -exec e cmd = liftIO (execCatch e cmd) >>= either (throwM . GeneralError) pure +runAwsRequestThrow e cmd = liftIO (runAwsRequest e cmd) >>= either (throwM . GeneralError) pure retry5x :: (Monad m) => RetryPolicyM m retry5x = limitRetries 5 <> exponentialBackoff 100000 + +-------------------------------------------------------------------------------- +-- Polysemy Interpreter + +-- | Run AWSSubsystem effect by interpreting it into the Amazon monad. +-- Uses Final IO strategy for the higher-order Listen effect. +runAWSSubsystem :: + (Member (Final IO) r) => + Env -> + Sem (AWSSubsystem : r) a -> + Sem r a +runAWSSubsystem env = interpretFinal $ \case + RunAwsRequest x -> liftS @IO $ runAwsRequest env._amazonkaEnv x + RunAwsRequestThrow x -> liftS @IO $ runAwsRequestThrow env._amazonkaEnv x + GetQueueUrl queueName -> liftS @IO $ do + resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) + pure $ view SQS.getQueueUrlResponse_queueUrl resp + EnqueueStandard url message -> liftS $ do + runResourceT $ runReaderT ((enqueueStandard url message).unAmazon) env + EnqueueFIFO url group dedupId message -> liftS $ do + runResourceT $ runReaderT ((enqueueFIFO url group dedupId message).unAmazon) env + Listen throttle url callback -> do + callbackS <- bindS callback + s <- getInitialStateS + pure $ runResourceT $ runReaderT ((listen throttle url $ callbackS . (s $>)).unAmazon) env diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore.hs b/libs/wire-subsystems/src/Wire/ConnectionStore.hs new file mode 100644 index 0000000000..f9c1cc979b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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.ConnectionStore + ( ConnectionStore (..), + -- * Operations + insertConnection, + updateConnection, + updateConnectionStatus, + lookupConnection, + lookupLocalConnectionsPage, + lookupRemoteConnectionsPage, + lookupRelationWithHistory, + lookupLocalConnections, + lookupConnectionStatus, + lookupConnectionStatus', + lookupContactList, + lookupContactListWithRelation, + lookupLocalConnectionStatuses, + lookupRemoteConnectionStatuses, + lookupAllStatuses, + remoteConnectedUsersPaginated, + countConnections, + deleteConnections, + deleteRemoteConnections, + ) +where + +import Cassandra (PageWithState, PagingState) +import Data.Id +import Data.Json.Util (UTCTimeMillis) +import Data.Qualified (Local, Qualified, Remote) +import Data.Range +import Imports +import Polysemy +import Wire.API.Connection (Relation, RelationWithHistory, UserConnection) +import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus, ConnectionStatusV2) +import Wire.ConnectionStore.Types (ResultPage) +import Wire.Sem.Paging (Page, PagingBounds) +import Wire.Sem.Paging qualified as P + +data ConnectionStore p m a where + -- Insert/Update operations + InsertConnection :: + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + Qualified ConvId -> + ConnectionStore p m UserConnection + UpdateConnection :: + UserConnection -> + RelationWithHistory -> + ConnectionStore p m UserConnection + UpdateConnectionStatus :: + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + ConnectionStore p m UTCTimeMillis + -- Lookup operations + LookupConnection :: + Local UserId -> + Qualified UserId -> + ConnectionStore p m (Maybe UserConnection) + LookupRelationWithHistory :: + Local UserId -> + Qualified UserId -> + ConnectionStore p m (Maybe RelationWithHistory) + LookupLocalConnections :: + Local UserId -> + Maybe UserId -> + Range 1 500 Int32 -> + ConnectionStore p m (ResultPage UserConnection) + LookupLocalConnectionsPage :: + Local UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + ConnectionStore p m (PageWithState UserConnection) + LookupRemoteConnectionsPage :: + Local UserId -> + Maybe PagingState -> + Int32 -> + ConnectionStore p m (PageWithState UserConnection) + -- Status operations + LookupConnectionStatus :: + [UserId] -> + [UserId] -> + ConnectionStore p m [ConnectionStatus] + LookupConnectionStatus' :: + [UserId] -> + ConnectionStore p m [ConnectionStatus] + LookupLocalConnectionStatuses :: + [UserId] -> + Local [UserId] -> + ConnectionStore p m [ConnectionStatusV2] + LookupRemoteConnectionStatuses :: + [UserId] -> + Remote [UserId] -> + ConnectionStore p m [ConnectionStatusV2] + LookupAllStatuses :: + Local [UserId] -> + ConnectionStore p m [ConnectionStatusV2] + -- Contact list operations + LookupContactList :: + UserId -> + ConnectionStore p m [UserId] + LookupContactListWithRelation :: + UserId -> + ConnectionStore p m [(UserId, RelationWithHistory)] + -- Pagination + RemoteConnectedUsersPaginated :: + Local UserId -> + Maybe (P.PagingState p (Remote UserConnection)) -> + PagingBounds p (Remote UserConnection) -> + ConnectionStore p m (Page p (Remote UserConnection)) + -- Counting + CountConnections :: + Local UserId -> + [Relation] -> + ConnectionStore p m Int64 + -- Deletion + DeleteConnections :: + UserId -> + ConnectionStore p m () + DeleteRemoteConnections :: + Remote UserId -> + Range 1 1000 [UserId] -> + ConnectionStore p m () + +makeSem ''ConnectionStore diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs new file mode 100644 index 0000000000..810fd0a919 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Cassandra.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE DeepSubsumption #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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.ConnectionStore.Cassandra where + +import Cassandra +import Control.Monad.Morph hiding (embed) +import Control.Monad.Trans.Maybe +import Data.Conduit (runConduit, (.|)) +import Data.Conduit.List qualified as C +import Data.Domain (Domain) +import Data.Id +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) +import Data.Qualified +import Data.Range +import Data.Time (getCurrentTime) +import Imports hiding (local) +import Polysemy +import Polysemy.Internal.Tactics +import UnliftIO.Async (pooledForConcurrentlyN_, pooledMapConcurrentlyN, pooledMapConcurrentlyN_) +import Wire.API.Connection +import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus (..), ConnectionStatusV2 (..)) +import Wire.ConnectionStore +import Wire.ConnectionStore.Types (ResultPage, cassandraResultPage) +import Wire.Sem.Paging.Cassandra + +-- | Cassandra interpreter for ConnectionStore effect +connectionStoreToCassandra :: + forall r a. + (Member (Embed Client) r) => + Sem (ConnectionStore InternalPaging ': r) a -> + Sem r a +connectionStoreToCassandra = + interpretH $ \case + InsertConnection self target rel qcnv -> do + pureT =<< (embed @Client $ insertConnectionImpl self target rel qcnv) + UpdateConnection c status -> do + pureT =<< (embed @Client $ updateConnectionImpl c status) + UpdateConnectionStatus self target status -> do + pureT =<< (embed @Client $ updateConnectionStatusImpl self target status) + LookupConnection self target -> do + pureT =<< (embed @Client $ lookupConnectionImpl self target) + LookupRelationWithHistory self target -> do + pureT =<< (embed @Client $ lookupRelationWithHistoryImpl self target) + LookupLocalConnections lfrom start size -> do + pureT =<< (embed @Client $ lookupLocalConnectionsImpl lfrom start size) + LookupLocalConnectionsPage self pagingState size -> do + pureT =<< (embed @Client $ lookupLocalConnectionsPageImpl self pagingState size) + LookupRemoteConnectionsPage self pagingState size -> do + pureT =<< (embed @Client $ lookupRemoteConnectionsPageImpl self pagingState size) + LookupConnectionStatus from to -> do + pureT =<< (embed @Client $ lookupConnectionStatusImpl from to) + LookupConnectionStatus' from -> do + pureT =<< (embed @Client $ lookupConnectionStatus'Impl from) + LookupLocalConnectionStatuses froms tos -> do + pureT =<< (embed @Client $ lookupLocalConnectionStatusesImpl froms tos) + LookupRemoteConnectionStatuses froms tos -> do + pureT =<< (embed @Client $ lookupRemoteConnectionStatusesImpl froms tos) + LookupAllStatuses lfroms -> do + pureT =<< (embed @Client $ lookupAllStatusesImpl lfroms) + LookupContactList u -> do + pureT =<< (embed @Client $ lookupContactListImpl u) + LookupContactListWithRelation u -> do + pureT =<< (embed @Client $ lookupContactListWithRelationImpl u) + RemoteConnectedUsersPaginated uid mps bounds -> do + liftT . embed @Client $ case mps of + Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginatedImpl uid (fromRange bounds) + Just ps -> ipNext ps + CountConnections u r -> do + pureT =<< (embed @Client $ countConnectionsImpl u r) + DeleteConnections u -> do + pureT =<< (embed @Client $ deleteConnectionsImpl u) + DeleteRemoteConnections remoteUser locals -> do + pureT =<< (embed @Client $ deleteRemoteConnectionsImpl remoteUser locals) + +-- Implementation functions + +insertConnectionImpl :: + (MonadClient m) => + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + Qualified ConvId -> + m UserConnection +insertConnectionImpl self target rel qcnv@(Qualified cnv cdomain) = do + now <- toUTCTimeMillis <$> liftIO getCurrentTime + let local (tUnqualified -> ltarget) = + write connectionInsert $ + params LocalQuorum (tUnqualified self, ltarget, rel, now, cnv) + let remote (tUntagged -> Qualified rtarget domain) = + write remoteConnectionInsert $ + params LocalQuorum (tUnqualified self, domain, rtarget, rel, now, cdomain, cnv) + retry x5 $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = now, + ucConvId = Just qcnv + } + +updateConnectionImpl :: + (MonadClient m) => + UserConnection -> + RelationWithHistory -> + m UserConnection +updateConnectionImpl c status = do + -- We need to construct a Local UserId from ucFrom + -- For now, assume we have the domain available in context + -- This may need to be adjusted based on how the effect is used + let self = toLocalUnsafe (qDomain (ucTo c)) (ucFrom c) + now <- updateConnectionStatusImpl self (ucTo c) status + pure $ + c + { ucStatus = relationDropHistory status, + ucLastUpdate = now + } + +updateConnectionStatusImpl :: + (MonadClient m) => + Local UserId -> + Qualified UserId -> + RelationWithHistory -> + m UTCTimeMillis +updateConnectionStatusImpl self target status = do + now <- toUTCTimeMillis <$> liftIO getCurrentTime + let local (tUnqualified -> ltarget) = + write connectionUpdate $ + params LocalQuorum (status, now, tUnqualified self, ltarget) + let remote (tUntagged -> Qualified rtarget domain) = + write remoteConnectionUpdate $ + params LocalQuorum (status, now, tUnqualified self, domain, rtarget) + retry x5 $ foldQualified self local remote target + pure now + +lookupConnectionImpl :: + (MonadClient m) => + Local UserId -> + Qualified UserId -> + m (Maybe UserConnection) +lookupConnectionImpl self target = runMaybeT $ do + let local (tUnqualified -> ltarget) = do + (_, _, rel, time, mcnv) <- + MaybeT . query1 connectionSelect $ + params LocalQuorum (tUnqualified self, ltarget) + pure (rel, time, fmap (tUntagged . qualifyAs self) mcnv) + let remote (tUntagged -> Qualified rtarget domain) = do + (rel, time, cdomain, cnv) <- + MaybeT . query1 remoteConnectionSelectFrom $ + params LocalQuorum (tUnqualified self, domain, rtarget) + pure (rel, time, Just (Qualified cnv cdomain)) + (rel, time, mqcnv) <- hoist (retry x1) $ foldQualified self local remote target + pure $ + UserConnection + { ucFrom = tUnqualified self, + ucTo = target, + ucStatus = relationDropHistory rel, + ucLastUpdate = time, + ucConvId = mqcnv + } + +lookupRelationWithHistoryImpl :: + (MonadClient m) => + Local UserId -> + Qualified UserId -> + m (Maybe RelationWithHistory) +lookupRelationWithHistoryImpl self target = do + let local (tUnqualified -> ltarget) = + query1 relationSelect (params LocalQuorum (tUnqualified self, ltarget)) + let remote (tUntagged -> Qualified rtarget domain) = + query1 remoteRelationSelect (params LocalQuorum (tUnqualified self, domain, rtarget)) + runIdentity <$$> retry x1 (foldQualified self local remote target) + +lookupLocalConnectionsImpl :: + (MonadClient m) => + Local UserId -> + Maybe UserId -> + Range 1 500 Int32 -> + m (ResultPage UserConnection) +lookupLocalConnectionsImpl lfrom start (fromRange -> size) = + toResult <$> case start of + Just u -> + retry x1 $ + paginate connectionsSelectFrom (paramsP LocalQuorum (tUnqualified lfrom, u) (size + 1)) + Nothing -> + retry x1 $ + paginate connectionsSelect (paramsP LocalQuorum (Identity (tUnqualified lfrom)) (size + 1)) + where + toResult = cassandraResultPage . fmap (toLocalUserConnection lfrom) . trim + trim p = p {result = take (fromIntegral size) (result p)} + +lookupLocalConnectionsPageImpl :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Range 1 1000 Int32 -> + m (PageWithState UserConnection) +lookupLocalConnectionsPageImpl self pagingState (fromRange -> size) = + fmap (toLocalUserConnection self) <$> paginateWithState connectionsSelect (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) + +lookupRemoteConnectionsPageImpl :: + (MonadClient m) => + Local UserId -> + Maybe PagingState -> + Int32 -> + m (PageWithState UserConnection) +lookupRemoteConnectionsPageImpl self pagingState size = + fmap (toRemoteUserConnection self) + <$> paginateWithState + remoteConnectionSelect + (paramsPagingState LocalQuorum (Identity (tUnqualified self)) size pagingState) + +lookupConnectionStatusImpl :: + (MonadClient m) => + [UserId] -> + [UserId] -> + m [ConnectionStatus] +lookupConnectionStatusImpl from to = + map toConnectionStatus + <$> retry x1 (query connectionStatusSelect (params LocalQuorum (from, to))) + +lookupConnectionStatus'Impl :: + (MonadClient m) => + [UserId] -> + m [ConnectionStatus] +lookupConnectionStatus'Impl from = + map toConnectionStatus + <$> retry x1 (query connectionStatusSelect' (params LocalQuorum (Identity from))) + +lookupLocalConnectionStatusesImpl :: + (MonadClient m, MonadUnliftIO m) => + [UserId] -> + Local [UserId] -> + m [ConnectionStatusV2] +lookupLocalConnectionStatusesImpl froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query relationsSelect (params LocalQuorum (from, tUnqualified tos))) + +lookupRemoteConnectionStatusesImpl :: + (MonadClient m, MonadUnliftIO m) => + [UserId] -> + Remote [UserId] -> + m [ConnectionStatusV2] +lookupRemoteConnectionStatusesImpl froms tos = do + concat <$> pooledMapConcurrentlyN 16 lookupStatuses froms + where + lookupStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain tos)) + <$> retry x1 (query remoteRelationsSelect (params LocalQuorum (from, tDomain tos, tUnqualified tos))) + +lookupAllStatusesImpl :: + (MonadClient m, MonadUnliftIO m) => + Local [UserId] -> + m [ConnectionStatusV2] +lookupAllStatusesImpl lfroms = do + let froms = tUnqualified lfroms + concat <$> pooledMapConcurrentlyN 16 lookupAndCombine froms + where + lookupAndCombine :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupAndCombine u = (<>) <$> lookupLocalStatuses u <*> lookupRemoteStatuses u + + lookupLocalStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupLocalStatuses from = + map (uncurry $ toConnectionStatusV2 from (tDomain lfroms)) + <$> retry x1 (query relationsSelectAll (params LocalQuorum (Identity from))) + lookupRemoteStatuses :: (MonadClient m) => UserId -> m [ConnectionStatusV2] + lookupRemoteStatuses from = + map (\(d, u, r) -> toConnectionStatusV2 from d u r) + <$> retry x1 (query remoteRelationsSelectAll (params LocalQuorum (Identity from))) + +lookupRemoteConnectedUsersPaginatedImpl :: + (MonadClient m) => + Local UserId -> + Int32 -> + m (Page (Remote UserConnection)) +lookupRemoteConnectedUsersPaginatedImpl u maxResults = do + (\x@(d, _, _, _, _, _) -> toRemoteUnsafe d (toRemoteUserConnection u x)) <$$> retry x1 (paginate remoteConnectionSelect (paramsP LocalQuorum (Identity (tUnqualified u)) maxResults)) + +lookupContactListImpl :: + (MonadClient m) => + UserId -> + m [UserId] +lookupContactListImpl u = + fst <$$> (filter ((== AcceptedWithHistory) . snd) <$> lookupContactListWithRelationImpl u) + +lookupContactListWithRelationImpl :: + (MonadClient m) => + UserId -> + m [(UserId, RelationWithHistory)] +lookupContactListWithRelationImpl u = + retry x1 (query contactsSelect (params LocalQuorum (Identity u))) + +countConnectionsImpl :: + (MonadClient m) => + Local UserId -> + [Relation] -> + m Int64 +countConnectionsImpl u r = do + rels <- retry x1 . query selectStatus $ params One (Identity (tUnqualified u)) + relsRemote <- retry x1 . query selectStatusRemote $ params One (Identity (tUnqualified u)) + + pure $ foldl' count 0 rels + foldl' count 0 relsRemote + where + selectStatus :: QueryString R (Identity UserId) (Identity RelationWithHistory) + selectStatus = "SELECT status FROM connection WHERE left = ?" + + selectStatusRemote :: QueryString R (Identity UserId) (Identity RelationWithHistory) + selectStatusRemote = "SELECT status FROM connection_remote WHERE left = ?" + + count n (Identity s) | relationDropHistory s `elem` r = n + 1 + count n _ = n + +deleteConnectionsImpl :: + (MonadClient m, MonadUnliftIO m) => + UserId -> + m () +deleteConnectionsImpl u = do + runConduit $ + paginateC contactsSelect (paramsP LocalQuorum (Identity u) 100) x1 + .| C.mapM_ + (pooledMapConcurrentlyN_ 16 delete) + do + retry x1 . write connectionClear $ params LocalQuorum (Identity u) + retry x1 . write remoteConnectionClear $ params LocalQuorum (Identity u) + where + delete (other, _status) = write connectionDelete $ params LocalQuorum (other, u) + +deleteRemoteConnectionsImpl :: + (MonadClient m, MonadUnliftIO m) => + Remote UserId -> + Range 1 1000 [UserId] -> + m () +deleteRemoteConnectionsImpl (tUntagged -> Qualified remoteUser remoteDomain) (fromRange -> locals) = + pooledForConcurrentlyN_ 16 locals $ \u -> + write remoteConnectionDelete $ params LocalQuorum (u, remoteDomain, remoteUser) + +-- Cassandra queries + +connectionInsert :: PrepQuery W (UserId, UserId, RelationWithHistory, UTCTimeMillis, ConvId) () +connectionInsert = "INSERT INTO connection (left, right, status, last_update, conv) VALUES (?, ?, ?, ?, ?)" + +connectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, UserId) () +connectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection SET status = ?, last_update = ? WHERE left = ? AND right = ?" + +connectionSelect :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right = ?" + +relationSelect :: PrepQuery R (UserId, UserId) (Identity RelationWithHistory) +relationSelect = "SELECT status FROM connection WHERE left = ? AND right = ?" + +relationsSelect :: PrepQuery R (UserId, [UserId]) (UserId, RelationWithHistory) +relationsSelect = "SELECT right, status FROM connection where left = ? AND right IN ?" + +relationsSelectAll :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +relationsSelectAll = "SELECT right, status FROM connection where left = ?" + +connectionStatusSelect :: PrepQuery R ([UserId], [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect = "SELECT left, right, status FROM connection WHERE left IN ? AND right IN ?" + +connectionStatusSelect' :: PrepQuery R (Identity [UserId]) (UserId, UserId, RelationWithHistory) +connectionStatusSelect' = "SELECT left, right, status FROM connection WHERE left IN ?" + +contactsSelect :: PrepQuery R (Identity UserId) (UserId, RelationWithHistory) +contactsSelect = "SELECT right, status FROM connection WHERE left = ?" + +connectionsSelect :: PrepQuery R (Identity UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelect = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? ORDER BY right ASC" + +connectionsSelectFrom :: PrepQuery R (UserId, UserId) (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) +connectionsSelectFrom = "SELECT left, right, status, last_update, conv FROM connection WHERE left = ? AND right > ? ORDER BY right ASC" + +connectionDelete :: PrepQuery W (UserId, UserId) () +connectionDelete = "DELETE FROM connection WHERE left = ? AND right = ?" + +connectionClear :: PrepQuery W (Identity UserId) () +connectionClear = "DELETE FROM connection WHERE left = ?" + +-- Remote connections + +remoteConnectionInsert :: PrepQuery W (UserId, Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) () +remoteConnectionInsert = "INSERT INTO connection_remote (left, right_domain, right_user, status, last_update, conv_domain, conv_id) VALUES (?, ?, ?, ?, ?, ?, ?)" + +remoteConnectionSelect :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelect = "SELECT right_domain, right_user, status, last_update, conv_domain, conv_id FROM connection_remote where left = ?" + +remoteConnectionSelectFrom :: PrepQuery R (UserId, Domain, UserId) (RelationWithHistory, UTCTimeMillis, Domain, ConvId) +remoteConnectionSelectFrom = "SELECT status, last_update, conv_domain, conv_id FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" + +remoteConnectionUpdate :: PrepQuery W (RelationWithHistory, UTCTimeMillis, UserId, Domain, UserId) () +remoteConnectionUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE connection_remote set status = ?, last_update = ? WHERE left = ? and right_domain = ? and right_user = ?" + +remoteConnectionDelete :: PrepQuery W (UserId, Domain, UserId) () +remoteConnectionDelete = "DELETE FROM connection_remote where left = ? AND right_domain = ? AND right_user = ?" + +remoteConnectionClear :: PrepQuery W (Identity UserId) () +remoteConnectionClear = "DELETE FROM connection_remote where left = ?" + +remoteRelationSelect :: PrepQuery R (UserId, Domain, UserId) (Identity RelationWithHistory) +remoteRelationSelect = "SELECT status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user = ?" + +remoteRelationsSelect :: PrepQuery R (UserId, Domain, [UserId]) (UserId, RelationWithHistory) +remoteRelationsSelect = "SELECT right_user, status FROM connection_remote WHERE left = ? AND right_domain = ? AND right_user IN ?" + +remoteRelationsSelectAll :: PrepQuery R (Identity UserId) (Domain, UserId, RelationWithHistory) +remoteRelationsSelectAll = "SELECT right_domain, right_user, status FROM connection_remote WHERE left = ?" + +-- Conversions + +toLocalUserConnection :: + Local x -> + (UserId, UserId, RelationWithHistory, UTCTimeMillis, Maybe ConvId) -> + UserConnection +toLocalUserConnection loc (l, r, relationDropHistory -> rel, time, cid) = + UserConnection l (tUntagged (qualifyAs loc r)) rel time (fmap (tUntagged . qualifyAs loc) cid) + +toRemoteUserConnection :: + Local UserId -> + (Domain, UserId, RelationWithHistory, UTCTimeMillis, Domain, ConvId) -> + UserConnection +toRemoteUserConnection l (rDomain, r, relationDropHistory -> rel, time, cDomain, cid) = + UserConnection (tUnqualified l) (Qualified r rDomain) rel time (Just $ Qualified cid cDomain) + +toConnectionStatus :: (UserId, UserId, RelationWithHistory) -> ConnectionStatus +toConnectionStatus (l, r, relationDropHistory -> rel) = ConnectionStatus l r rel + +toConnectionStatusV2 :: UserId -> Domain -> UserId -> RelationWithHistory -> ConnectionStatusV2 +toConnectionStatusV2 from toDomain toUser relWithHistory = + ConnectionStatusV2 from (Qualified toUser toDomain) (relationDropHistory relWithHistory) diff --git a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ConnectionStore/Types.hs similarity index 54% rename from services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs rename to libs/wire-subsystems/src/Wire/ConnectionStore/Types.hs index 35f2444ab8..cd55097109 100644 --- a/services/brig/src/Brig/Effects/ConnectionStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ConnectionStore/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeepSubsumption #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2024 Wire Swiss GmbH @@ -17,25 +15,29 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Effects.ConnectionStore.Cassandra where +module Wire.ConnectionStore.Types + ( ResultPage, + resultList, + resultHasMore, + cassandraResultPage, + ) +where -import Brig.Data.Connection -import Brig.Effects.ConnectionStore -import Cassandra -import Data.Range +import Cassandra qualified import Imports -import Polysemy -import Polysemy.Internal.Tactics -import Wire.Sem.Paging.Cassandra -connectionStoreToCassandra :: - forall r a. - (Member (Embed Client) r) => - Sem (ConnectionStore InternalPaging ': r) a -> - Sem r a -connectionStoreToCassandra = - interpretH $ - liftT . embed @Client . \case - RemoteConnectedUsersPaginated uid mps bounds -> case mps of - Nothing -> flip mkInternalPage pure =<< lookupRemoteConnectedUsersPaginated uid (fromRange bounds) - Just ps -> ipNext ps +-- | An opaque page of results with an indication of whether +-- more data than contained in the page is available. +newtype ResultPage a = ResultPage (Cassandra.Page a) + +resultList :: ResultPage a -> [a] +resultList (ResultPage p) = Cassandra.result p +{-# INLINE resultList #-} + +resultHasMore :: ResultPage a -> Bool +resultHasMore (ResultPage p) = Cassandra.hasMore p +{-# INLINE resultHasMore #-} + +cassandraResultPage :: Cassandra.Page a -> ResultPage a +cassandraResultPage = ResultPage +{-# INLINE cassandraResultPage #-} diff --git a/services/brig/src/Brig/DeleteQueue/Interpreter.hs b/libs/wire-subsystems/src/Wire/DeleteQueue/Interpreter.hs similarity index 79% rename from services/brig/src/Brig/DeleteQueue/Interpreter.hs rename to libs/wire-subsystems/src/Wire/DeleteQueue/Interpreter.hs index 22e6dd90c7..20ceade1cb 100644 --- a/services/brig/src/Brig/DeleteQueue/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/DeleteQueue/Interpreter.hs @@ -1,14 +1,12 @@ -module Brig.DeleteQueue.Interpreter +module Wire.DeleteQueue.Interpreter ( runDeleteQueue, - QueueEnv (..), ) where import Amazonka.SQS.Lens -import Brig.AWS qualified as AWS -import Brig.Queue.Stomp qualified as Stomp import Control.Exception (ErrorCall (..)) import Control.Lens +import Control.Monad.Trans.Resource (runResourceT) import Data.Aeson import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Lazy qualified as BL @@ -19,14 +17,13 @@ import OpenSSL.EVP.Digest hiding (digest) import Polysemy import Polysemy.Error import System.Logger.Class qualified as Log +import Wire.AWSSubsystem qualified as AWS +import Wire.AWSSubsystem.AWS qualified as AWSI import Wire.DeleteQueue +import Wire.DeleteQueue.Types import Wire.InternalEvent import Wire.Sem.Logger - --- | The queue environment constructed from `QueueOpts`. -data QueueEnv - = StompQueueEnv Stomp.Broker Text - | SqsQueueEnv AWS.Env Int Text +import Wire.StompSubsystem.Stomp qualified as Stomp runDeleteQueue :: ( Member (Embed IO) r, @@ -53,13 +50,13 @@ enqueue :: QueueEnv -> a -> Sem r () -enqueue (StompQueueEnv broker queue) message = - embed @IO $ Stomp.enqueue broker queue message +enqueue (StompQueueEnv env queue) message = + embed @IO $ runResourceT $ runReaderT (Stomp.unStomp $ Stomp.enqueueInternal queue message) env enqueue (SqsQueueEnv awsEnv _ queue) message = do let body = encode message md5 <- embed @IO $ getDigestByName "MD5" let bodyMD5 = fmap (flip digest body) md5 - resp <- embed @IO $ AWS.execute awsEnv (AWS.enqueueStandard queue body) + resp <- embed @IO $ runFinal $ AWSI.runAWSSubsystem awsEnv (AWS.enqueueStandard queue body) unless (resp ^. sendMessageResponse_mD5OfMessageBody == bodyMD5) $ do err $ Log.msg (Log.val "Returned hash (MD5) doesn't match message hash") diff --git a/services/brig/src/Brig/Queue.hs b/libs/wire-subsystems/src/Wire/DeleteQueue/Listen.hs similarity index 65% rename from services/brig/src/Brig/Queue.hs rename to libs/wire-subsystems/src/Wire/DeleteQueue/Listen.hs index 3772b57fc0..0e367757df 100644 --- a/services/brig/src/Brig/Queue.hs +++ b/libs/wire-subsystems/src/Wire/DeleteQueue/Listen.hs @@ -16,37 +16,36 @@ -- with this program. If not, see . -- | Working with remote queues (like Amazon SQS). -module Brig.Queue - ( module Brig.Queue.Types, - listen, +module Wire.DeleteQueue.Listen + ( listen, ) where -import Brig.AWS qualified as AWS -import Brig.DeleteQueue.Interpreter (QueueEnv (..)) -import Brig.Queue.Stomp qualified as Stomp -import Brig.Queue.Types -import Control.Monad.Catch +import Control.Monad.Trans.Resource (runResourceT) import Data.Aeson import Imports -import System.Logger.Class as Log hiding (settings) +import Polysemy (embedFinal, runFinal) +import Wire.AWSSubsystem qualified as AWS +import Wire.AWSSubsystem.AWS qualified as AWSI +import Wire.DeleteQueue.Types +import Wire.StompSubsystem.Stomp qualified as Stomp -- | Forever listen to messages coming from a queue and execute a callback -- for each incoming message. -- --- See documentation of underlying functions (e.g. 'Stomp.listen') for +-- See documentation of underlying functions (e.g. 'Stomp.listenInternal') for -- extra details. listen :: ( Show a, FromJSON a, - MonadLogger m, - MonadMask m, MonadUnliftIO m ) => QueueEnv -> (a -> m ()) -> m () listen (StompQueueEnv env queue) callback = - Stomp.listen env queue callback -listen (SqsQueueEnv env throttleMillis queue) callback = do - withRunInIO $ \lower -> AWS.execute env $ AWS.listen throttleMillis queue $ lower . callback + withRunInIO $ \lower -> + runResourceT $ runReaderT (Stomp.unStomp $ Stomp.listenInternal queue $ lower . callback) env +listen (SqsQueueEnv env throttleMillis queue) callback = + withRunInIO $ \lower -> + runFinal $ AWSI.runAWSSubsystem env $ AWS.listen throttleMillis queue $ embedFinal . lower . callback diff --git a/services/brig/src/Brig/Queue/Types.hs b/libs/wire-subsystems/src/Wire/DeleteQueue/Types.hs similarity index 68% rename from services/brig/src/Brig/Queue/Types.hs rename to libs/wire-subsystems/src/Wire/DeleteQueue/Types.hs index e7784b8b8f..af61070b51 100644 --- a/services/brig/src/Brig/Queue/Types.hs +++ b/libs/wire-subsystems/src/Wire/DeleteQueue/Types.hs @@ -15,13 +15,18 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Queue.Types +module Wire.DeleteQueue.Types ( QueueOpts (..), + QueueEnv (..), + InternalEventsOpts (..), ) where import Data.Aeson +import Data.Text import Imports +import Wire.AWSSubsystem.AWS qualified as AWSI +import Wire.StompSubsystem.Stomp qualified as Stomp -- | Config file info for a remote queue that you can publish to and listen from. data QueueOpts = StompQueueOpts Text | SqsQueueOpts Text @@ -33,3 +38,17 @@ instance FromJSON QueueOpts where "stomp" -> StompQueueOpts <$> o .: "queueName" "sqs" -> SqsQueueOpts <$> o .: "queueName" other -> fail ("unknown 'queueType': " <> other) + +-- | The queue environment constructed from `QueueOpts`. +data QueueEnv + = StompQueueEnv Stomp.Env Text + | SqsQueueEnv AWSI.Env Int Text + +data InternalEventsOpts = InternalEventsOpts + { internalEventsQueue :: !QueueOpts + } + deriving (Show) + +instance FromJSON InternalEventsOpts where + parseJSON = withObject "InternalEventsOpts" $ \o -> + InternalEventsOpts <$> parseJSON (Object o) diff --git a/libs/wire-subsystems/src/Wire/EmailSending/Core.hs b/libs/wire-subsystems/src/Wire/EmailSending/Core.hs new file mode 100644 index 0000000000..2a72d9cfa0 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/EmailSending/Core.hs @@ -0,0 +1,24 @@ +module Wire.EmailSending.Core where + +import Amazonka qualified as AWS +import Imports +import Polysemy +import System.Logger (Logger) +import Wire.EmailSending +import Wire.EmailSending.SES +import Wire.EmailSending.SMTP + +data EmailSendingInterpreterConfig = EmailSendingInterpreterConfig + { smtpEnv :: Maybe SMTP, + awsEnv :: AWS.Env, + appLogger :: Logger + } + +emailSendingInterpreter :: + (Member (Embed IO) r) => + EmailSendingInterpreterConfig -> + InterpreterFor EmailSending r +emailSendingInterpreter c = do + case c.smtpEnv of + Just smtp -> emailViaSMTPInterpreter c.appLogger smtp + Nothing -> emailViaSESInterpreter c.awsEnv diff --git a/libs/wire-subsystems/src/Wire/Error.hs b/libs/wire-subsystems/src/Wire/Error.hs index 27c32c5666..8834dcca32 100644 --- a/libs/wire-subsystems/src/Wire/Error.hs +++ b/libs/wire-subsystems/src/Wire/Error.hs @@ -11,12 +11,18 @@ import Imports import Network.HTTP.Types import Network.Wai.Utilities.Error qualified as Wai import Network.Wai.Utilities.JSONResponse +import Servant (ServerError) -- | Error thrown to the user data HttpError where StdError :: !Wai.Error -> HttpError RichError :: (ToJSON a) => !Wai.Error -> !a -> [Header] -> HttpError +instance Eq HttpError where + StdError e == StdError e' = e == e' + -- RichErrors are always different because we don't know the types a, a' here + _ == _ = False + instance Show HttpError where show (StdError werr) = "StdError (" <> show werr <> ")" show e@(RichError _ _ headers) = "RichError (json = " <> Text.unpack (Text.decodeUtf8 $ BS.toStrict $ encode e) <> ", headers = " <> show headers <> ")" @@ -52,3 +58,9 @@ postgresUsageErrorToHttpError err = case err of StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err)) ConnectionUsageError _ -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err)) AcquisitionTimeoutUsageError -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err)) + +httpErrorToServerError :: HttpError -> ServerError +httpErrorToServerError = undefined + +serverErrorToHttpError :: ServerError -> HttpError +serverErrorToHttpError = undefined diff --git a/libs/wire-subsystems/src/Wire/Events/Interpreter.hs b/libs/wire-subsystems/src/Wire/Events/Interpreter.hs new file mode 100644 index 0000000000..d4436c0f90 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Events/Interpreter.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RecordWildCards #-} + +-- 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.Events.Interpreter + ( runEvents, + onConnectionEvent, + onPropertyEvent, + onClientEvent, + notify, + toApsData, + ) +where + +import Control.Lens ((?~)) +import Data.Default +import Data.Id +import Data.Json.Util (ToJSONObject (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Qualified (Local) +import Imports +import Polysemy +import Polysemy.Input (Input) +import Polysemy.TinyLog (TinyLog) +import Wire.API.Connection +import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) +import Wire.API.Push.V2 qualified as V2 +import Wire.API.User (Name (..)) +import Wire.API.UserEvent +import Wire.AWSSubsystem (AWSSubsystem) +import Wire.ConnectionStore (ConnectionStore) +import Wire.Events +import Wire.Events.Journal qualified as Journal +import Wire.Events.Notifications qualified as Notifications +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.NotificationSubsystem +import Wire.Sem.Now (Now) +import Wire.Sem.Paging.Cassandra (InternalPaging) + +-- | Interpreter for the Events effect +runEvents :: + ( Member (Embed IO) r, + Member NotificationSubsystem r, + Member AWSSubsystem r, + Member GalleyAPIAccess r, + Member TinyLog r, + Member (Input (Local ())) r, + Member Now r, + Member (ConnectionStore InternalPaging) r + ) => + InterpreterFor Events r +runEvents = interpret \case + GenerateUserEvent uid mconnid event -> sendUserEvent uid mconnid event + GeneratePropertyEvent uid connid event -> onPropertyEvent uid connid event + +sendUserEvent :: + ( Member (Embed IO) r, + Member AWSSubsystem r, + Member NotificationSubsystem r, + Member GalleyAPIAccess r, + Member TinyLog r, + Member (Input (Local ())) r, + Member Now r, + Member (ConnectionStore InternalPaging) r + ) => + UserId -> + Maybe ConnId -> + UserEvent -> + Sem r () +sendUserEvent orig conn e = do + Notifications.dispatchNotifications orig conn e + Journal.journalUserEvent orig e + +onConnectionEvent :: + (Member NotificationSubsystem r) => + -- | Originator of the event. + UserId -> + -- | Client connection ID, if any. + Maybe ConnId -> + -- | The event. + ConnectionEvent -> + Sem r () +onConnectionEvent orig conn evt = do + let from = ucFrom (ucConn evt) + notify + (ConnectionEvent evt) + orig + V2.RouteAny + conn + (pure $ from :| []) + +onPropertyEvent :: + (Member NotificationSubsystem r) => + -- | Originator of the event. + UserId -> + -- | Client connection ID. + ConnId -> + PropertyEvent -> + Sem r () +onPropertyEvent orig conn e = + notify + (PropertyEvent e) + orig + V2.RouteDirect + (Just conn) + (pure $ orig :| []) + +onClientEvent :: + (Member NotificationSubsystem r) => + -- | Originator of the event. + UserId -> + -- | Client connection ID. + Maybe ConnId -> + -- | The event. + ClientEvent -> + Sem r () +onClientEvent orig conn e = do + let event = ClientEvent e + let rcpt = Recipient orig V2.RecipientClientsAll + pushNotifications + [ def + { origin = Just orig, + json = toJSONObject event, + recipients = [rcpt], + conn, + apsData = toApsData event + } + ] + +-- | (Asynchronously) notifies other users of events. +notify :: + (Member NotificationSubsystem r) => + Event -> + -- | Origin user + UserId -> + -- | Push routing strategy. + V2.Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + -- | Users to notify. + Sem r (NonEmpty UserId) -> + Sem r () +notify event orig route conn recipients = do + rs <- (\u -> Recipient u RecipientClientsAll) <$$> recipients + let push = + def + { origin = Just orig, + json = toJSONObject event, + recipients = toList rs, + conn, + route, + apsData = toApsData event + } + void $ pushNotificationAsync push + +toApsData :: Event -> Maybe V2.ApsData +toApsData (ConnectionEvent (ConnectionUpdated uc name)) = + case (ucStatus uc, name) of + (MissingLegalholdConsent, _) -> Nothing + (Pending, n) -> apsConnRequest <$> n + (Accepted, n) -> apsConnAccept <$> n + (Blocked, _) -> Nothing + (Ignored, _) -> Nothing + (Sent, _) -> Nothing + (Cancelled, _) -> Nothing + where + apsConnRequest n = + V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" + apsConnAccept n = + V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" +toApsData _ = Nothing diff --git a/libs/wire-subsystems/src/Wire/Events/Journal.hs b/libs/wire-subsystems/src/Wire/Events/Journal.hs new file mode 100644 index 0000000000..94a8bbd424 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Events/Journal.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE RecordWildCards #-} + +-- 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.Events.Journal + ( userActivateJournal, + userUpdateJournal, + userDeleteJournal, + userEmailRemoveJournal, + journalEvent, + journalUserEvent, + ) +where + +import Control.Lens +import Data.ByteString.Base64 qualified as B64 +import Data.ByteString.Char8 (pack) +import Data.ByteString.Conversion +import Data.ByteString.Lazy (fromStrict) +import Data.Id +import Data.Proto +import Data.Proto.Id +import Data.ProtoLens (defMessage) +import Data.ProtoLens.Encoding (encodeMessage) +import Data.UUID.V4 (nextRandom) +import Imports +import Polysemy +import Proto.UserEvents (UserEvent'EventType (..)) +import Proto.UserEvents qualified as Proto +import Proto.UserEvents_Fields qualified as U +import Wire.API.User +import Wire.API.UserEvent qualified as API +import Wire.AWSSubsystem qualified as AWS + +-- | Journal a user activation event +userActivateJournal :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + User -> + Sem r () +userActivateJournal u@User {..} = + journalEvent UserEvent'USER_ACTIVATE (userId u) (userEmail u) (Just userLocale) userTeam (Just userDisplayName) + +-- | Journal a user update event +userUpdateJournal :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + UserId -> + Maybe EmailAddress -> + Maybe Locale -> + Maybe Name -> + Sem r () +userUpdateJournal uid em loc = + journalEvent UserEvent'USER_UPDATE uid em loc Nothing + +-- | Journal a user email removal event +userEmailRemoveJournal :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + UserId -> + EmailAddress -> + Sem r () +userEmailRemoveJournal uid em = + journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing + +-- | Journal a user deletion event +userDeleteJournal :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + UserId -> + Sem r () +userDeleteJournal uid = + journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing + +-- | Low-level journal event function +journalEvent :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + UserEvent'EventType -> + UserId -> + Maybe EmailAddress -> + Maybe Locale -> + Maybe TeamId -> + Maybe Name -> + Sem r () +journalEvent typ uid em loc tid nm = do + queueUrl <- AWS.getQueueUrl "user.events" + ts <- now + rnd <- embed nextRandom + let userEvent :: Proto.UserEvent = + defMessage + & U.eventType .~ typ + & U.userId .~ toBytes uid + & U.utcTime .~ ts + & U.maybe'email .~ (toByteString' <$> em) + & U.maybe'locale .~ (pack . show <$> loc) + & U.maybe'teamId .~ (toBytes <$> tid) + & U.maybe'name .~ (toByteString' <$> nm) + encoded = fromStrict $ B64.encode $ encodeMessage userEvent + void $ AWS.enqueueFIFO queueUrl "user.events" rnd encoded + +-- | Journal a Wire.API.UserEvent by pattern matching on its constructors +journalUserEvent :: + ( Member AWS.AWSSubsystem r, + Member (Embed IO) r + ) => + UserId -> + API.UserEvent -> + Sem r () +journalUserEvent orig e = case e of + API.UserActivated acc -> + userActivateJournal acc + API.UserUpdated API.UserUpdatedData {eupName = Just name} -> + userUpdateJournal orig Nothing Nothing (Just name) + API.UserUpdated API.UserUpdatedData {eupLocale = Just loc} -> + userUpdateJournal orig Nothing (Just loc) Nothing + API.UserIdentityUpdated (API.UserIdentityUpdatedData _ (Just em) _) -> + userUpdateJournal orig (Just em) Nothing Nothing + API.UserIdentityRemoved (API.UserIdentityRemovedData _ (Just em) _) -> + userEmailRemoveJournal orig em + API.UserDeleted {} -> + userDeleteJournal orig + _ -> + pure () diff --git a/libs/wire-subsystems/src/Wire/Events/Notifications.hs b/libs/wire-subsystems/src/Wire/Events/Notifications.hs new file mode 100644 index 0000000000..fa62901f32 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/Events/Notifications.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE RecordWildCards #-} + +-- 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.Events.Notifications + ( dispatchNotifications, + notify, + notifySelf, + notifyContacts, + ) +where + +import Control.Lens (view, (?~), (^.)) +import Data.Default +import Data.Id +import Data.Json.Util +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy +import Data.Qualified +import Data.Range +import Imports hiding (local) +import Polysemy +import Polysemy.Input (Input, input) +import Polysemy.TinyLog (TinyLog) +import System.Logger.Message hiding ((.=)) +import Wire.API.Connection +import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) +import Wire.API.Push.V2 qualified as V2 +import Wire.API.Team.Member (ListType (ListComplete), TeamMemberList, teamMemberListType, teamMembers) +import Wire.API.Team.Member qualified as TM +import Wire.API.User +import Wire.API.UserEvent +import Wire.ConnectionStore (ConnectionStore) +import Wire.ConnectionStore qualified as CS +import Wire.ConnectionStore.Types (resultHasMore, resultList) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess qualified as GalleyAPI +import Wire.NotificationSubsystem +import Wire.Sem.Logger qualified as Log +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now +import Wire.Sem.Paging qualified as P +import Wire.Sem.Paging.Cassandra (InternalPaging) + +-- | Helper to qualify a value as local using Input (Local ()) +qualifyLocal' :: (Member (Input (Local ())) r) => a -> Sem r (Local a) +qualifyLocal' a = flip toLocalUnsafe a . tDomain <$> input + +-- | Notify users about events +dispatchNotifications :: + ( Member (ConnectionStore InternalPaging) r, + Member GalleyAPIAccess r, + Member NotificationSubsystem r, + Member TinyLog r, + Member (Input (Local ())) r, + Member Now r + ) => + UserId -> + Maybe ConnId -> + UserEvent -> + Sem r () +dispatchNotifications orig conn e = case e of + UserCreated {} -> pure () + UserSuspended {} -> pure () + UserResumed {} -> pure () + LegalHoldClientRequested {} -> notifyContacts event orig V2.RouteAny conn + UserLegalHoldDisabled {} -> notifyContacts event orig V2.RouteAny conn + UserLegalHoldEnabled {} -> notifyContacts event orig V2.RouteAny conn + UserUpdated UserUpdatedData {..} + -- This relies on the fact that we never change the locale AND something else. + | isJust eupLocale -> notifySelf event orig V2.RouteDirect conn + | otherwise -> notifyContacts event orig V2.RouteDirect conn + UserActivated {} -> notifySelf event orig V2.RouteAny conn + UserIdentityUpdated {} -> notifySelf event orig V2.RouteDirect conn + UserIdentityRemoved {} -> notifySelf event orig V2.RouteDirect conn + UserDeleted {} -> do + -- n.b. Synchronously fetch the contact list on the current thread. + -- If done asynchronously, the connections may already have been deleted. + notifyUserDeletionLocals orig conn event + notifyUserDeletionRemotes orig + where + event = UserEvent e + +-- | Notify local users about a user deletion +notifyUserDeletionLocals :: + forall r. + ( Member (ConnectionStore InternalPaging) r, + Member NotificationSubsystem r, + Member (Input (Local ())) r, + Member Now r + ) => + UserId -> + Maybe ConnId -> + Event -> + Sem r () +notifyUserDeletionLocals deleted conn event = do + luid <- qualifyLocal' deleted + -- first we send a notification to the deleted user's devices + notify event deleted V2.RouteDirect conn (pure (deleted :| [])) + -- then to all their connections + connectionPages Nothing luid (toRange (Proxy @500)) + where + handler :: [UserConnection] -> Sem r () + handler connections = do + -- sent event to connections that are accepted + case qUnqualified . ucTo <$> filter ((==) Accepted . ucStatus) connections of + x : xs -> notify event deleted V2.RouteDirect conn (pure (x :| xs)) + [] -> pure () + -- also send a connection cancelled event to connections that are pending + d <- tDomain <$> input + forM_ + (filter ((==) Sent . ucStatus) connections) + ( \uc -> do + now <- toUTCTimeMillis <$> Now.get + -- because the connections are going to be removed from the database anyway when a user gets deleted + -- we don't need to save the updated connection state in the database + -- note that we switch from and to users so that the "other" user becomes the recipient of the event + let ucCancelled = + UserConnection + (qUnqualified (ucTo uc)) + (Qualified (ucFrom uc) d) + Cancelled + now + (ucConvId uc) + let e = ConnectionUpdated ucCancelled Nothing + onConnectionEvent deleted conn e + ) + + connectionPages :: Maybe UserId -> Local UserId -> Range 1 500 Int32 -> Sem r () + connectionPages mbStart user pageSize = do + page <- CS.lookupLocalConnections user mbStart pageSize + case resultList page of + [] -> pure () + xs -> do + handler xs + when (resultHasMore page) $ + connectionPages (Just (maximum (qUnqualified . ucTo <$> xs))) user pageSize + +-- | Notify remote backends about a user deletion +notifyUserDeletionRemotes :: + forall r. + ( Member TinyLog r, + Member (Input (Local ())) r, + Member (ConnectionStore InternalPaging) r + ) => + UserId -> + Sem r () +notifyUserDeletionRemotes deleted = do + luid <- qualifyLocal' deleted + P.withChunks (\mps -> CS.remoteConnectedUsersPaginated luid mps maxBound) fanoutNotifications + where + fanoutNotifications :: [Remote UserConnection] -> Sem r () + fanoutNotifications = mapM_ notifyBackend . bucketRemote + + notifyBackend :: Remote [UserConnection] -> Sem r () + notifyBackend ucs = do + -- FUTUREWORK: Federation notifications for user deletion + -- This requires Brig-specific federation client functions that + -- haven't been moved to wire-subsystem yet. For now, federation + -- notifications are handled by Brig directly. + -- See: Brig.Federation.Client.notifyUserDeleted and sendConnectionAction + unless (null (tUnqualified ucs)) $ + Log.warn $ + field "domain" (show (tDomain ucs)) + . msg (val "Skipping federation notification for user deletion (not yet implemented in wire-subsystem)") + +-- | (Asynchronously) notifies other users of events. +notify :: + (Member NotificationSubsystem r) => + Event -> + -- | Origin user, TODO: Delete + UserId -> + -- | Push routing strategy. + V2.Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + -- | Users to notify. + Sem r (NonEmpty UserId) -> + Sem r () +notify event orig route conn recipients = do + rs <- (\u -> Recipient u RecipientClientsAll) <$$> recipients + let push = + def + { origin = Just orig, + json = toJSONObject event, + recipients = toList rs, + conn, + route, + apsData = toApsData event + } + void $ pushNotificationAsync push + +-- | Notify only the origin user +notifySelf :: + (Member NotificationSubsystem r) => + Event -> + -- | Origin user. + UserId -> + -- | Push routing strategy. + V2.Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + Sem r () +notifySelf event orig route conn = + notify event orig route conn (pure (orig :| [])) + +-- | Notify the origin user's contacts (connections and team members) +notifyContacts :: + forall r. + ( Member (ConnectionStore InternalPaging) r, + Member GalleyAPIAccess r, + Member NotificationSubsystem r + ) => + Event -> + -- | Origin user. + UserId -> + -- | Push routing strategy. + V2.Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + Sem r () +notifyContacts event orig route conn = do + notify event orig route conn $ + (:|) orig <$> liftA2 (++) contacts teamContacts + where + contacts :: Sem r [UserId] + contacts = CS.lookupContactList orig + + teamContacts :: Sem r [UserId] + teamContacts = screenMemberList <$> GalleyAPI.getTeamContacts orig + -- If we have a truncated team, we just ignore it all together to avoid very large fanouts + -- + screenMemberList :: Maybe TeamMemberList -> [UserId] + screenMemberList (Just mems) + | mems ^. teamMemberListType == ListComplete = + view TM.userId <$> mems ^. teamMembers + screenMemberList _ = [] + +-- | Event handler for connection events +onConnectionEvent :: + (Member NotificationSubsystem r) => + -- | Originator of the event. + UserId -> + -- | Client connection ID, if any. + Maybe ConnId -> + -- | The event. + ConnectionEvent -> + Sem r () +onConnectionEvent orig conn evt = do + let from = ucFrom (ucConn evt) + notify + (ConnectionEvent evt) + orig + V2.RouteAny + conn + (pure $ from :| []) + +-- | Convert events to APS data for iOS push notifications +toApsData :: Event -> Maybe V2.ApsData +toApsData (ConnectionEvent (ConnectionUpdated uc name)) = + case (ucStatus uc, name) of + (MissingLegalholdConsent, _) -> Nothing + (Pending, n) -> apsConnRequest <$> n + (Accepted, n) -> apsConnAccept <$> n + (Blocked, _) -> Nothing + (Ignored, _) -> Nothing + (Sent, _) -> Nothing + (Cancelled, _) -> Nothing + where + apsConnRequest n = + V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" + apsConnAccept n = + V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] + & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" +toApsData _ = Nothing diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 07fd8d4a28..771d31f94a 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -145,5 +145,8 @@ data GalleyAPIAccess m a where GalleyAPIAccess m [EJPDConvInfo] GetTeamAdmins :: TeamId -> GalleyAPIAccess m Team.TeamMemberList InternalGetConversation :: ConvId -> GalleyAPIAccess m (Maybe Conversation) + GetTeamContacts :: + UserId -> + GalleyAPIAccess m (Maybe Team.TeamMemberList) makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 2562ae6c29..bcce4a2448 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -97,6 +97,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetEJPDConvInfo uid -> getEJPDConvInfo uid GetTeamAdmins tid -> getTeamAdmins tid InternalGetConversation id' -> internalGetConversation id' + GetTeamContacts uid -> getTeamContacts uid getUserLegalholdStatus :: ( Member TinyLog r, @@ -704,3 +705,26 @@ internalGetConversation convId = do method GET . paths ["i", "conversations", toByteString' convId] . expect [status200, status404] + +getTeamContacts :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + UserId -> + Sem r (Maybe Member.TeamMemberList) +getTeamContacts uid = do + debug $ + remote "galley" + . field "user" (toByteString uid) + . msg (val "Getting team contacts") + rs <- galleyRequest req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBodyOrThrow "galley" rs + _ -> pure Nothing + where + req = + method GET + . paths ["i", "users", toByteString' uid, "team", "members"] + . expect [status200, status404] diff --git a/libs/wire-subsystems/src/Wire/ParseException.hs b/libs/wire-subsystems/src/Wire/ParseException.hs index 815dd28c36..40d176c72b 100644 --- a/libs/wire-subsystems/src/Wire/ParseException.hs +++ b/libs/wire-subsystems/src/Wire/ParseException.hs @@ -6,6 +6,7 @@ import Network.HTTP.Types import Network.Wai.Utilities import Network.Wai.Utilities.JSONResponse import Wire.API.Error +import Wire.Error -- | Failed to parse a response from another service. data ParseException = ParseException @@ -23,3 +24,6 @@ instance Exception ParseException where instance APIError ParseException where toResponse _ = waiErrorToJSONResponse $ mkError status500 "internal-error" "Internal server error" + +parseExceptionToHttpError :: ParseException -> HttpError +parseExceptionToHttpError (ParseException _ _) = StdError (mkError status500 "internal-error" mempty) diff --git a/libs/wire-subsystems/src/Wire/ScimSubsystem.hs b/libs/wire-subsystems/src/Wire/ScimSubsystem.hs new file mode 100644 index 0000000000..590bc44571 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ScimSubsystem.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.ScimSubsystem where + +import Data.Id +import Polysemy +import Web.Scim.Class.Group qualified as SCG +import Wire.API.User.Scim (SparTag) + +data ScimSubsystem m a where + ScimCreateUserGroup :: TeamId -> SCG.Group -> ScimSubsystem m (SCG.StoredGroup SparTag) + +makeSem ''ScimSubsystem diff --git a/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs new file mode 100644 index 0000000000..aecb43402d --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs @@ -0,0 +1,118 @@ +module Wire.ScimSubsystem.Interpreter where + +import Data.Default +import Data.Id +import Data.Json.Util +import Data.Qualified +import Data.Text qualified as Text +import Data.Vector qualified as V +import Imports +import Network.URI (parseURI) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Web.Scim.Class.Group qualified as SCG +import Web.Scim.Schema.Common qualified as Common +import Web.Scim.Schema.Error +import Web.Scim.Schema.Meta qualified as Meta +import Web.Scim.Schema.ResourceType qualified as RT +import Wire.API.User +import Wire.API.User.Scim (SparTag) +import Wire.API.UserGroup +import Wire.ScimSubsystem +import Wire.UserGroupSubsystem +import Wire.UserSubsystem + +data ScimSubsystemConfig = ScimSubsystemConfig + { scimBaseUri :: Common.URI + } + +interpretScimSubsystem :: + ( Member UserGroupSubsystem r, + Member (Input ScimSubsystemConfig) r, + Member (Error ScimSubsystemError) r, + Member UserSubsystem r, + Member (Input (Local ())) r + ) => + InterpreterFor ScimSubsystem r +interpretScimSubsystem = interpret $ \case + ScimCreateUserGroup teamId scimGroup -> createScimGroupImpl teamId scimGroup + +data ScimSubsystemError + = ScimSubsystemError ScimError + | ScimSubsystemInvalidGroupMemberId Text + | ScimSubsystemScimGroupWithNonScimMembers [UserId] + deriving (Show, Eq) + +scimThrow :: (Member (Error ScimSubsystemError) r) => ScimError -> Sem r a +scimThrow = throw . ScimSubsystemError + +createScimGroupImpl :: + forall r. + ( Member UserGroupSubsystem r, + Member (Input ScimSubsystemConfig) r, + Member (Error ScimSubsystemError) r, + Member UserSubsystem r, + Member (Input (Local ())) r + ) => + TeamId -> + SCG.Group -> + Sem r (SCG.StoredGroup SparTag) +createScimGroupImpl teamId grp = do + membersNotManagedByScim <- do + let uidsAsText = (.value) <$> grp.members + uids :: [UserId] <- + let thrw = throw . ScimSubsystemInvalidGroupMemberId + in forM uidsAsText $ either (thrw . Text.pack) pure . parseIdFromText + getby :: Local GetBy <- inputQualifyLocal def {getByUserId = uids} + getAccountsBy getby + <&> filter (\u -> u.userManagedBy /= ManagedByScim) + <&> fmap userId + unless (null membersNotManagedByScim) do + throw (ScimSubsystemScimGroupWithNonScimMembers membersNotManagedByScim) + + ugName <- + userGroupNameFromText grp.displayName + & either (scimThrow . badRequest InvalidValue . Just) pure + ugMemberIds <- + let go :: SCG.Member -> Sem r UserId + go m = + parseIdFromText m.value + & either (scimThrow . badRequest InvalidValue . Just . Text.pack) pure + in go `mapM` grp.members + + let newGroup = NewUserGroup {name = ugName, members = V.fromList ugMemberIds} + ug <- createGroupFull ManagedByScim teamId Nothing newGroup + ScimSubsystemConfig scimBaseUri <- input + pure $ toStoredGroup scimBaseUri ug + +toStoredGroup :: Common.URI -> UserGroup -> SCG.StoredGroup SparTag +toStoredGroup scimBaseUri ug = Meta.WithMeta meta (Common.WithId ug.id_ sg) + where + mkLocation :: String -> Common.URI + mkLocation pathSuffix = + let uri = Common.uriToString scimBaseUri <> pathSuffix + in maybe (error "invalid SCIM group location URI") Common.URI (parseURI uri) + + meta = + Meta.Meta + { Meta.resourceType = RT.GroupResource, + Meta.created = fromUTCTimeMillis ug.createdAt, + Meta.lastModified = fromUTCTimeMillis ug.createdAt, + Meta.version = Meta.Weak "v1", + Meta.location = mkLocation $ "/Groups/" <> Text.unpack (idToText ug.id_) + } + + sg = + SCG.Group + { schemas = ["urn:ietf:params:scim:schemas:core:2.0:Group"], + displayName = userGroupNameToText ug.name, + members = + [ SCG.Member + { value = idToText uid, + typ = "User", + ref = Common.uriToText . mkLocation $ "/Users/" <> idToString uid + } + | uid <- toList (runIdentity ug.members) + ] + } diff --git a/services/brig/src/Brig/Effects/ConnectionStore.hs b/libs/wire-subsystems/src/Wire/StompSubsystem.hs similarity index 59% rename from services/brig/src/Brig/Effects/ConnectionStore.hs rename to libs/wire-subsystems/src/Wire/StompSubsystem.hs index 013232d268..1a6b0518c4 100644 --- a/services/brig/src/Brig/Effects/ConnectionStore.hs +++ b/libs/wire-subsystems/src/Wire/StompSubsystem.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2024 Wire Swiss GmbH +-- Copyright (C) 2025 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 @@ -14,22 +16,15 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE TemplateHaskell #-} -module Brig.Effects.ConnectionStore where +module Wire.StompSubsystem where -import Data.Id -import Data.Qualified (Local, Remote) +import Data.Aeson (FromJSON, ToJSON) import Imports -import Polysemy -import Wire.API.Connection (UserConnection) -import Wire.Sem.Paging (Page, PagingBounds, PagingState) +import Polysemy (makeSem) -data ConnectionStore p m a where - RemoteConnectedUsersPaginated :: - Local UserId -> - Maybe (PagingState p (Remote UserConnection)) -> - PagingBounds p (Remote UserConnection) -> - ConnectionStore p m (Page p (Remote UserConnection)) +data StompSubsystem m r where + Enqueue :: (ToJSON a) => Text -> Text -> a -> StompSubsystem m () + Listen :: (FromJSON a, Show a) => Text -> Text -> (a -> m ()) -> StompSubsystem m () -makeSem ''ConnectionStore +makeSem ''StompSubsystem diff --git a/services/brig/src/Brig/Queue/Stomp.hs b/libs/wire-subsystems/src/Wire/StompSubsystem/Stomp.hs similarity index 61% rename from services/brig/src/Brig/Queue/Stomp.hs rename to libs/wire-subsystems/src/Wire/StompSubsystem/Stomp.hs index 631f790013..72cd9d4eb1 100644 --- a/services/brig/src/Brig/Queue/Stomp.hs +++ b/libs/wire-subsystems/src/Wire/StompSubsystem/Stomp.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -16,34 +21,38 @@ -- with this program. If not, see . -- | Working with STOMP queues (targeting ActiveMQ specifically). -module Brig.Queue.Stomp +module Wire.StompSubsystem.Stomp ( Env (..), + Stomp (..), mkEnv, Broker (..), Credentials (..), - enqueue, - listen, + StompOpts (..), + enqueueInternal, + listenInternal, + runStompSubsystem, ) where -import BasePrelude hiding (Handler, throwIO) -import Brig.Options qualified as Opts import Codec.MIME.Type qualified as MIME -import Control.Monad.Catch (Handler (..), MonadMask) +import Control.Lens hiding ((.=)) +import Control.Monad.Catch (Handler (..), MonadCatch, MonadMask, try) +import Control.Monad.Trans.Resource import Control.Retry hiding (retryPolicy) import Data.Aeson as Aeson import Data.ByteString.Lazy qualified as BL +import Data.Char qualified as Char import Data.Conduit.Network.TLS import Data.Text import Data.Text.Encoding +import Imports import Network.Mom.Stompl.Client.Queue hiding (try) -import System.Logger.Class as Log -import UnliftIO (MonadUnliftIO, throwIO, withRunInIO) - -data Env = Env - { -- | STOMP broker that we're using - broker :: Broker - } +import Polysemy +import Polysemy.Final +import System.Logger qualified as Logger +import System.Logger.Class as Log hiding (settings) +import UnliftIO (throwIO, timeout) +import Wire.StompSubsystem data Broker = Broker { -- | Broker URL @@ -65,16 +74,63 @@ data Credentials = Credentials instance FromJSON Credentials +data StompOpts = StompOpts + { host :: !Text, + port :: !Int, + tls :: !Bool + } + deriving (Show, Generic) + +instance FromJSON StompOpts where + parseJSON = genericParseJSON customOptions + where + customOptions = + defaultOptions + { fieldLabelModifier = \a -> "stom" <> capitalise a + } + capitalise :: String -> String + capitalise [] = [] + capitalise (x : xs) = Char.toUpper x : xs + +data Env = Env + { _logger :: !Logger.Logger, + _broker :: !Broker + } + +makeLenses ''Env + +newtype Stomp a = Stomp + { unStomp :: ReaderT Env (ResourceT IO) a + } + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader Env, + MonadResource, + MonadUnliftIO + ) + +instance MonadLogger Stomp where + log l m = view logger >>= \g -> Logger.log g l m + -- | Construct an 'Env' with some default settings. mkEnv :: + -- | Logger + Logger.Logger -> -- | Options that can be customized - Opts.StompOpts -> + StompOpts -> -- | Credentials Credentials -> Env -mkEnv o cred = +mkEnv lgr o cred = Env - { broker = + { _logger = Logger.clone (Just "stomp") lgr, + _broker = Broker { host = o.host, port = o.port, @@ -87,17 +143,18 @@ mkEnv o cred = -- -- In case of failure will try five more times. The timeout for each attempt -- is 500ms. -enqueue :: (ToJSON a, MonadIO m) => Broker -> Text -> a -> m () -enqueue b q m = - retrying retryPolicy retryPredicate (const enqueueAction) >>= either throwIO pure +enqueueInternal :: (ToJSON a) => Text -> a -> Stomp () +enqueueInternal q m = do + b <- view broker + retrying (retryPolicy b) (retryPredicate b) (const $ enqueueAction b) >>= either throwIO pure where - retryPredicate _ res = pure (isLeft res) - retryPolicy = limitRetries 5 <> exponentialBackoff 50000 - enqueueAction = + retryPredicate _ _ res = pure (isLeft res) + retryPolicy _ = limitRetries 5 <> exponentialBackoff 50000 + enqueueAction broker' = liftIO $ - try @StomplException $ + (try :: IO () -> IO (Either StomplException ())) $ stompTimeout "enqueue" 500000 $ - withConnection' b $ + withConnection' broker' $ \conn -> withWriter conn @@ -127,27 +184,25 @@ enqueue b q m = -- -- In case of connection failure or an exception, will retry indefinitely. -- --- When 'listen' catches any kind of exception, it will reestablish the +-- When 'listenInternal' catches any kind of exception, it will reestablish the -- connection and get a new message to process. Assuming that the broker is -- configured properly, after failing on the same message several times the -- message will go into the Dead Letter Queue where it can be analyzed -- manually. --- --- FUTUREWORK: This probably deserves a Polysemy action -listen :: - (FromJSON a, MonadLogger m, MonadMask m, MonadUnliftIO m) => - Broker -> +listenInternal :: + (FromJSON a) => Text -> - (a -> m ()) -> - m () -listen b q callback = - recovering retryPolicy handlers (const listenAction) + (a -> IO ()) -> + Stomp () +listenInternal q callback = do + b <- view broker + recovering retryPolicy (handlers b) (const $ listenAction b) where retryPolicy = constantDelay 1000000 - listenAction = - withRunInIO $ \runInIO -> - withConnection' b $ \conn -> - withReader + listenAction broker' = + withRunInIO $ \_ -> + withConnection' broker' $ \conn -> + Network.Mom.Stompl.Client.Queue.withReader conn (unpack q) (unpack q) @@ -159,9 +214,9 @@ listen b q callback = -- NB: 'readQ' can't timeout because it's just reading from -- a chan (no network queries are being made) m <- readQ r - runInIO $ callback (msgContent m) + callback (msgContent m) stompTimeout "listen/ack" 1000000 $ ack conn m - handlers = skipAsyncExceptions ++ [logError] + handlers _ = skipAsyncExceptions ++ [logError] logError = const . Handler $ \(e :: SomeException) -> do Log.err $ msg (val "Exception when listening to a STOMP queue") @@ -197,11 +252,11 @@ jsonType = MIME.Type (MIME.Application "json") [] -- | Set up a STOMP connection. withConnection' :: Broker -> (Con -> IO a) -> IO a withConnection' b = - withConnection (unpack (host b)) (port b) config [] + withConnection (unpack b.host) b.port config [] where config = - [OAuth (unpack (user cred)) (unpack (pass cred)) | Just cred <- [auth b]] - ++ [OTLS (tlsClientConfig (port b) (encodeUtf8 (host b))) | tls b] + [OAuth (unpack cred.user) (unpack cred.pass) | Just cred <- [b.auth]] + ++ [OTLS (tlsClientConfig b.port (encodeUtf8 b.host)) | b.tls] ++ [OTmo 1000] -- | Like 'timeout', but throws an 'AppException' instead of returning a @@ -214,3 +269,18 @@ stompTimeout location t act = throwIO $ AppException $ location <> ": STOMP request took more than " <> show t <> "mcs and has timed out" + +------------------------------------------------------------------------------- +-- Polysemy Interpreter + +runStompSubsystem :: + (Member (Final IO) r) => + Env -> + Sem (StompSubsystem : r) a -> + Sem r a +runStompSubsystem env = interpretFinal $ \case + Enqueue _host queue message -> liftS @IO $ runResourceT $ runReaderT (enqueueInternal queue message).unStomp env + Listen _host queue callback -> do + callbackS <- bindS callback + s <- getInitialStateS + liftS @IO $ runResourceT $ runReaderT ((listenInternal queue $ \message -> void $ callbackS (s $> message)).unStomp) env diff --git a/libs/wire-subsystems/src/Wire/UserGroupSubsystem.hs b/libs/wire-subsystems/src/Wire/UserGroupSubsystem.hs index beb132825b..1942bc768d 100644 --- a/libs/wire-subsystems/src/Wire/UserGroupSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserGroupSubsystem.hs @@ -10,6 +10,7 @@ import Data.Vector (Vector) import Imports import Polysemy import Wire.API.Pagination +import Wire.API.User.Profile (ManagedBy) import Wire.API.UserGroup import Wire.API.UserGroup.Pagination @@ -41,6 +42,7 @@ instance Default GroupSearch where data UserGroupSubsystem m a where CreateGroup :: UserId -> NewUserGroup -> UserGroupSubsystem m UserGroup + CreateGroupFull :: ManagedBy -> TeamId -> Maybe UserId -> NewUserGroup -> UserGroupSubsystem r UserGroup GetGroup :: UserId -> UserGroupId -> Bool -> UserGroupSubsystem m (Maybe UserGroup) GetGroups :: UserId -> GroupSearch -> UserGroupSubsystem m UserGroupPage UpdateGroup :: UserId -> UserGroupId -> UserGroupUpdate -> UserGroupSubsystem m () diff --git a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs index 151152b12b..32b8f51454 100644 --- a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs @@ -45,6 +45,7 @@ interpretUserGroupSubsystem :: InterpreterFor UserGroupSubsystem r interpretUserGroupSubsystem = interpret $ \case CreateGroup creator newGroup -> createUserGroup creator newGroup + CreateGroupFull managedBy team mbCreator newGroup -> createUserGroupFullImpl managedBy team mbCreator newGroup GetGroup getter gid includeChannels -> getUserGroup getter gid includeChannels GetGroups getter search -> getUserGroups getter search UpdateGroup updater groupId groupUpdate -> updateGroup updater groupId groupUpdate @@ -84,8 +85,24 @@ createUserGroup :: NewUserGroup -> Sem r UserGroup createUserGroup creator newGroup = do - let managedBy = ManagedByWire team <- getTeamAsAdmin creator >>= note UserGroupNotATeamAdmin + createUserGroupFullImpl ManagedByWire team (Just creator) newGroup + +createUserGroupFullImpl :: + ( Member UserSubsystem r, + Member (Error UserGroupSubsystemError) r, + Member Store.UserGroupStore r, + Member (Input (Local ())) r, + Member NotificationSubsystem r, + Member TeamSubsystem r + ) => + ManagedBy -> + TeamId {- home team of the user group.-} -> + Maybe UserId {- creator of the user group (just needed for exclusion from event; this is not + checked for consistency with TeamId. -} -> + NewUserGroup -> + Sem r UserGroup +createUserGroupFullImpl managedBy team mbCreator newGroup = do luids <- qualifyLocal $ toList newGroup.members profiles <- getLocalUserProfiles luids let existingIds = Set.fromList $ fmap (qUnqualified . profileQualifiedId) profiles @@ -97,7 +114,7 @@ createUserGroup creator newGroup = do ug <- Store.createUserGroup team newGroup managedBy admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team pushNotifications - [ mkEvent creator (UserGroupCreated ug.id_) admins + [ mmkEvent mbCreator (UserGroupCreated ug.id_) admins ] pure ug @@ -123,15 +140,18 @@ getTeamAsMember memberId = runMaybeT do mbr <- MaybeT $ internalGetTeamMember memberId team pure (team, mbr) -mkEvent :: UserId -> UserGroupEvent -> [UserId] -> Push -mkEvent author evt recipients = +mmkEvent :: Maybe UserId -> UserGroupEvent -> [UserId] -> Push +mmkEvent mAuthor evt recipients = def - { origin = Just author, + { origin = mAuthor, json = toJSONObject $ UserGroupEvent evt, recipients = (\uid -> Recipient {recipientUserId = uid, recipientClients = RecipientClientsAll}) <$> recipients, transient = True } +mkEvent :: UserId -> UserGroupEvent -> [UserId] -> Push +mkEvent = mmkEvent . Just + qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a) qualifyLocal a = do l <- input diff --git a/services/brig/test/resources/internal-notification.json b/libs/wire-subsystems/test/resources/internal-notification.json similarity index 100% rename from services/brig/test/resources/internal-notification.json rename to libs/wire-subsystems/test/resources/internal-notification.json diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index a4d35656f9..29ba317262 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -50,6 +50,7 @@ miniGalleyAPIAccess teams configs = interpret $ \case GetTeamAdmins tid -> pure $ newTeamMemberList (maybe [] (filter (\tm -> isAdminOrOwner (tm ^. permissions))) $ Map.lookup tid teams) ListComplete SelectTeamMemberInfos tid uids -> pure $ selectTeamMemberInfosImpl teams tid uids InternalGetConversation _ -> error "GetConv not implemented in InternalGetConversation" + GetTeamContacts _ -> pure Nothing -- this is called but the result is not needed in unit tests selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 66e43c6b9d..5007192df5 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -27,6 +27,8 @@ userSubsystemTestInterpreter initialUsers = GetLocalUserProfiles luids -> let uids = qUnqualified $ tUntagged luids in pure (toProfile <$> filter (\u -> userId u `elem` uids) initialUsers) + GetAccountsBy (tUnqualified -> MkGetBy NoPendingInvitations uids []) -> + pure (filter (\u -> userId u `elem` uids) initialUsers) GetAccountsBy _ -> error "GetAccountsBy: implement on demand (userSubsystemInterpreter)" GetAccountNoFilter _ -> error "GetAccountNoFilter: implement on demand (userSubsystemInterpreter)" UpdateUserProfile {} -> error "UpdateUserProfile: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs new file mode 100644 index 0000000000..4cf2bbbab7 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields -Wno-incomplete-uni-patterns -Wno-incomplete-patterns -Wno-orphans #-} + +module Wire.ScimSubsystem.InterpreterSpec (spec) where + +import Data.Id +import Data.Text qualified as Text +import Imports +import Network.URI +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.Internal.Kind +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Web.Scim.Class.Group qualified as Group +import Web.Scim.Schema.Common qualified as Common +import Web.Scim.Schema.Meta qualified as Common +import Wire.API.Team.Member as TM +import Wire.API.User as User +import Wire.API.User.Scim +import Wire.API.UserGroup +import Wire.ScimSubsystem +import Wire.ScimSubsystem.Interpreter +import Wire.UserGroupSubsystem qualified as UGS +import Wire.UserGroupSubsystem.Interpreter qualified as UGS +import Wire.UserGroupSubsystem.InterpreterSpec qualified as UGS + +type AllDependencies = + [ ScimSubsystem, + Input ScimSubsystemConfig, + Error ScimSubsystemError, + UGS.UserGroupSubsystem + ] + `Append` UGS.AllDependencies + +runDependencies :: + forall a. + [User] -> + Map TeamId [TeamMember] -> + Sem AllDependencies a -> + Either ScimSubsystemError a +runDependencies initialUsers initialTeams = + run + . lowerLevelStuff + . UGS.interpretUserGroupSubsystem + . runError + . runInputConst (ScimSubsystemConfig scimBaseUri) + . interpretScimSubsystem + where + scimBaseUri :: Common.URI + scimBaseUri = Common.URI . fromJust . parseURI $ "http://nowhere.net/scim/v2" + + lowerLevelStuff :: InterpretersFor UGS.AllDependencies r + lowerLevelStuff = crashOnLowerErrors . UGS.interpretDependencies initialUsers initialTeams + where + crashOnLowerErrors = fmap (either (error . show) id) . runError + +instance Arbitrary Group.Group where + arbitrary = do + name <- Text.pack . take 4000 <$> ((:) <$> arbitrary <*> arbitrary) + pure + Group.Group + { schemas = ["urn:ietf:params:scim:schemas:core:2.0:Group"], + displayName = name, + members = [] + } + +mkScimGroupMember :: User -> Group.Member +mkScimGroupMember (idToText . User.userId -> value) = + let typ = "User" + ref = "$schema://$host.$domain/scim/vs/Users/$uuid" -- not a real URI, just a string for testing. + in Group.Member {..} + +spec :: Spec +spec = focus . UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do + describe "scimCreateUserGroup" $ do + prop "creates a group returns it" $ \(team :: UGS.ArbitraryTeam) (newScimGroup_ :: Group.Group) -> + let newScimGroup = + newScimGroup_ + { Group.members = + let all_ = UGS.allUsers team + nonscim_ = filter (\u -> u.userManagedBy == ManagedByScim) all_ + in mkScimGroupMember <$> nonscim_ + } + resultOrError = do + runDependencies (UGS.allUsers team) (UGS.galleyTeam team) $ do + createdGroup :: Group.StoredGroup SparTag <- scimCreateUserGroup team.tid newScimGroup + retrievedGroup :: Maybe UserGroup <- UGS.getGroup (UGS.ownerId team) createdGroup.thing.id False + pure (createdGroup, retrievedGroup) + in case resultOrError of + Left err -> counterexample ("Left: " ++ show err) False + Right (createdGroup, retrievedGroup) -> + Just createdGroup.thing.id === ((.id_) <$> retrievedGroup) + + it "does not allow non-scim members" $ do + team :: UGS.ArbitraryTeam <- generate arbitrary + newScimGroup :: Group.Group <- do + generate arbitrary <&> \g -> g {Group.members = take 2 $ mkScimGroupMember <$> UGS.allUsers team} + let have = + runDependencies (UGS.allUsers team) (UGS.galleyTeam team) $ do + scimCreateUserGroup team.tid newScimGroup + want = + if all (\u -> u.userManagedBy == ManagedByScim) (UGS.allUsers team) + then isRight + else isLeft + unless (want have) do + expectationFailure . show $ ((.userManagedBy) <$> UGS.allUsers team) + + describe "getScimGroup" $ do + it "retrieves metadata intact" $ do + pendingWith "we actually haven't implemented metadata storage in store, because it was weird to test it without get." diff --git a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs index aa35062d5c..adc6c43ed7 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserGroupSubsystem/InterpreterSpec.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wno-ambiguous-fields -Wno-incomplete-uni-patterns -Wno-incomplete-patterns #-} -module Wire.UserGroupSubsystem.InterpreterSpec (spec) where +module Wire.UserGroupSubsystem.InterpreterSpec where import Control.Error.Util (hush) import Control.Lens ((.~), (^.)) @@ -70,9 +70,16 @@ runDependencies :: Sem AllDependencies a -> Either UserGroupSubsystemError a runDependencies initialUsers initialTeams = - run - . runError - . evalState mempty + run . runError . interpretDependencies initialUsers initialTeams + +interpretDependencies :: + forall r a. + [User] -> + Map TeamId [TeamMember] -> + Sem (AllDependencies `Append` r) a -> + Sem ('[Error UserGroupSubsystemError] `Append` r) a +interpretDependencies initialUsers initialTeams = + evalState mempty . inMemoryNotificationSubsystemInterpreter . evalState defaultTime . runInputConst (toLocalUnsafe (Domain "example.com") ()) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 8e7deafde7..76f5fbafe4 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -79,7 +79,9 @@ common common-all , aeson-pretty , amazonka , amazonka-core + , amazonka-dynamodb , amazonka-ses + , amazonka-sqs , amqp , async , attoparsec @@ -115,6 +117,7 @@ common common-all , hasql-th , hasql-transaction , hex + , hscim , HsOpenSSL , hspec , html-entities @@ -129,8 +132,10 @@ common common-all , memory , mime , mime-mail + , mmorph , network , network-conduit-tls + , network-uri , polysemy , polysemy-conc , polysemy-plugin @@ -138,6 +143,7 @@ common common-all , polysemy-wire-zoo , profunctors , prometheus-client + , proto-lens , QuickCheck , raw-strings-qq , resource-pool @@ -161,6 +167,7 @@ common common-all , token-bucket , transformers , types-common + , types-common-journal , unliftio , unordered-containers , uri-bytestring @@ -193,10 +200,15 @@ library Wire.AuthenticationSubsystem.Interpreter Wire.AuthenticationSubsystem.ZAuth Wire.AWS + Wire.AWSSubsystem + Wire.AWSSubsystem.AWS Wire.BlockListStore Wire.BlockListStore.Cassandra Wire.BrigAPIAccess Wire.BrigAPIAccess.Rpc + Wire.ConnectionStore + Wire.ConnectionStore.Cassandra + Wire.ConnectionStore.Types Wire.ConversationStore Wire.ConversationStore.Cassandra Wire.ConversationStore.Cassandra.Instances @@ -209,11 +221,15 @@ library Wire.ConversationStore.Postgres Wire.DeleteQueue Wire.DeleteQueue.InMemory + Wire.DeleteQueue.Interpreter + Wire.DeleteQueue.Listen + Wire.DeleteQueue.Types Wire.DomainRegistrationStore Wire.DomainRegistrationStore.Cassandra Wire.DomainVerificationChallengeStore Wire.DomainVerificationChallengeStore.Cassandra Wire.EmailSending + Wire.EmailSending.Core Wire.EmailSending.SES Wire.EmailSending.SMTP Wire.EmailSubsystem @@ -225,6 +241,9 @@ library Wire.EnterpriseLoginSubsystem.Null Wire.Error Wire.Events + Wire.Events.Interpreter + Wire.Events.Journal + Wire.Events.Notifications Wire.FederationAPIAccess Wire.FederationAPIAccess.Interpreter Wire.FederationConfigStore @@ -263,10 +282,14 @@ library Wire.RateLimit Wire.RateLimit.Interpreter Wire.Rpc + Wire.ScimSubsystem + Wire.ScimSubsystem.Interpreter Wire.SessionStore Wire.SessionStore.Cassandra Wire.SparAPIAccess Wire.SparAPIAccess.Rpc + Wire.StompSubsystem + Wire.StompSubsystem.Stomp Wire.StoredConversation Wire.StoredUser Wire.TeamCollaboratorsStore @@ -357,6 +380,7 @@ library , memory , mime , mime-mail + , mmorph , network , network-conduit-tls , polysemy @@ -453,6 +477,7 @@ test-suite wire-subsystems-tests Wire.NotificationSubsystem.InterpreterSpec Wire.PropertySubsystem.InterpreterSpec Wire.RateLimited.InterpreterSpec + Wire.ScimSubsystem.InterpreterSpec Wire.TeamCollaboratorsSubsystem.InterpreterSpec Wire.TeamInvitationSubsystem.InterpreterSpec Wire.UserGroupSubsystem.InterpreterSpec diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 67449f7bb0..8b834884f0 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -96,7 +96,6 @@ library Brig.API.User Brig.API.Util Brig.App - Brig.AWS Brig.AWS.SesNotification Brig.AWS.Types Brig.Budget @@ -111,9 +110,6 @@ library Brig.Data.Nonce Brig.Data.Types Brig.Data.User - Brig.DeleteQueue.Interpreter - Brig.Effects.ConnectionStore - Brig.Effects.ConnectionStore.Cassandra Brig.Effects.JwtTools Brig.Effects.PublicKeyBundle Brig.Effects.SFT @@ -126,7 +122,6 @@ library Brig.InternalEvent.Process Brig.InternalEvent.Types Brig.IO.Intra - Brig.IO.Journal Brig.IO.Logging Brig.Main Brig.Options @@ -135,9 +130,6 @@ library Brig.Provider.Email Brig.Provider.RPC Brig.Provider.Template - Brig.Queue - Brig.Queue.Stomp - Brig.Queue.Types Brig.RPC Brig.Run Brig.Schema.Run @@ -213,14 +205,11 @@ library , amazonka >=2 , amazonka-core >=2 , amazonka-dynamodb >=2 - , amazonka-ses >=2 - , amazonka-sqs >=2 , amqp , async >=2.1 , auto-update >=0.1 , base >=4 && <5 , base-prelude - , base16-bytestring >=0.1 , base64-bytestring >=1.0 , bilge >=0.21.1 , bloodhound >=0.13 @@ -269,13 +258,11 @@ library , memory , metrics-core >=0.3 , metrics-wai >=0.3 - , mime , mime-mail >=0.4 , mmorph , MonadRandom >=0.5 , mtl >=2.1 , network >=2.4 - , network-conduit-tls , openapi3 , optparse-applicative >=0.11 , polysemy @@ -284,7 +271,6 @@ library , polysemy-time , polysemy-wire-zoo , prometheus-client - , proto-lens >=0.1 , random-shuffle >=0.0.3 , raw-strings-qq , resourcet >=1.1 @@ -297,7 +283,6 @@ library , servant-swagger-ui , split >=0.2 , ssl-util - , stomp-queue >=0.3 , template >=0.2 , template-haskell , text >=0.11 @@ -308,7 +293,6 @@ library , transformers >=0.3 , types-common >=0.16 , types-common-aws - , types-common-journal >=0.1 , unliftio >=0.2 , unordered-containers >=0.2 , uri-bytestring >=0.2 diff --git a/services/brig/default.nix b/services/brig/default.nix index 550ed4212b..049ad1c049 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -7,8 +7,6 @@ , amazonka , amazonka-core , amazonka-dynamodb -, amazonka-ses -, amazonka-sqs , amqp , async , attoparsec @@ -81,7 +79,6 @@ , MonadRandom , mtl , network -, network-conduit-tls , network-uri , openapi3 , optparse-applicative @@ -115,7 +112,6 @@ , spar , split , ssl-util -, stomp-queue , streaming-commons , string-conversions , tasty @@ -165,14 +161,11 @@ mkDerivation { amazonka amazonka-core amazonka-dynamodb - amazonka-ses - amazonka-sqs amqp async auto-update base base-prelude - base16-bytestring base64-bytestring bilge bloodhound @@ -221,13 +214,11 @@ mkDerivation { memory metrics-core metrics-wai - mime mime-mail mmorph MonadRandom mtl network - network-conduit-tls openapi3 optparse-applicative polysemy @@ -236,7 +227,6 @@ mkDerivation { polysemy-time polysemy-wire-zoo prometheus-client - proto-lens random-shuffle raw-strings-qq resourcet @@ -249,7 +239,6 @@ mkDerivation { servant-swagger-ui split ssl-util - stomp-queue template template-haskell text @@ -260,7 +249,6 @@ mkDerivation { transformers types-common types-common-aws - types-common-journal unliftio unordered-containers uri-bytestring diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 5eb9c2b464..5da8731c5c 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -30,7 +30,6 @@ where import Bilge (RequestId (..)) import Brig.API.Error -import Brig.AWS qualified as AWS import Brig.App import Brig.CanonicalInterpreter (BrigCanonicalEffects, runBrigToIO) import Brig.Options (allowlistEmailDomains) @@ -54,6 +53,7 @@ import Wire.API.Allowlists qualified as Allowlists import Wire.API.Error import Wire.API.Error.Brig import Wire.API.User +import Wire.AWSSubsystem qualified as AWS import Wire.AuthenticationSubsystem.Error (zauthError) import Wire.Error @@ -100,7 +100,7 @@ brigErrorHandlers :: Logger -> ByteString -> [Catch.Handler IO (Either HttpError brigErrorHandlers logger reqId = [ Catch.Handler $ \(ex :: ZV.Failure) -> pure (Left (StdError (zauthError ex))), - Catch.Handler $ \(ex :: AWS.Error) -> + Catch.Handler $ \(ex :: AWS.AWSSubsystemError) -> case ex of AWS.SESInvalidDomain -> pure (Left (StdError (errorToWai @'InvalidEmail))) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index df7f552897..21c9d8beb3 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -44,7 +44,6 @@ import Brig.Calling.API qualified as Calling import Brig.Data.Connection qualified as Data import Brig.Data.Nonce as Nonce import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) import Brig.Effects.SFT @@ -187,7 +186,6 @@ import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Metrics (Metrics) import Wire.Sem.Now (Now) -import Wire.Sem.Paging.Cassandra import Wire.Sem.Random (Random) import Wire.SessionStore (SessionStore) import Wire.SparAPIAccess @@ -398,7 +396,6 @@ servantSitemap :: Member (Concurrency 'Unsafe) r, Member BlockListStore r, Member IndexedUserStore r, - Member (ConnectionStore InternalPaging) r, Member HashPassword r, Member (Input UserSubsystemConfig) r, Member DomainRegistrationStore r, @@ -894,16 +891,11 @@ createAccessToken method luid cid proof = do API.createAccessToken luid cid method link proof !>> certEnrollmentError upgradePersonalToTeam :: - ( Member (ConnectionStore InternalPaging) r, - Member (Embed HttpClientIO) r, - Member GalleyAPIAccess r, - Member (Input (Local ())) r, - Member Now r, - Member NotificationSubsystem r, - Member TinyLog r, + ( Member GalleyAPIAccess r, Member UserSubsystem r, Member UserStore r, - Member EmailSending r + Member EmailSending r, + Member Events r ) => Local UserId -> Public.BindingNewTeamUser -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 323a66ff4a..d58ec0d164 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -75,7 +75,6 @@ import Brig.Data.Connection (countConnections) import Brig.Data.Connection qualified as Data import Brig.Data.User import Brig.Data.User qualified as Data -import Brig.Effects.ConnectionStore import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra @@ -145,8 +144,6 @@ import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPass import Wire.PropertySubsystem as PropertySubsystem import Wire.RateLimit import Wire.Sem.Concurrency -import Wire.Sem.Now (Now) -import Wire.Sem.Paging.Cassandra import Wire.StoredUser import Wire.TeamSubsystem (TeamSubsystem) import Wire.TeamSubsystem qualified as TeamSubsystem @@ -266,13 +263,8 @@ upgradePersonalToTeam :: ( Member GalleyAPIAccess r, Member UserStore r, Member UserSubsystem r, - Member TinyLog r, - Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member Now r, - Member (ConnectionStore InternalPaging) r, - Member EmailSending r + Member EmailSending r, + Member Events r ) => Local UserId -> BindingNewTeamUser -> @@ -295,7 +287,7 @@ upgradePersonalToTeam luid bNewTeam = do liftSem $ UserStore.updateUserTeam uid tid liftSem $ User.internalUpdateSearchIndex uid - liftSem $ Intra.sendUserEvent uid Nothing (teamUpdated uid tid) + liftSem $ Events.generateUserEvent uid Nothing (teamUpdated uid tid) initAccountFeatureConfig uid -- send confirmation email diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 811e6930e2..960a54e0b8 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -84,6 +84,7 @@ module Brig.App -- * Crutches that should be removed once Brig has been completely transitioned to Polysemy wrapClient, + wrapClientSem, wrapClientE, wrapClientM, wrapHttpClient, @@ -102,14 +103,10 @@ where import Bilge qualified as RPC import Bilge.IO import Bilge.RPC (HasRequestId (..)) -import Brig.AWS qualified as AWS import Brig.Calling qualified as Calling -import Brig.DeleteQueue.Interpreter import Brig.Options (ElasticSearchOpts, Opts, Settings (..)) import Brig.Options qualified as Opt import Brig.Provider.Template -import Brig.Queue.Stomp qualified as Stomp -import Brig.Queue.Types import Brig.Schema.Run qualified as Migrations import Brig.Team.Template import Brig.Template (Localised, genTemplateBranding) @@ -147,6 +144,7 @@ import OpenSSL.EVP.Digest (Digest, getDigestByName) import OpenSSL.Session (SSLOption (..)) import OpenSSL.Session qualified as SSL import Polysemy +import Polysemy.Embed (runEmbedded) import Polysemy.Fail import Polysemy.Final import Polysemy.Input (Input, input) @@ -162,13 +160,19 @@ import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Locale (Locale) import Wire.API.Routes.Version import Wire.API.User.Identity +import Wire.AWSSubsystem.AWS qualified as AWS import Wire.AuthenticationSubsystem.Config (ZAuthEnv) import Wire.AuthenticationSubsystem.Config qualified as AuthenticationSubsystem +import Wire.ConnectionStore +import Wire.ConnectionStore.Cassandra +import Wire.DeleteQueue.Types (InternalEventsOpts (..), QueueEnv (..), QueueOpts (..)) import Wire.EmailSending.SMTP qualified as SMTP import Wire.EmailSubsystem.Template (TemplateBranding, forLocale) import Wire.RateLimit.Interpreter +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.SessionStore import Wire.SessionStore.Cassandra +import Wire.StompSubsystem.Stomp qualified as Stomp import Wire.UserKeyStore import Wire.UserKeyStore.Cassandra import Wire.UserStore @@ -258,11 +262,11 @@ newEnv opts = do eventsQueue :: QueueEnv <- case opts.internalEvents.internalEventsQueue of StompQueueOpts q -> do stomp :: Stomp.Env <- case (opts.stompOptions, opts.settings.stomp) of - (Just s, Just c) -> Stomp.mkEnv s <$> initCredentials c + (Just s, Just c) -> Stomp.mkEnv lgr s <$> initCredentials c (Just _, Nothing) -> error "STOMP is configured but 'setStomp' is not set" (Nothing, Just _) -> error "'setStomp' is present but STOMP is not configured" (Nothing, Nothing) -> error "stomp is selected for internal events, but not configured in 'setStomp', STOMP" - pure (StompQueueEnv (Stomp.broker stomp) q) + pure (StompQueueEnv stomp q) SqsQueueOpts q -> do let throttleMillis = fromMaybe Opt.defSqsThrottleMillis opts.settings.sqsThrottleMillis SqsQueueEnv aws throttleMillis <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q @@ -572,6 +576,17 @@ wrapClient m = do env <- ask runClient env.casClient $ runReaderT m env +-- | New Polysemy-based wrapper that supports ConnectionStore effect +wrapClientSem :: Sem '[ConnectionStore InternalPaging, Embed Cas.Client, Embed IO, Final IO] a -> AppT r a +wrapClientSem action = do + env <- ask + liftIO + $ runFinal + . embedToFinal @IO + . runEmbedded @Cas.Client (runClient env.casClient) + . connectionStoreToCassandra + $ action + wrapClientE :: ExceptT e (ReaderT Env Cas.Client) a -> ExceptT e (AppT r) a wrapClientE = mapExceptT wrapClient diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 6e968f75ae..e4928672b8 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -1,16 +1,11 @@ module Brig.CanonicalInterpreter where -import Brig.AWS (amazonkaEnv) import Brig.App as App -import Brig.DeleteQueue.Interpreter as DQ -import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.ConnectionStore.Cassandra (connectionStoreToCassandra) import Brig.Effects.JwtTools import Brig.Effects.PublicKeyBundle import Brig.Effects.SFT (SFT, interpretSFT) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) -import Brig.IO.Intra (runEvents) import Brig.Options (federationDomainConfigs, federationStrategy) import Brig.Options qualified as Opt import Brig.Team.Template (TeamTemplates) @@ -36,6 +31,8 @@ import Polysemy.TinyLog (TinyLog) import Wire.API.Federation.Client qualified import Wire.API.Federation.Error import Wire.API.Team.Collaborator +import Wire.AWSSubsystem (AWSSubsystem) +import Wire.AWSSubsystem.AWS (amazonkaEnv, runAWSSubsystem) import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) import Wire.AppStore @@ -47,14 +44,16 @@ import Wire.AuthenticationSubsystem.Config import Wire.AuthenticationSubsystem.Interpreter import Wire.BlockListStore import Wire.BlockListStore.Cassandra +import Wire.ConnectionStore (ConnectionStore) +import Wire.ConnectionStore.Cassandra (connectionStoreToCassandra) import Wire.DeleteQueue +import Wire.DeleteQueue.Interpreter (runDeleteQueue) import Wire.DomainRegistrationStore import Wire.DomainRegistrationStore.Cassandra import Wire.DomainVerificationChallengeStore import Wire.DomainVerificationChallengeStore.Cassandra import Wire.EmailSending -import Wire.EmailSending.SES -import Wire.EmailSending.SMTP +import Wire.EmailSending.Core (EmailSendingInterpreterConfig (EmailSendingInterpreterConfig), emailSendingInterpreter) import Wire.EmailSubsystem import Wire.EmailSubsystem.Interpreter import Wire.EnterpriseLoginSubsystem @@ -63,6 +62,7 @@ import Wire.EnterpriseLoginSubsystem.Interpreter import Wire.EnterpriseLoginSubsystem.Null import Wire.Error import Wire.Events +import Wire.Events.Interpreter (runEvents) import Wire.FederationAPIAccess qualified import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..), interpretFederationAPIAccess) import Wire.FederationConfigStore (FederationConfigStore) @@ -152,6 +152,7 @@ type BrigLowerLevelEffects = PropertySubsystem, DeleteQueue, Wire.Events.Events, + AWSSubsystem, NotificationSubsystem, RateLimit, UserGroupStore, @@ -311,7 +312,7 @@ runBrigToIO e (AppT ma) = do . interpretClientToIO e.casClient . runMetricsToIO . runRpcWithHttp e.httpManager e.requestId - . emailSendingInterpreter e + . emailSendingInterpreter (EmailSendingInterpreterConfig e.smtpEnv (e.awsEnv ^. amazonkaEnv) e.appLogger) . interpretSparAPIAccessToRpc e.sparEndpoint . interpretGalleyAPIAccessToRpc e.disabledVersions e.galleyEndpoint . passwordResetCodeStoreToCassandra @Cas.Client @@ -364,6 +365,7 @@ runBrigToIO e (AppT ma) = do . interpretUserGroupStoreToPostgres . interpretRateLimit e.rateLimitEnv . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) + . runAWSSubsystem e.awsEnv . runEvents . runDeleteQueue e.internalEvents . interpretPropertySubsystem propertySubsystemConfig @@ -411,9 +413,3 @@ rethrowHttpErrorIO act = do case eithError of Left err -> embedToFinal $ throwM $ err Right a -> pure a - -emailSendingInterpreter :: (Member (Embed IO) r) => Env -> InterpreterFor EmailSending r -emailSendingInterpreter e = do - case e.smtpEnv of - Just smtp -> emailViaSMTPInterpreter e.appLogger smtp - Nothing -> emailViaSESInterpreter (e.awsEnv ^. amazonkaEnv) diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index ce9640f974..8a2dc3d6de 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -53,7 +53,6 @@ import Amazonka.Data.Text qualified as AWS import Amazonka.DynamoDB qualified as AWS import Amazonka.DynamoDB.Lens qualified as AWS import Bilge.Retry (httpHandlers) -import Brig.AWS import Brig.App import Brig.Types.Instances () import Cassandra as C hiding (Client) @@ -77,7 +76,7 @@ import Data.Text qualified as Text import Data.Time.Clock import Data.UUID qualified as UUID import Imports -import Polysemy (Member) +import Polysemy (Member, runFinal) import Prometheus qualified as Prom import System.CryptoBox (Result (Success)) import System.CryptoBox qualified as CryptoBox @@ -89,6 +88,8 @@ import Wire.API.User.Auth import Wire.API.User.Client hiding (UpdateClient (..)) import Wire.API.User.Client.Prekey import Wire.API.UserMap (UserMap (..)) +import Wire.AWSSubsystem +import Wire.AWSSubsystem.AWS qualified as AWSI import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.AuthenticationSubsystem qualified as Authentication import Wire.AuthenticationSubsystem.Error @@ -245,8 +246,7 @@ lookupPrekeyIds u c = rmClient :: ( MonadClient m, - MonadReader Brig.App.Env m, - MonadCatch m + MonadReader Brig.App.Env m ) => UserId -> ClientId -> @@ -482,16 +482,15 @@ key u c = HashMap.singleton ddbClient (ddbKey u c) deleteOptLock :: ( MonadReader Brig.App.Env m, - MonadCatch m, MonadIO m ) => UserId -> ClientId -> m () deleteOptLock u c = do - t <- asks ((.awsEnv) <&> view prekeyTable) - e <- asks ((.awsEnv) <&> view amazonkaEnv) - void $ exec e (AWS.newDeleteItem t & AWS.deleteItem_key .~ key u c) + t <- asks ((.awsEnv) <&> view AWSI.prekeyTable) + e <- asks (.awsEnv) + void $ liftIO $ runFinal $ AWSI.runAWSSubsystem e $ runAwsRequest (AWS.newDeleteItem t & AWS.deleteItem_key .~ key u c) withOptLock :: forall a m. @@ -560,20 +559,20 @@ withOptLock u c ma = go (10 :: Int) (Text -> r) -> m (Maybe x) execDyn cnv mkCmd = do - cmd <- mkCmd <$> asks ((.awsEnv) <&> view prekeyTable) - e <- asks ((.awsEnv) <&> view amazonkaEnv) + cmd <- mkCmd <$> asks ((.awsEnv) <&> view AWSI.prekeyTable) + e <- asks (.awsEnv) liftIO $ execDyn' e cnv cmd where execDyn' :: forall y p. (AWS.AWSRequest p, Typeable (AWS.AWSResponse p), Typeable p) => - AWS.Env -> + AWSI.Env -> (AWS.AWSResponse p -> Maybe y) -> p -> IO (Maybe y) execDyn' e conv cmd = recovering policy handlers (const run) where - run = execCatch e cmd >>= either handleErr (pure . conv) + run = runFinal (AWSI.runAWSSubsystem e (runAwsRequest cmd)) >>= either handleErr (pure . conv) handlers = httpHandlers ++ [const $ EL.handler_ AWS._ConditionalCheckFailedException (pure True)] policy = limitRetries 3 <> exponentialBackoff 100000 handleErr (AWS.ServiceError se) | se ^. AWS.serviceError_code == AWS.ErrorCode "ProvisionedThroughputExceeded" = do diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 7c95f7cd6c..e3d6dc26ca 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -19,15 +19,11 @@ -- FUTUREWORK: Move to Brig.User.RPC or similar. module Brig.IO.Intra - ( -- * Pushing & Journaling Events - sendUserEvent, + ( -- * Events onConnectionEvent, onPropertyEvent, onClientEvent, - -- * user subsystem interpretation for user events - runEvents, - -- * Conversations createConnectConv, acceptConnectConv, @@ -53,16 +49,10 @@ import Bilge.RPC import Brig.API.Error (internalServerError) import Brig.API.Types import Brig.App -import Brig.Data.Connection -import Brig.Data.Connection qualified as Data -import Brig.Effects.ConnectionStore (ConnectionStore) -import Brig.Effects.ConnectionStore qualified as E -import Brig.Federation.Client (notifyUserDeleted, sendConnectionAction) -import Brig.IO.Journal qualified as Journal import Brig.IO.Logging import Brig.RPC -import Control.Error (ExceptT, runExceptT) -import Control.Lens (view, (?~), (^.), (^?)) +import Control.Error (ExceptT) +import Control.Lens ((^?)) import Control.Monad.Catch import Control.Monad.Trans.Except (throwE) import Data.Aeson @@ -73,72 +63,32 @@ import Data.Default import Data.Id import Data.Json.Util import Data.List.NonEmpty (NonEmpty (..)) -import Data.Proxy import Data.Qualified -import Data.Range import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Polysemy -import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import System.Logger.Message hiding ((.=)) import Wire.API.Connection import Wire.API.Conversation hiding (Member) import Wire.API.Event.Conversation (Connect (Connect)) -import Wire.API.Federation.API.Brig import Wire.API.Federation.Error -import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll)) import Wire.API.Push.V2 qualified as V2 import Wire.API.Routes.Internal.Galley.ConversationsIntra import Wire.API.Routes.Internal.Galley.TeamsIntra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) import Wire.API.Team.LegalHold (LegalholdProtectee) -import Wire.API.Team.Member qualified as Team import Wire.API.User import Wire.API.User.Client import Wire.API.UserEvent -import Wire.Events +import Wire.Events.Interpreter (notify, toApsData) import Wire.NotificationSubsystem import Wire.Rpc import Wire.Sem.Logger qualified as Log -import Wire.Sem.Now (Now) -import Wire.Sem.Now qualified as Now -import Wire.Sem.Paging qualified as P -import Wire.Sem.Paging.Cassandra (InternalPaging) ----------------------------------------------------------------------------- -- Event Handlers -sendUserEvent :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member Now r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - Maybe ConnId -> - UserEvent -> - Sem r () -sendUserEvent orig conn e = - dispatchNotifications orig conn e - *> embed (journalEvent orig e) - -runEvents :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member Now r, - Member (ConnectionStore InternalPaging) r - ) => - InterpreterFor Events r -runEvents = interpret \case - -- FUTUREWORK(mangoiv): should this be in another module? - GenerateUserEvent uid mconnid event -> sendUserEvent uid mconnid event - GeneratePropertyEvent uid connid event -> onPropertyEvent uid connid event - onConnectionEvent :: (Member NotificationSubsystem r) => -- | Originator of the event. @@ -195,246 +145,6 @@ onClientEvent orig conn e = do } ] -journalEvent :: (MonadReader Env m, MonadIO m) => UserId -> UserEvent -> m () -journalEvent orig e = case e of - UserActivated acc -> - Journal.userActivate acc - UserUpdated UserUpdatedData {eupName = Just name} -> - Journal.userUpdate orig Nothing Nothing (Just name) - UserUpdated UserUpdatedData {eupLocale = Just loc} -> - Journal.userUpdate orig Nothing (Just loc) Nothing - UserIdentityUpdated (UserIdentityUpdatedData _ (Just em) _) -> - Journal.userUpdate orig (Just em) Nothing Nothing - UserIdentityRemoved (UserIdentityRemovedData _ (Just em) _) -> - Journal.userEmailRemove orig em - UserDeleted {} -> - Journal.userDelete orig - _ -> - pure () - -------------------------------------------------------------------------------- --- Low-Level Event Notification - --- | 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 :: - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r, - Member (Input (Local ())) r, - Member Now r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - Maybe ConnId -> - UserEvent -> - Sem r () -dispatchNotifications orig conn e = case e of - UserCreated {} -> pure () - UserSuspended {} -> pure () - UserResumed {} -> pure () - LegalHoldClientRequested {} -> notifyContacts event orig V2.RouteAny conn - UserLegalHoldDisabled {} -> notifyContacts event orig V2.RouteAny conn - UserLegalHoldEnabled {} -> notifyContacts event orig V2.RouteAny conn - UserUpdated UserUpdatedData {..} - -- This relies on the fact that we never change the locale AND something else. - | isJust eupLocale -> notifySelf event orig V2.RouteDirect conn - | otherwise -> notifyContacts event orig V2.RouteDirect conn - UserActivated {} -> notifySelf event orig V2.RouteAny conn - UserIdentityUpdated {} -> notifySelf event orig V2.RouteDirect conn - UserIdentityRemoved {} -> notifySelf event orig V2.RouteDirect conn - UserDeleted {} -> do - -- n.b. Synchronously fetch the contact list on the current thread. - -- If done asynchronously, the connections may already have been deleted. - notifyUserDeletionLocals orig conn event - notifyUserDeletionRemotes orig - where - event = UserEvent e - -notifyUserDeletionLocals :: - forall r. - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member (Input (Local ())) r, - Member Now r - ) => - UserId -> - Maybe ConnId -> - Event -> - Sem r () -notifyUserDeletionLocals deleted conn event = do - luid <- qualifyLocal' deleted - -- first we send a notification to the deleted user's devices - notify event deleted V2.RouteDirect conn (pure (deleted :| [])) - -- then to all their connections - connectionPages Nothing luid (toRange (Proxy @500)) - where - handler :: [UserConnection] -> Sem r () - handler connections = do - -- sent event to connections that are accepted - case qUnqualified . ucTo <$> filter ((==) Accepted . ucStatus) connections of - x : xs -> notify event deleted V2.RouteDirect conn (pure (x :| xs)) - [] -> pure () - -- also send a connection cancelled event to connections that are pending - d <- tDomain <$> input - forM_ - (filter ((==) Sent . ucStatus) connections) - ( \uc -> do - now <- toUTCTimeMillis <$> Now.get - -- because the connections are going to be removed from the database anyway when a user gets deleted - -- we don't need to save the updated connection state in the database - -- note that we switch from and to users so that the "other" user becomes the recipient of the event - let ucCancelled = - UserConnection - (qUnqualified (ucTo uc)) - (Qualified (ucFrom uc) d) - Cancelled - now - (ucConvId uc) - let e = ConnectionUpdated ucCancelled Nothing - onConnectionEvent deleted conn e - ) - - connectionPages :: Maybe UserId -> Local UserId -> Range 1 500 Int32 -> Sem r () - connectionPages mbStart user pageSize = do - page <- embed $ Data.lookupLocalConnections user mbStart pageSize - case resultList page of - [] -> pure () - xs -> do - handler xs - when (Data.resultHasMore page) $ - connectionPages (Just (maximum (qUnqualified . ucTo <$> xs))) user pageSize - -notifyUserDeletionRemotes :: - forall r. - ( Member (Embed HttpClientIO) r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (ConnectionStore InternalPaging) r - ) => - UserId -> - Sem r () -notifyUserDeletionRemotes deleted = do - luid <- qualifyLocal' deleted - P.withChunks (\mps -> E.remoteConnectedUsersPaginated luid mps maxBound) fanoutNotifications - where - fanoutNotifications :: [Remote UserConnection] -> Sem r () - fanoutNotifications = mapM_ notifyBackend . bucketRemote - - notifyBackend :: Remote [UserConnection] -> Sem r () - notifyBackend ucs = do - case tUnqualified (checked <$> ucs) of - Nothing -> - -- The user IDs cannot be more than 1000, so we can assume the range - -- check will only fail because there are 0 User Ids. - pure () - Just rangedUcs -> do - luidDeleted <- qualifyLocal' deleted - embed $ notifyUserDeleted luidDeleted (qualifyAs ucs (mapRange (qUnqualified . ucTo) rangedUcs)) - -- also sent connection cancelled events to the connections that are pending - let remotePendingConnections = qualifyAs ucs <$> filter ((==) Sent . ucStatus) (fromRange rangedUcs) - forM_ remotePendingConnections $ sendCancelledEvent luidDeleted - - sendCancelledEvent :: Local UserId -> Remote UserConnection -> Sem r () - sendCancelledEvent luidDeleted ruc = do - embed (runExceptT (sendConnectionAction luidDeleted Nothing (qUnqualified . ucTo <$> ruc) RemoteRescind)) >>= \case - -- should we abort the whole process if we fail to send the event to a remote backend? - Left e -> - Log.err $ - field "error" (show e) - . msg (val "An error occurred while sending a connection cancelled event to a remote backend.") - Right _ -> pure () - --- | (Asynchronously) notifies other users of events. -notify :: - (Member NotificationSubsystem r) => - Event -> - -- | Origin user, TODO: Delete - UserId -> - -- | Push routing strategy. - V2.Route -> - -- | Origin device connection, if any. - Maybe ConnId -> - -- | Users to notify. - Sem r (NonEmpty UserId) -> - Sem r () -notify event orig route conn recipients = do - rs <- (\u -> Recipient u RecipientClientsAll) <$$> recipients - let push = - def - { origin = Just orig, - json = toJSONObject event, - recipients = toList rs, - conn, - route, - apsData = toApsData event - } - void $ pushNotificationAsync push - -notifySelf :: - (Member NotificationSubsystem r) => - Event -> - -- | Origin user. - UserId -> - -- | Push routing strategy. - V2.Route -> - -- | Origin device connection, if any. - Maybe ConnId -> - Sem r () -notifySelf event orig route conn = - notify event orig route conn (pure (orig :| [])) - -notifyContacts :: - forall r. - ( Member (Embed HttpClientIO) r, - Member NotificationSubsystem r, - Member TinyLog r - ) => - Event -> - -- | Origin user. - UserId -> - -- | Push routing strategy. - V2.Route -> - -- | Origin device connection, if any. - Maybe ConnId -> - Sem r () -notifyContacts event orig route conn = do - notify event orig route conn $ - (:|) orig <$> liftA2 (++) contacts teamContacts - where - contacts :: Sem r [UserId] - contacts = embed $ lookupContactList orig - - teamContacts :: Sem 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 -> [UserId] - screenMemberList (Just mems) - | mems ^. Team.teamMemberListType == Team.ListComplete = - view Team.userId <$> mems ^. Team.teamMembers - screenMemberList _ = [] - -toApsData :: Event -> Maybe V2.ApsData -toApsData (ConnectionEvent (ConnectionUpdated uc name)) = - case (ucStatus uc, name) of - (MissingLegalholdConsent, _) -> Nothing - (Pending, n) -> apsConnRequest <$> n - (Accepted, n) -> apsConnAccept <$> n - (Blocked, _) -> Nothing - (Ignored, _) -> Nothing - (Sent, _) -> Nothing - (Cancelled, _) -> Nothing - where - apsConnRequest n = - V2.apsData (V2.ApsLocKey "push.notification.connection.request") [fromName n] - & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" - apsConnAccept n = - V2.apsData (V2.ApsLocKey "push.notification.connection.accepted") [fromName n] - & V2.apsSound ?~ V2.ApsSound "new_message_apns.caf" -toApsData _ = Nothing - ------------------------------------------------------------------------------- -- Conversation Management @@ -628,26 +338,6 @@ rmClient u c = do ------------------------------------------------------------------------------- -- Team Management --- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. --- --- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: - ( Member TinyLog r, - Member (Embed HttpClientIO) r - ) => - UserId -> - Sem r (Maybe Team.TeamMemberList) -getTeamContacts u = do - Log.debug $ remote "galley" . msg (val "Get team contacts") - rs <- embed $ galleyRequest GET req - embed $ case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["i", "users", toByteString' u, "team", "members"] - . expect [status200, status404] - guardLegalhold :: LegalholdProtectee -> UserClients -> diff --git a/services/brig/src/Brig/IO/Journal.hs b/services/brig/src/Brig/IO/Journal.hs deleted file mode 100644 index 9bc16347c8..0000000000 --- a/services/brig/src/Brig/IO/Journal.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Brig.IO.Journal - ( userActivate, - userUpdate, - userDelete, - userEmailRemove, - ) -where - -import Brig.AWS qualified as AWS -import Brig.App -import Control.Lens -import Data.ByteString.Base64 qualified as B64 -import Data.ByteString.Char8 (pack) -import Data.ByteString.Conversion -import Data.ByteString.Lazy (fromStrict) -import Data.Id -import Data.Proto -import Data.Proto.Id -import Data.ProtoLens (defMessage) -import Data.ProtoLens.Encoding (encodeMessage) -import Data.UUID.V4 (nextRandom) -import Imports -import Proto.UserEvents (UserEvent, UserEvent'EventType (..)) -import Proto.UserEvents_Fields qualified as U -import Wire.API.User - --- Note [journaling] --- ~~~~~~~~~~~~~~~~~ --- User journal operations to SQS are a no-op when the service is started --- without journaling arguments for user updates - -userActivate :: (MonadReader Env m, MonadIO m) => User -> m () -userActivate u@User {..} = journalEvent UserEvent'USER_ACTIVATE (userId u) (userEmail u) (Just userLocale) userTeam (Just userDisplayName) - -userUpdate :: (MonadReader Env m, MonadIO m) => UserId -> Maybe EmailAddress -> Maybe Locale -> Maybe Name -> m () -userUpdate uid em loc = journalEvent UserEvent'USER_UPDATE uid em loc Nothing - -userEmailRemove :: (MonadReader Env m, MonadIO m) => UserId -> EmailAddress -> m () -userEmailRemove uid em = journalEvent UserEvent'USER_EMAIL_REMOVE uid (Just em) Nothing Nothing Nothing - -userDelete :: (MonadReader Env m, MonadIO m) => UserId -> m () -userDelete uid = journalEvent UserEvent'USER_DELETE uid Nothing Nothing Nothing Nothing - -journalEvent :: (MonadReader Env m, MonadIO m) => UserEvent'EventType -> UserId -> Maybe EmailAddress -> Maybe Locale -> Maybe TeamId -> Maybe Name -> m () -journalEvent typ uid em loc tid nm = - -- this may be the only place that uses awsEnv from brig Env. refactor it to use the - -- DeleteQueue effect instead? - asks (.awsEnv) >>= \env -> for_ (view AWS.userJournalQueue env) $ \queue -> do - ts <- now - rnd <- liftIO nextRandom - let userEvent :: UserEvent = - defMessage - & U.eventType .~ typ - & U.userId .~ toBytes uid - & U.utcTime .~ ts - & U.maybe'email .~ (toByteString' <$> em) - & U.maybe'locale .~ (pack . show <$> loc) - & U.maybe'teamId .~ (toBytes <$> tid) - & U.maybe'name .~ (toByteString' <$> nm) -- [] - encoded = fromStrict $ B64.encode $ encodeMessage userEvent - AWS.execute env (AWS.enqueueFIFO queue "user.events" rnd encoded) diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 6c717705ba..3987836a80 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -24,7 +24,6 @@ module Brig.Options where -import Brig.Queue.Types (QueueOpts (..)) import Control.Applicative import Control.Lens hiding (Level, element, enum) import Data.Aeson @@ -55,10 +54,13 @@ import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version import Wire.API.Team.Feature import Wire.API.User +import Wire.AWSSubsystem.AWS qualified as AWS import Wire.AuthenticationSubsystem.Config (ZAuthSettings) import Wire.AuthenticationSubsystem.Cookie.Limit +import Wire.DeleteQueue.Types (InternalEventsOpts (..)) import Wire.EmailSending.SMTP (SMTPConnType (..)) import Wire.RateLimit.Interpreter +import Wire.StompSubsystem.Stomp (StompOpts (..)) data ElasticSearchOpts = ElasticSearchOpts { -- | ElasticSearch URL @@ -92,32 +94,6 @@ data ElasticSearchOpts = ElasticSearchOpts instance FromJSON ElasticSearchOpts -data AWSOpts = AWSOpts - { -- | Event journal queue for user events - -- (e.g. user deletion) - userJournalQueue :: !(Maybe Text), - -- | Dynamo table for storing prekey data - prekeyTable :: !Text, - -- | AWS SQS endpoint - sqsEndpoint :: !AWSEndpoint, - -- | DynamoDB endpoint - dynamoDBEndpoint :: !(Maybe AWSEndpoint) - } - deriving (Show, Generic) - -instance FromJSON AWSOpts - -data EmailAWSOpts = EmailAWSOpts - { -- | Event feedback queue for SES - -- (e.g. for email bounces and complaints) - sesQueue :: !Text, - -- | AWS SES endpoint - sesEndpoint :: !AWSEndpoint - } - deriving (Show, Generic) - -instance FromJSON EmailAWSOpts - data EmailSMTPCredentials = EmailSMTPCredentials { -- | Username to authenticate -- against the SMTP server @@ -142,22 +118,6 @@ data EmailSMTPOpts = EmailSMTPOpts instance FromJSON EmailSMTPOpts -data StompOpts = StompOpts - { host :: !Text, - port :: !Int, - tls :: !Bool - } - deriving (Show, Generic) - -data InternalEventsOpts = InternalEventsOpts - { internalEventsQueue :: !QueueOpts - } - deriving (Show) - -instance FromJSON InternalEventsOpts where - parseJSON = withObject "InternalEventsOpts" $ \o -> - InternalEventsOpts <$> parseJSON (Object o) - data EmailSMSGeneralOpts = EmailSMSGeneralOpts { -- | Email, SMS, ... template directory templateDir :: !FilePath, @@ -239,7 +199,7 @@ data TeamOpts = TeamOpts instance FromJSON TeamOpts data EmailOpts - = EmailAWS EmailAWSOpts + = EmailAWS AWS.EmailAWSOpts | EmailSMTP EmailSMTPOpts deriving (Show, Generic) @@ -402,7 +362,7 @@ data Opts = Opts -- | RabbitMQ settings, required when federation is enabled. rabbitmq :: !(Maybe AmqpEndpoint), -- | AWS settings - aws :: !AWSOpts, + aws :: !AWS.AWSOpts, -- | Enable Random Prekey Strategy randomPrekeys :: !(Maybe Bool), -- | STOMP broker settings @@ -846,14 +806,6 @@ instance FromJSON Opts where other -> other } -instance FromJSON StompOpts where - parseJSON = genericParseJSON customOptions - where - customOptions = - defaultOptions - { fieldLabelModifier = \a -> "stom" <> capitalise a - } - makeLensesWith (lensRules & lensField .~ suffixNamer) ''Opts makeLensesWith (lensRules & lensField .~ suffixNamer) ''Settings diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 77db6d20f2..de03f1f89d 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -23,7 +23,6 @@ import Brig.API.Handler import Brig.API.Internal qualified as IAPI import Brig.API.Public import Brig.API.User qualified as API -import Brig.AWS qualified as AWS import Brig.AWS.SesNotification qualified as SesNotification import Brig.App import Brig.Calling qualified as Calling @@ -31,9 +30,9 @@ import Brig.CanonicalInterpreter import Brig.Effects.UserPendingActivationStore (UserPendingActivation (UserPendingActivation), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UsersPendingActivationStore import Brig.InternalEvent.Process qualified as Internal -import Brig.Options hiding (internalEvents, sesQueue) -import Brig.Queue qualified as Queue +import Brig.Options hiding (internalEvents) import Brig.Version +import Wire.DeleteQueue.Listen qualified as Queue import Control.Concurrent.Async qualified as Async import Control.Exception.Safe (catchAny) import Control.Lens ((.~)) @@ -56,7 +55,7 @@ import Network.Wai.Utilities.Server import Network.Wai.Utilities.Server qualified as Server import OpenTelemetry.Instrumentation.Wai qualified as Otel import OpenTelemetry.Trace as Otel -import Polysemy (Member) +import Polysemy (Member, embedFinal, runFinal) import Servant (Context ((:.)), (:<|>) (..)) import Servant qualified import System.Logger (flush, msg, val, (.=), (~~)) @@ -69,6 +68,8 @@ import Wire.API.Routes.Public.Brig import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) +import Wire.AWSSubsystem qualified as AWS +import Wire.AWSSubsystem.AWS qualified as AWSI import Wire.DeleteQueue import Wire.OpenTelemetry (withTracer) import Wire.PostgresMigrations @@ -93,8 +94,9 @@ run opts = withTracer \tracer -> do let throttleMillis = fromMaybe defSqsThrottleMillis opts.settings.sqsThrottleMillis emailListener <- for e.awsEnv._sesQueue $ \q -> Async.async $ - AWS.execute e.awsEnv $ - AWS.listen throttleMillis q (runBrigToIO e . SesNotification.onEvent) + runFinal $ + AWSI.runAWSSubsystem e.awsEnv $ + AWS.listen throttleMillis q (embedFinal . runBrigToIO e . SesNotification.onEvent) sftDiscovery <- forM e.sftEnv $ Async.async . Calling.startSFTServiceDiscovery e.appLogger turnDiscovery <- Calling.startTurnDiscovery e.appLogger e.fsWatcher e.turnEnv authMetrics <- Async.async (runBrigToIO e collectAuthMetrics) diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index 7c88c057ab..cdaaec4cdf 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -29,7 +29,6 @@ import API.User.Handles qualified import API.User.RichInfo qualified import API.User.Util import Bilge hiding (accept, timeout) -import Brig.AWS qualified as AWS import Brig.App (initZAuth) import Brig.Options qualified as Opt import Cassandra qualified as DB @@ -39,6 +38,7 @@ import Test.Tasty hiding (Timeout) import Util import Util.AWS (UserJournalWatcher) import Wire.API.Federation.Component +import Wire.AWSSubsystem.AWS qualified as AWS import Wire.AuthenticationSubsystem.Config tests :: diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 4bde9dcd18..e95f385595 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -27,7 +27,6 @@ import API.Team.Util import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert -import Brig.AWS qualified as AWS import Brig.AWS.Types import Brig.Options qualified as Opt import Brig.Types.Activation @@ -70,6 +69,7 @@ import Network.HTTP.Types qualified as Http import Network.Wai qualified as Wai import Network.Wai.Utilities.Error qualified as Error import Network.Wai.Utilities.Error qualified as Wai +import Polysemy (runFinal) import Test.QuickCheck (arbitrary, generate) import Test.Tasty hiding (Timeout) import Test.Tasty.Cannon hiding (Cannon, Timeout) @@ -93,8 +93,10 @@ import Wire.API.User.Activation import Wire.API.User.Auth import Wire.API.User.Auth qualified as Auth import Wire.API.User.Client +import Wire.AWSSubsystem qualified as AWS +import Wire.AWSSubsystem.AWS qualified as AWSI -tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWSI.Env -> UserJournalWatcher -> TestTree tests _ at opts p b c ch g aws userJournalWatcher = testGroup "account" @@ -471,7 +473,7 @@ testCreateUserInvalidEmail _ brig = do -- @END -testCreateUserBlacklist :: Opt.Opts -> Brig -> AWS.Env -> Http () +testCreateUserBlacklist :: Opt.Opts -> Brig -> AWSI.Env -> Http () testCreateUserBlacklist (Opt.restrictUserCreation . Opt.settings -> Just True) _ _ = pure () testCreateUserBlacklist _ brig aws = mapM_ ensureBlacklist ["bounce", "complaint"] @@ -511,7 +513,7 @@ testCreateUserBlacklist _ brig aws = ] -- If there is no queue available, we need to force it either by publishing an event or using the API forceBlacklist :: Text -> EmailAddress -> Http () - forceBlacklist typ em = case aws ^. AWS.sesQueue of + forceBlacklist typ em = case aws ^. AWSI.sesQueue of Just queue -> publishMessage typ em queue Nothing -> Bilge.post (brig . path "i/users/blacklist" . queryItem "email" (toByteString' em)) !!! const 200 === statusCode publishMessage :: Text -> EmailAddress -> Text -> Http () @@ -520,7 +522,7 @@ testCreateUserBlacklist _ brig aws = "bounce" -> MailBounce BouncePermanent [Mailbox Nothing em] "complaint" -> MailComplaint [Mailbox Nothing em] x -> error ("Unsupported message type: " ++ show x) - void . AWS.execute aws $ AWS.enqueueStandard queue bdy + void . liftIO . runFinal . AWSI.runAWSSubsystem aws $ AWS.enqueueStandard queue bdy awaitBlacklist :: Int -> EmailAddress -> Http () awaitBlacklist n e = do r <- Bilge.head (brig . path "i/users/blacklist" . queryItem "email" (toByteString' e)) diff --git a/services/brig/test/integration/Run.hs b/services/brig/test/integration/Run.hs index dbbbafff99..442fc0420f 100644 --- a/services/brig/test/integration/Run.hs +++ b/services/brig/test/integration/Run.hs @@ -35,7 +35,6 @@ import API.User qualified as User import API.UserPendingActivation qualified as UserPendingActivation import Bilge hiding (header, host, port) import Bilge qualified -import Brig.AWS qualified as AWS import Brig.App (initHttpManagerWithTLSConfig) import Brig.Options qualified as Opts import Cassandra.Util (defInitCassandra) @@ -66,6 +65,7 @@ import Util.Test.SQS qualified as SQS import Web.HttpApiData import Wire.API.Federation.API import Wire.API.Routes.Version +import Wire.AWSSubsystem.AWS qualified as AWS data BackendConf = BackendConf { remoteBrig :: Endpoint, @@ -130,14 +130,14 @@ runTests iConf brigOpts otherArgs = do Opts.TurnSourceFiles files -> files Opts.TurnSourceDNS _ -> error "The integration tests can only be run when TurnServers are sourced from files" localDomain = brigOpts.settings.federationDomain - awsOpts = Opts.aws brigOpts + awsOpts = brigOpts.aws lg <- Logger.new Logger.defSettings -- TODO: use mkLogger'? db <- defInitCassandra (brigOpts.cassandra) lg mg <- initHttpManagerWithTLSConfig False Nothing let fedBrigClient = FedClient @'Brig mg (brig iConf) emailAWSOpts <- parseEmailAWSOpts awsEnv <- AWS.mkEnv lg awsOpts emailAWSOpts mg - mUserJournalWatcher <- for (Opts.userJournalQueue awsOpts) $ SQS.watchSQSQueue (view AWS.amazonkaEnv awsEnv) + mUserJournalWatcher <- for awsOpts.userJournalQueue $ SQS.watchSQSQueue (view AWS.amazonkaEnv awsEnv) userApi <- User.tests brigOpts fedBrigClient mg b c ch g n awsEnv db mUserJournalWatcher providerApi <- Provider.tests localDomain brigOpts (provider iConf) mg db b c g n searchApis <- Search.tests brigOpts iConf.additionalElasticSearch mg g b @@ -196,7 +196,7 @@ runTests iConf brigOpts otherArgs = do latestVersion :: Version latestVersion = maxBound - parseEmailAWSOpts :: IO (Maybe Opts.EmailAWSOpts) + parseEmailAWSOpts :: IO (Maybe AWS.EmailAWSOpts) parseEmailAWSOpts = case Opts.email . Opts.emailSMS $ brigOpts of (Opts.EmailAWS aws) -> pure (Just aws) (Opts.EmailSMTP _) -> pure Nothing diff --git a/services/brig/test/integration/Util/AWS.hs b/services/brig/test/integration/Util/AWS.hs index 458bd82d0c..599cbc7f56 100644 --- a/services/brig/test/integration/Util/AWS.hs +++ b/services/brig/test/integration/Util/AWS.hs @@ -17,7 +17,6 @@ module Util.AWS where -import Brig.AWS qualified as AWS import Control.Lens import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as Lazy @@ -31,6 +30,7 @@ import Proto.UserEvents_Fields qualified as PU import Test.Tasty.HUnit import Util.Test.SQS qualified as SQS import Wire.API.User +import Wire.AWSSubsystem.AWS qualified as AWS type UserJournalWatcher = Maybe (SQS.SQSWatcher PU.UserEvent) diff --git a/services/brig/test/unit/Test/Brig/InternalNotification.hs b/services/brig/test/unit/Test/Brig/InternalNotification.hs index fed7ff008f..a7c80fb465 100644 --- a/services/brig/test/unit/Test/Brig/InternalNotification.hs +++ b/services/brig/test/unit/Test/Brig/InternalNotification.hs @@ -34,7 +34,7 @@ tests = checkGolden :: IO () checkGolden = do -- This file was generated from ToJSON of the format prior to 67993ab1 - ns <- BSL.readFile "test/resources/internal-notification.json" + ns <- BSL.readFile "../../../../libs/wire-subsystems/test/resources/internal-notification.json" let eith = A.eitherDecode @InternalNotification ns case eith of Left err -> assertFailure ("Could not parse InternalNotification: " <> show err) diff --git a/services/spar/default.nix b/services/spar/default.nix index 4b4b7bf58b..ddf82c585e 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -9,6 +9,7 @@ , base , base64-bytestring , bilge +, bloodhound , brig-types , bytestring , bytestring-conversion @@ -23,6 +24,7 @@ , exceptions , extended , gitignoreSource +, hasql-pool , hscim , HsOpenSSL , hspec @@ -31,7 +33,9 @@ , hspec-wai , http-api-data , http-client +, http-client-openssl , http-types +, http2-manager , imports , iso639 , lens @@ -66,6 +70,7 @@ , tinylog , transformers , types-common +, unordered-containers , uri-bytestring , utf8-string , uuid @@ -76,6 +81,7 @@ , wai-utilities , warp , wire-api +, wire-api-federation , wire-subsystems , xml-conduit , yaml @@ -92,6 +98,7 @@ mkDerivation { base base64-bytestring bilge + bloodhound brig-types bytestring bytestring-conversion @@ -103,10 +110,16 @@ mkDerivation { crypton-x509 exceptions extended + hasql-pool hscim + HsOpenSSL hspec + http-client + http-client-openssl http-types + http2-manager imports + iso639 lens metrics-wai mtl @@ -128,6 +141,7 @@ mkDerivation { tinylog transformers types-common + unordered-containers uri-bytestring utf8-string uuid @@ -136,8 +150,10 @@ mkDerivation { wai-utilities warp wire-api + wire-api-federation wire-subsystems yaml + zauth ]; executableHaskellDepends = [ aeson diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 75ff2848f6..96a3d0d45b 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -52,6 +52,7 @@ library Spar.Schema.V9 Spar.Scim Spar.Scim.Auth + Spar.Scim.Group Spar.Scim.Types Spar.Scim.User Spar.Sem.AReqIDStore @@ -155,6 +156,7 @@ library , base , base64-bytestring , bilge + , bloodhound , brig-types , bytestring , bytestring-conversion @@ -166,10 +168,16 @@ library , crypton-x509 , exceptions , extended + , hasql-pool , hscim + , HsOpenSSL , hspec + , http-client + , http-client-openssl , http-types + , http2-manager , imports + , iso639 , lens , metrics-wai , mtl @@ -191,6 +199,7 @@ library , tinylog , transformers , types-common + , unordered-containers , uri-bytestring , utf8-string , uuid @@ -199,8 +208,10 @@ library , wai-utilities , warp , wire-api + , wire-api-federation , wire-subsystems , yaml + , zauth default-language: Haskell2010 diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index be71411c14..7a71829fa5 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -24,6 +24,10 @@ galley: host: 127.0.0.1 port: 8085 +gundeck: + host: 127.0.0.1 + port: 8086 + cassandra: endpoint: host: 127.0.0.1 @@ -31,6 +35,19 @@ cassandra: keyspace: spar_test filterNodesByDatacentre: datacenter1 +elasticsearch: + url: https://localhost:9200 + index: directory_test_spar + credentials: test/resources/elasticsearch-credentials.yaml + caCert: test/resources/elasticsearch-ca.pem + insecureSkipVerifyTls: false + +postgresql: + host: 127.0.0.1 + port: "5432" + database: spar_test + user: postgres + # Wire/AWS specific, optional # discoUrl: "https://" @@ -44,4 +61,76 @@ maxttlAuthresp: 7200 # seconds. do not set this to 1h or less, as that is what maxScimTokens: 8 # Token limit {#RefScimToken} richInfoLimit: 5000 # should be in sync with Brig +internalEvents: + queueType: sqs + queueName: integration-brig-events-internal + +zauth: + privateKeys: test/resources/zauth/privkeys.txt + publicKeys: test/resources/zauth/pubkeys.txt + authSettings: + keyIndex: 1 + userTokenTimeout: 120 + sessionTokenTimeout: 20 + accessTokenTimeout: 30 + providerTokenTimeout: 60 + legacySessionTokenTimeout: 120 + legalHoldUserTokenTimeout: 120 + legalHoldAccessTokenTimeout: 30 + +emailSMS: + templateDir: ../../libs/wire-subsystems/templates + emailSender: backend-integration@wire.com + templateBranding: + brand: Wire + brandUrl: https://wire.com + brandLabelUrl: wire.com + brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png + brandService: Wire Service Provider + copyright: © WIRE SWISS GmbH + misuse: misuse@wire.com + legal: https://wire.com/legal/ + forgot: https://wire.com/forgot/ + support: https://support.wire.com/ + +logLevel: Warn logNetStrings: False # log using netstrings encoding (see http://cr.yp.to/proto/netstrings.txt) + +aws: + sesEndpoint: http://localhost:4579 # Amazon SES endpoint (fake-sqs/fake-ses) + sqsEndpoint: http://localhost:4568 # Amazon SQS endpoint (fake-sqs/fake-ses) + dynamoDBEndpoint: http://localhost:4567 # Amazon DynamoDB endpoint (fake-dynamodb) + prekeyTable: integration-brig-prekeys + +settings: + federationDomain: example.com + passwordHashingOptions: + algorithm: argon2id + memory: 32768 + parallelism: 4 + iterations: 3 + passwordHashingRateLimit: + burstSize: 5 + requestInterval: 1 + ipAddrLimit: + burst: 5 + inverseRate: 300000000 # 5 mins, makes it 12 reqs/hour + userLimit: + burst: 5 + inverseRate: 60000000 # 1 min, makes it 60 req/hour + internalLimit: + burst: 10 + inverseRate: 0 # No rate limiting for internal use + ipv4CidrBlock: 32 # Only block individual IP addresses + ipv6CidrBlock: 64 # Block /64 range at a time. + ipAddressExceptions: + - 127.0.0.1/8 + maxRateLimitedKeys: 100000 # Estimated memory usage: 4 MB + emailVisibility: "visible_if_on_team" + maxTeamSize: 500 + activationTimeout: 86400 # 24 hours in seconds + userCookieRenewAge: 1209600 # 2 weeks in seconds + userCookieLimit: 32 + userCookieThrottle: + stdDev: 3000 + retryAfter: 86400 diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index b7354ac743..6224146fb2 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -114,6 +114,7 @@ import Wire.API.Team.Member (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp)) import Wire.API.User import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Now (Now) @@ -149,6 +150,7 @@ api :: Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member ScimTokenStore r, + Member ScimSubsystem r, Member DefaultSsoCode r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -165,6 +167,7 @@ api :: Final IO ) r, + Member ScimSubsystem r, Member (Logger (Msg -> Msg)) r ) => Opts -> @@ -191,6 +194,7 @@ apiSSO :: Member SAML2 r, Member SamlProtocolSettings r, Member Reporter r, + Member ScimSubsystem r, Member SAMLUserStore r ) => Opts -> diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 1ef6cb6508..ef33968ed3 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -38,6 +38,7 @@ where import Bilge import qualified Cassandra as Cas +import Cassandra.Options (Endpoint) import Control.Exception (assert) import Control.Lens hiding ((.=)) import Data.Aeson as Aeson (encode, object, (.=)) @@ -49,13 +50,14 @@ import qualified Data.CaseInsensitive as CI import Data.Id import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NonEmpty +import Data.Qualified import qualified Data.Text as Text import Data.Text.Ascii (encodeBase64, toText) import qualified Data.Text.Encoding as Text -import Data.Text.Encoding.Error import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText import Data.These +import qualified Hasql.Pool as Hasql import Imports hiding (MonadReader, asks, log) import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai.Utilities.Error as Wai @@ -95,15 +97,28 @@ import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import qualified System.Logger as TinyLog import URI.ByteString as URI +import Util.Options (PasswordHashingOptions) import Web.Cookie (SetCookie, renderSetCookie) +import Wire.API.Routes.Version import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import qualified Wire.AWSSubsystem.AWS as AWSI +import Wire.AuthenticationSubsystem.Config +import Wire.DeleteQueue.Types (QueueEnv) +import Wire.EmailSending.SMTP (SMTP) +import Wire.EmailSubsystem.Template (Localised, TeamTemplates, TemplateBranding, UserTemplates) +import Wire.Error +import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig) +import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreConfig) +import Wire.RateLimit.Interpreter (RateLimitEnv) +import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Random (Random) import qualified Wire.Sem.Random as Random +import Wire.UserSubsystem.UserSubsystemConfig (UserSubsystemConfig) throwSparSem :: (Member (Error SparError) r) => SparCustomError -> Sem r a throwSparSem = throw . SAML.CustomError @@ -115,7 +130,25 @@ data Env = Env sparCtxHttpManager :: Bilge.Manager, sparCtxHttpBrig :: Bilge.Request, sparCtxHttpGalley :: Bilge.Request, - sparCtxRequestId :: RequestId + sparCtxHttpGalleyEndpoint :: Endpoint, + sparCtxHttpGundeckEndpoint :: Endpoint, + disabledVersions :: Set Version, + sparCtxRequestId :: RequestId, + sparCtxLocalUnit :: Local (), + sparCtxScimSubsystemConfig :: ScimSubsystemConfig, + sparCtxAuthenticationSubsystemConfig :: AuthenticationSubsystemConfig, + sparCtxPasswordHashingOptions :: PasswordHashingOptions, + sparCtxUserTemplates :: Localised UserTemplates, + sparCtxTeamTemplates :: Localised TeamTemplates, + sparCtxTemplateBranding :: TemplateBranding, + sparCtxRateLimit :: RateLimitEnv, + sparCtxFederationAPIAccessConfig :: FederationAPIAccessConfig, + sparCtxIndexedUserStoreConfig :: IndexedUserStoreConfig, + sparCtxUserSubsystemConfig :: UserSubsystemConfig, + sparCtxHasqlPool :: Hasql.Pool, + sparCtxSmtp :: Maybe SMTP, + sparCtxAws :: AWSI.Env, + sparCtxInternalEvents :: QueueEnv } -- | Get a user by UserRef, no matter what the team. @@ -350,19 +383,16 @@ catchVerdictErrors = (`catch` hndlr) where hndlr :: SparError -> Sem r VerdictHandlerResult hndlr err = do - waiErr <- renderSparErrorWithLogging err - pure $ case waiErr of - Right (werr :: Wai.Error) -> + serr <- renderSparErrorWithLogging err + pure $ case serr of + StdError (werr :: Wai.Error) -> VerifyHandlerError (LText.toStrict $ Wai.label werr) (LText.toStrict $ Wai.message werr) - Left (serr :: ServerError) -> + RichError (werr :: Wai.Error) _bdy _hdrs -> VerifyHandlerError - "unknown-error" - ( Text.pack (errReasonPhrase serr) - <> " " - <> (Text.decodeUtf8With lenientDecode . toStrict . errBody $ serr) - ) + (LText.toStrict $ Wai.label werr) + (LText.toStrict $ Wai.message werr) -- TODO: do we want to keep the entire RichError for logging? -- | If a user attempts to login presenting a new IdP issuer, but there is no entry in -- @"spar.user"@ for her: lookup @"old_issuers"@ from @"spar.idp"@ for the new IdP, and @@ -575,12 +605,11 @@ errorPage err mpInputs = errHeaders = [("Content-Type", "text/html")] } where - werr = either forceWai id $ renderSparError err - forceWai ServerError {..} = - Wai.mkError - (Http.Status errHTTPCode "") - (LText.pack errReasonPhrase) - (LText.decodeUtf8With lenientDecode errBody) + werr = + renderSparError err & \case + StdError e -> e + RichError e _ _ -> e + errbody :: [LText] errbody = [ "", @@ -627,8 +656,12 @@ sparToServerErrorWithLogging err = do Reporter.report Nothing (servantToWaiError errServant) pure errServant -renderSparErrorWithLogging :: (Member Reporter r) => SparError -> Sem r (Either ServerError Wai.Error) -renderSparErrorWithLogging err = do - let errPossiblyWai = renderSparError err - Reporter.report Nothing (either servantToWaiError id $ errPossiblyWai) - pure errPossiblyWai +renderSparErrorWithLogging :: (Member Reporter r) => SparError -> Sem r HttpError +renderSparErrorWithLogging (renderSparError -> err) = do + Reporter.report + Nothing + ( err & \case + StdError e -> e + RichError e _ _ -> e + ) + pure err diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 75170b8e2d..04b078b096 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -25,11 +25,20 @@ module Spar.CanonicalInterpreter where import qualified Cassandra as Cas -import Control.Monad.Except +import Control.Exception (ErrorCall (..)) +import Control.Lens ((^.)) +import Control.Monad.Except hiding (mapError) +import Data.Qualified +import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign) +import qualified Hasql.Pool as Hasql import Imports import Polysemy +import qualified Polysemy.Async as P import Polysemy.Error import Polysemy.Input (Input, runInputConst) +import Polysemy.Internal.Kind +import Polysemy.TinyLog hiding (err) +import qualified SAML2.WebSSO as SAML import Servant import Spar.App hiding (sparToServerErrorWithLogging) import Spar.Error @@ -67,47 +76,146 @@ import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSpa import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog +import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.User.Saml -import Wire.Sem.Logger (Logger) +import Wire.AWSSubsystem (AWSSubsystem) +import Wire.AWSSubsystem.AWS (runAWSSubsystem) +import qualified Wire.AWSSubsystem.AWS as AWSI +import Wire.AppStore +import Wire.AppStore.Postgres +import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem.Config +import Wire.AuthenticationSubsystem.Error +import Wire.AuthenticationSubsystem.Interpreter +import Wire.BlockListStore +import Wire.BlockListStore.Cassandra (interpretBlockListStoreToCassandra) +import Wire.ConnectionStore (ConnectionStore) +import Wire.ConnectionStore.Cassandra (connectionStoreToCassandra) +import Wire.DeleteQueue +import Wire.DeleteQueue.Interpreter (runDeleteQueue) +import Wire.DomainRegistrationStore +import Wire.DomainRegistrationStore.Cassandra (interpretDomainRegistrationStoreToCassandra) +import Wire.EmailSending (EmailSending) +import Wire.EmailSending.Core (EmailSendingInterpreterConfig (EmailSendingInterpreterConfig), emailSendingInterpreter) +import Wire.EmailSubsystem +import Wire.EmailSubsystem.Interpreter (emailSubsystemInterpreter) +import Wire.Error +import Wire.Events +import Wire.Events.Interpreter (runEvents) +import Wire.FederationAPIAccess +import Wire.FederationAPIAccess.Interpreter (interpretFederationAPIAccess) +import Wire.FederationConfigStore +import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) +import Wire.GalleyAPIAccess +import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) +import Wire.GundeckAPIAccess +import Wire.HashPassword +import Wire.HashPassword.Interpreter (runHashPassword) +import Wire.IndexedUserStore +import Wire.IndexedUserStore.ElasticSearch (interpretIndexedUserStoreES) +import Wire.InvitationStore +import Wire.InvitationStore.Cassandra (interpretInvitationStoreToCassandra) +import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Interpreter +import Wire.ParseException (ParseException, parseExceptionToHttpError) +import Wire.PasswordResetCodeStore +import Wire.PasswordResetCodeStore.Cassandra (passwordResetCodeStoreToCassandra) +import Wire.PasswordStore (PasswordStore) +import Wire.PasswordStore.Cassandra (interpretPasswordStore) +import Wire.RateLimit +import Wire.RateLimit.Interpreter (interpretRateLimit) +import Wire.Rpc (Rpc, runRpcWithHttp) +import Wire.ScimSubsystem +import Wire.ScimSubsystem.Interpreter +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) +import Wire.Sem.Delay import Wire.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) +import Wire.Sem.Metrics +import Wire.Sem.Metrics.IO (runMetricsToIO) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIO) +import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.Sem.Random (Random) import Wire.Sem.Random.IO (randomToIO) +import Wire.SessionStore +import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) +import Wire.TeamSubsystem +import Wire.TeamSubsystem.GalleyAPI +import Wire.UserGroupStore +import qualified Wire.UserGroupStore as Store +import Wire.UserGroupStore.Postgres +import Wire.UserGroupSubsystem +import Wire.UserGroupSubsystem.Interpreter +import Wire.UserKeyStore +import Wire.UserKeyStore.Cassandra (interpretUserKeyStoreCassandra) +import Wire.UserStore +import Wire.UserStore.Cassandra +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem.Error +import Wire.UserSubsystem.Interpreter type CanonicalEffs = + '[ScimSubsystem, UserGroupSubsystem, UserSubsystem, AuthenticationSubsystem] + `Append` LowerLevelCanonicalEffs + +type LowerLevelCanonicalEffs = '[ SAML2, SamlProtocolSettings, AssIDStore, AReqIDStore, VerdictFormatStore, - ScimExternalIdStore, - ScimUserTimesStore, - ScimTokenStore, - DefaultSsoCode, - IdPConfigStore, - IdPRawMetadataStore, - SAMLUserStore, - Embed Cas.Client, - BrigAccess, - GalleyAccess, - Error IdpDbError, - Error TTLError, - Error SparError, - Reporter, - -- TODO(sandy): Make this a Logger Text instead - Logger String, - Logger (TinyLog.Msg -> TinyLog.Msg), - Input Opts, - Input TinyLog.Logger, - Random, - Now, - Embed IO, - Final IO + Error UserGroupSubsystemError, + Store.UserGroupStore, + Events, + AWSSubsystem, + NotificationSubsystem, + GundeckAPIAccess, + P.Async, + Delay, + TeamSubsystem, + GalleyAPIAccess ] + `Append` AuthSubsystemLowerEffects + `Append` UserSubsystemLowerEffects + `Append` '[ Error ErrorCall, + Error ParseException, + Rpc, + Input (Local ()), + Input ScimSubsystemConfig, + Error ScimSubsystemError, + ScimExternalIdStore, + ScimUserTimesStore, + ScimTokenStore, + DefaultSsoCode, + IdPConfigStore, + IdPRawMetadataStore, + SAMLUserStore, + Embed Cas.Client, + BrigAccess, + GalleyAccess, + UserStore, + Error RateLimitExceeded, + Error IdpDbError, + Error TTLError, + Input Hasql.Pool, + Error Hasql.UsageError, + Error SparError, + Reporter, + EmailSending, + Logger String, + Logger (TinyLog.Msg -> TinyLog.Msg), + Input Opts, + Input TinyLog.Logger, + Random, + Now, + Embed IO, + Final IO + ] runSparToIO :: Env -> Sem CanonicalEffs a -> IO (Either SparError a) -runSparToIO ctx action = +runSparToIO ctx = runFinal . embedToFinal @IO . nowToIO @@ -116,10 +224,15 @@ runSparToIO ctx action = . runInputConst (sparCtxOpts ctx) . loggerToTinyLog (sparCtxLogger ctx) . stringLoggerToTinyLog + . emailSendingInterpreter (EmailSendingInterpreterConfig ctx.sparCtxSmtp (ctx.sparCtxAws ^. AWSI.amazonkaEnv) ctx.sparCtxLogger) . reporterToTinyLogWai . runError @SparError + . iHasqlUsageError + . runInputConst ctx.sparCtxHasqlPool . ttlErrorToSparError . idpDbErrorToSparError + . mapError (httpErrorToSparError . rateLimitExceededToHttpError) + . interpretUserStoreCassandra ctx.sparCtxCas . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) @@ -130,18 +243,181 @@ runSparToIO ctx action = . scimTokenStoreToCassandra . scimUserTimesStoreToCassandra . scimExternalIdStoreToCassandra + . mapScimSubsystemErrors + . runInputConst (ctx.sparCtxScimSubsystemConfig) + . runInputConst (ctx.sparCtxLocalUnit) + . runRpcWithHttp ctx.sparCtxHttpManager ctx.sparCtxRequestId + . iParseException + . iErrorCall + . interpretUserSubsystemLowerEffects ctx + . interpretAuthSubsystemLowerEffects ctx + . iGalleyAPIAccess ctx + . intepreterTeamSubsystemToGalleyAPI + . runDelay + . P.asyncToIOFinal + . iGundeckAPIAccess ctx + . iNotificationSubsystem ctx + . runAWSSubsystem ctx.sparCtxAws + . runEvents + . iUserGroupStore + . iUserGroupSubsystemError . verdictFormatStoreToCassandra . aReqIDStoreToCassandra . assIDStoreToCassandra . sparRouteToServant (saml $ sparCtxOpts ctx) - $ saml2ToSaml2WebSso action + . saml2ToSaml2WebSso + . iUserAuthDoubleSubsystem + . interpretUserGroupSubsystem + . interpretScimSubsystem + +iUserAuthDoubleSubsystem :: (Members LowerLevelCanonicalEffs r) => InterpretersFor '[UserSubsystem, AuthenticationSubsystem] r +iUserAuthDoubleSubsystem = authSubsystemInterpreter . userSubsystemInterpreter + where + userSubsystemInterpreter :: (Members LowerLevelCanonicalEffs r) => InterpreterFor UserSubsystem r + userSubsystemInterpreter = runUserSubsystem authSubsystemInterpreter + + authSubsystemInterpreter :: (Members LowerLevelCanonicalEffs r) => InterpreterFor AuthenticationSubsystem r + authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter + +iGalleyAPIAccess :: + ( Member (Error ParseException) r, + Member Rpc r, + Member TinyLog r + ) => + Env -> + InterpreterFor GalleyAPIAccess r +iGalleyAPIAccess env = interpretGalleyAPIAccessToRpc env.disabledVersions env.sparCtxHttpGalleyEndpoint + +iGundeckAPIAccess :: + ( Member (Embed IO) r, + Member Rpc r + ) => + Env -> + InterpreterFor GundeckAPIAccess r +iGundeckAPIAccess env = runGundeckAPIAccess (sparCtxHttpGundeckEndpoint env) + +iNotificationSubsystem :: + ( Member GundeckAPIAccess r, + Member TinyLog r, + Member Delay r, + Member P.Async r, + Member (Final IO) r + ) => + Env -> + InterpreterFor NotificationSubsystem r +iNotificationSubsystem env = runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig env.sparCtxRequestId) + +iUserGroupStore :: + ( Member (Input (Local ())) r, + Member (Embed IO) r, + Member (Input Hasql.Pool) r, + Member (Error Hasql.UsageError) r + ) => + InterpreterFor UserGroupStore r +iUserGroupStore = interpretUserGroupStoreToPostgres + +iUserGroupSubsystemError :: (Member (Error SparError) r) => InterpreterFor (Error UserGroupSubsystemError) r +iUserGroupSubsystemError = Polysemy.Error.mapError (httpErrorToSparError . userGroupSubsystemErrorToHttpError) + +iHasqlUsageError :: (Member (Error SparError) r) => InterpreterFor (Error Hasql.UsageError) r +iHasqlUsageError = Polysemy.Error.mapError (httpErrorToSparError . postgresUsageErrorToHttpError) + +iParseException :: (Member (Error SparError) r) => InterpreterFor (Error ParseException) r +iParseException = Polysemy.Error.mapError (httpErrorToSparError . parseExceptionToHttpError) + +iErrorCall :: (Member (Error SparError) r) => InterpreterFor (Error ErrorCall) r +iErrorCall = Polysemy.Error.mapError errorCallToSparError + where + errorCallToSparError :: ErrorCall -> SparError + errorCallToSparError (ErrorCallWithLocation msg _) = SAML.CustomError (SparInternalError (fromString msg)) + +type UserSubsystemLowerEffects = + '[ UserStore, + AppStore, + UserKeyStore, + BlockListStore, + ConnectionStore InternalPaging, + DomainRegistrationStore, + FederationAPIAccess FederatorClient, + Concurrency 'Unsafe, + Error FederationError, + Error UserSubsystemError, + DeleteQueue, + IndexedUserStore, + FederationConfigStore, + Metrics, + InvitationStore, + Input UserSubsystemConfig + ] + +interpretUserSubsystemLowerEffects :: + ( Member (Input Hasql.Pool) r, + Member UserStore r, + Member (Error Hasql.UsageError) r, + Member (Error SparError) r, + Member (Final IO) r, + Member (Embed IO) r, + Member (Embed Cas.Client) r, + Member TinyLog r, + Member (Error ErrorCall) r + ) => + Env -> + InterpretersFor UserSubsystemLowerEffects r +interpretUserSubsystemLowerEffects env = + runInputConst env.sparCtxUserSubsystemConfig + . interpretInvitationStoreToCassandra env.sparCtxCas + . runMetricsToIO + . interpretFederationDomainConfig env.sparCtxCas Nothing mempty + . interpretIndexedUserStoreES env.sparCtxIndexedUserStoreConfig + . runDeleteQueue env.sparCtxInternalEvents + . mapError (httpErrorToSparError . userSubsystemErrorToHttpError) + . mapError (httpErrorToSparError . StdError . federationErrorToWai) + . unsafelyPerformConcurrency + . interpretFederationAPIAccess env.sparCtxFederationAPIAccessConfig + . interpretDomainRegistrationStoreToCassandra env.sparCtxCas + . connectionStoreToCassandra + . interpretBlockListStoreToCassandra env.sparCtxCas + . interpretUserKeyStoreCassandra env.sparCtxCas + . interpretAppStoreToPostgres + . interpretUserStoreCassandra env.sparCtxCas + +type AuthSubsystemLowerEffects = + '[ PasswordResetCodeStore, + Error AuthenticationSubsystemError, + HashPassword, + SessionStore, + Input AuthenticationSubsystemConfig, + PasswordStore, + EmailSubsystem, + RateLimit, + CryptoSign, + Random + ] + +interpretAuthSubsystemLowerEffects :: + ( Member (Error SparError) r, + Member (Embed Cas.Client) r, + Member EmailSending r, + Member (Error RateLimitExceeded) r, + Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, + Member (Embed IO) r + ) => + Env -> + InterpretersFor AuthSubsystemLowerEffects r +interpretAuthSubsystemLowerEffects env = + randomToIO + . runCryptoSign + . interpretRateLimit env.sparCtxRateLimit + . emailSubsystemInterpreter env.sparCtxUserTemplates env.sparCtxTeamTemplates env.sparCtxTemplateBranding + . interpretPasswordStore env.sparCtxCas + . runInputConst env.sparCtxAuthenticationSubsystemConfig + . interpretSessionStoreCassandra env.sparCtxCas + . runHashPassword env.sparCtxPasswordHashingOptions + . mapError (httpErrorToSparError . authenticationSubsystemErrorToHttpError) + . passwordResetCodeStoreToCassandra @Cas.Client runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do - err <- liftIO $ runSparToIO ctx spar - throwErrorAsHandlerException err - where - throwErrorAsHandlerException :: Either SparError a -> Handler a - throwErrorAsHandlerException (Left err) = - sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError - throwErrorAsHandlerException (Right a) = pure a + liftIO (runSparToIO ctx spar) >>= \case + Right val -> pure val + Left err -> sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError diff --git a/services/spar/src/Spar/Data/Instances.hs b/services/spar/src/Spar/Data/Instances.hs index d7a8f8a911..1ab252c0f2 100644 --- a/services/spar/src/Spar/Data/Instances.hs +++ b/services/spar/src/Spar/Data/Instances.hs @@ -72,8 +72,6 @@ instance Cql SAML.NameID where deriving instance Cql SAML.Issuer -deriving instance Cql SAML.IdPId - deriving instance Cql (SAML.ID SAML.AuthnRequest) type VerdictFormatRow = (VerdictFormatCon, Maybe URI, Maybe URI) diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index 732da191f3..779310d78c 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -39,6 +39,8 @@ module Spar.Error sparToServerError, renderSparError, waiToServant, + mapScimSubsystemErrors, + httpErrorToSparError, ) where @@ -48,6 +50,8 @@ import Control.Monad.Except import Data.Aeson import qualified Data.ByteString.Lazy as ByteString import qualified Data.ByteString.UTF8 as UTF8 +import Data.Id +import qualified Data.Text as Text import Data.Text.Encoding.Error import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText @@ -58,11 +62,15 @@ import Network.HTTP.Types.Status import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Wai import qualified Network.Wai.Utilities.Server as Wai +import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import Servant import qualified System.Logger.Class as Log import qualified Web.Scim.Schema.Error as Scim import Wire.API.User.Saml (TTLError) +import Wire.Error +import Wire.ScimSubsystem.Interpreter type SparError = SAML.Error SparCustomError @@ -72,6 +80,9 @@ instance Exception SparError throwSpar :: (MonadError SparError m) => SparCustomError -> m a throwSpar = throwError . SAML.CustomError +httpErrorToSparError :: HttpError -> SparError +httpErrorToSparError = SAML.CustomError . SparSomeHttpError + data SparCustomError = SparIdPNotFound LText | SparSPNotFound LText @@ -107,12 +118,8 @@ data SparCustomError | -- | scim tokens can only be created in case where there's at most one idp SparProvisioningMoreThanOneIdP SparProvisioningMoreThanOneIdP | SparProvisioningTokenLimitReached - | -- | FUTUREWORK(fisx): This constructor is used in exactly one place (see - -- "Spar.Sem.SAML2.Library"), for an error that immediately gets caught. - -- Instead, we could just use an IO exception, and catch it with - -- 'catchErrors' (see "Spar.Run"). Maybe we want to remove this case - -- altogether? Not sure. - SparInternalError LText + | SparInternalError LText + | SparSomeHttpError HttpError | -- | All errors returned from SCIM handlers are wrapped into 'SparScimError' SparScimError Scim.ScimError deriving (Eq, Show) @@ -147,7 +154,7 @@ servantToWaiError (ServerError code phrase body _headers) = (LText.decodeUtf8With lenientDecode body) sparToServerError :: SparError -> ServerError -sparToServerError = either id waiToServant . renderSparError +sparToServerError = httpErrorToServerError . renderSparError waiToServant :: Wai.Error -> ServerError waiToServant waierr = @@ -158,94 +165,96 @@ waiToServant waierr = errHeaders = [] } -renderSparError :: SparError -> Either ServerError Wai.Error -renderSparError (SAML.CustomError SparNoSuchRequest) = Right $ Wai.mkError status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." -renderSparError (SAML.CustomError (SparRequestMissingTryIdpInitiatedLogin (issuer :: LText))) = Left err303 {errHeaders = [("Location", cs issuer)]} +renderSparError :: SparError -> HttpError +renderSparError (SAML.CustomError SparNoSuchRequest) = StdError $ Wai.mkError status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." +renderSparError (SAML.CustomError (SparRequestMissingTryIdpInitiatedLogin (issuer :: LText))) = RichError (Wai.mkError status303 "" "") () [("Location", cs issuer)] where cs :: LText -> ByteString cs = mconcat . ByteString.toChunks . LText.encodeUtf8 -renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wai.mkError status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) -renderSparError (SAML.CustomError (SparCouldNotSubstituteSuccessURI msg)) = Right $ Wai.mkError status400 "bad-success-redirect" ("re-parsing the substituted URI failed: " <> msg) -renderSparError (SAML.CustomError (SparCouldNotSubstituteFailureURI msg)) = Right $ Wai.mkError status400 "bad-failure-redirect" ("re-parsing the substituted URI failed: " <> msg) -renderSparError (SAML.CustomError (SparBadInitiateLoginQueryParams label)) = Right $ Wai.mkError status400 label label -renderSparError (SAML.CustomError (SparUserRefInNoOrMultipleTeams msg)) = Right $ Wai.mkError status403 "bad-team" ("Forbidden: multiple teams or no team for same UserRef " <> msg) -renderSparError (SAML.CustomError (SparBadUserName msg)) = Right $ Wai.mkError status400 "bad-username" ("Bad UserName in SAML response, except len [1, 128]: " <> msg) -renderSparError (SAML.CustomError (SparCannotCreateUsersOnReplacedIdP replacingIdPId)) = Right $ Wai.mkError status400 "cannont-provision-on-replaced-idp" ("This IdP has been replaced, users can only be auto-provisioned on the replacing IdP " <> replacingIdPId) +renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = StdError $ Wai.mkError status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) +renderSparError (SAML.CustomError (SparCouldNotSubstituteSuccessURI msg)) = StdError $ Wai.mkError status400 "bad-success-redirect" ("re-parsing the substituted URI failed: " <> msg) +renderSparError (SAML.CustomError (SparCouldNotSubstituteFailureURI msg)) = StdError $ Wai.mkError status400 "bad-failure-redirect" ("re-parsing the substituted URI failed: " <> msg) +renderSparError (SAML.CustomError (SparBadInitiateLoginQueryParams label)) = StdError $ Wai.mkError status400 label label +renderSparError (SAML.CustomError (SparUserRefInNoOrMultipleTeams msg)) = StdError $ Wai.mkError status403 "bad-team" ("Forbidden: multiple teams or no team for same UserRef " <> msg) +renderSparError (SAML.CustomError (SparBadUserName msg)) = StdError $ Wai.mkError status400 "bad-username" ("Bad UserName in SAML response, except len [1, 128]: " <> msg) +renderSparError (SAML.CustomError (SparCannotCreateUsersOnReplacedIdP replacingIdPId)) = StdError $ Wai.mkError status400 "cannont-provision-on-replaced-idp" ("This IdP has been replaced, users can only be auto-provisioned on the replacing IdP " <> replacingIdPId) -- RFC-specific errors -renderSparError (SAML.CustomError (SparCouldNotParseRfcResponse service msg)) = Right $ Wai.mkError status502 "bad-upstream" ("Could not parse " <> service <> " response body: " <> msg) -renderSparError (SAML.CustomError SparReAuthRequired) = Right $ Wai.mkError status403 "access-denied" "This operation requires reauthentication." -renderSparError (SAML.CustomError SparReAuthCodeAuthFailed) = Right $ Wai.mkError status403 "code-authentication-failed" "Reauthentication failed with invalid verification code." -renderSparError (SAML.CustomError SparReAuthCodeAuthRequired) = Right $ Wai.mkError status403 "code-authentication-required" "Reauthentication failed. Verification code required." -renderSparError (SAML.CustomError SparCouldNotRetrieveCookie) = Right $ Wai.mkError status502 "bad-upstream" "Unable to get a cookie from an upstream server." -renderSparError (SAML.CustomError (SparCassandraError msg)) = Right $ Wai.mkError status500 "server-error" msg -- TODO: should we be more specific here and make it 'db-error'? +renderSparError (SAML.CustomError (SparCouldNotParseRfcResponse service msg)) = StdError $ Wai.mkError status502 "bad-upstream" ("Could not parse " <> service <> " response body: " <> msg) +renderSparError (SAML.CustomError SparReAuthRequired) = StdError $ Wai.mkError status403 "access-denied" "This operation requires reauthentication." +renderSparError (SAML.CustomError SparReAuthCodeAuthFailed) = StdError $ Wai.mkError status403 "code-authentication-failed" "Reauthentication failed with invalid verification code." +renderSparError (SAML.CustomError SparReAuthCodeAuthRequired) = StdError $ Wai.mkError status403 "code-authentication-required" "Reauthentication failed. Verification code required." +renderSparError (SAML.CustomError SparCouldNotRetrieveCookie) = StdError $ Wai.mkError status502 "bad-upstream" "Unable to get a cookie from an upstream server." +renderSparError (SAML.CustomError (SparCassandraError msg)) = StdError $ Wai.mkError status500 "server-error" msg -- TODO: should we be more specific here and make it 'db-error'? renderSparError (SAML.CustomError (SparCassandraTTLError ttlerr)) = - Right $ + StdError $ Wai.mkError status400 "ttl-error" (LText.pack $ show ttlerr) -renderSparError (SAML.UnknownIdP msg) = Right $ Wai.mkError status404 "not-found" ("IdP not found: " <> msg) -renderSparError (SAML.Forbidden msg) = Right $ Wai.mkError status403 "forbidden" ("Forbidden: " <> msg) +renderSparError (SAML.UnknownIdP msg) = StdError $ Wai.mkError status404 "not-found" ("IdP not found: " <> msg) +renderSparError (SAML.Forbidden msg) = StdError $ Wai.mkError status403 "forbidden" ("Forbidden: " <> msg) renderSparError (SAML.BadSamlResponseBase64Error msg) = - Right $ + StdError $ Wai.mkError status400 "bad-response-encoding" ("Bad response: base64 error: " <> msg) renderSparError (SAML.BadSamlResponseXmlError msg) = - Right $ + StdError $ Wai.mkError status400 "bad-response-xml" ("Bad response: XML parse error: " <> msg) renderSparError (SAML.BadSamlResponseSamlError msg) = - Right $ + StdError $ Wai.mkError status400 "bad-response-saml" ("Bad response: SAML parse error: " <> msg) -renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: SAMLResponse form field missing from HTTP body" -renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no Issuer in AuthnResponse" -renderSparError SAML.BadSamlResponseInconsistentIdPIssuerInfo = Right $ Wai.mkError status403 "bad-response-saml" "Bad response: IdP Issuer in AuthnResponse does not match AuthnRequest" -renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no assertions in AuthnResponse" -renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: assertion without ID" +renderSparError SAML.BadSamlResponseFormFieldMissing = StdError $ Wai.mkError status400 "bad-response-saml" "Bad response: SAMLResponse form field missing from HTTP body" +renderSparError SAML.BadSamlResponseIssuerMissing = StdError $ Wai.mkError status400 "bad-response-saml" "Bad response: no Issuer in AuthnResponse" +renderSparError SAML.BadSamlResponseInconsistentIdPIssuerInfo = StdError $ Wai.mkError status403 "bad-response-saml" "Bad response: IdP Issuer in AuthnResponse does not match AuthnRequest" +renderSparError SAML.BadSamlResponseNoAssertions = StdError $ Wai.mkError status400 "bad-response-saml" "Bad response: no assertions in AuthnResponse" +renderSparError SAML.BadSamlResponseAssertionWithoutID = StdError $ Wai.mkError status400 "bad-response-saml" "Bad response: assertion without ID" renderSparError (SAML.BadSamlResponseInvalidSignature msg) = - Right $ + StdError $ Wai.mkError status400 "bad-response-signature" msg -renderSparError (SAML.CustomError (SparIdPNotFound "")) = Right $ Wai.mkError status404 "not-found" "Could not find IdP." -renderSparError (SAML.CustomError (SparIdPNotFound msg)) = Right $ Wai.mkError status404 "not-found" ("Could not find IdP: " <> msg) -renderSparError (SAML.CustomError (SparSPNotFound "")) = Right $ Wai.mkError status404 "not-found" "Could not find SP." -renderSparError (SAML.CustomError (SparSPNotFound msg)) = Right $ Wai.mkError status404 "not-found" ("Could not find SP: " <> msg) -renderSparError (SAML.CustomError SparSamlCredentialsNotFound) = Right $ Wai.mkError status404 "not-found" "Could not find SAML credentials, and auto-provisioning is disabled." -renderSparError (SAML.CustomError SparMissingZUsr) = Right $ Wai.mkError status400 "client-error" "[header] 'Z-User' required" -renderSparError (SAML.CustomError SparNotInTeam) = Right $ Wai.mkError status403 "no-team-member" "Requesting user is not a team member or not a member of this team." +renderSparError (SAML.CustomError (SparIdPNotFound "")) = StdError $ Wai.mkError status404 "not-found" "Could not find IdP." +renderSparError (SAML.CustomError (SparIdPNotFound msg)) = StdError $ Wai.mkError status404 "not-found" ("Could not find IdP: " <> msg) +renderSparError (SAML.CustomError (SparSPNotFound "")) = StdError $ Wai.mkError status404 "not-found" "Could not find SP." +renderSparError (SAML.CustomError (SparSPNotFound msg)) = StdError $ Wai.mkError status404 "not-found" ("Could not find SP: " <> msg) +renderSparError (SAML.CustomError SparSamlCredentialsNotFound) = StdError $ Wai.mkError status404 "not-found" "Could not find SAML credentials, and auto-provisioning is disabled." +renderSparError (SAML.CustomError SparMissingZUsr) = StdError $ Wai.mkError status400 "client-error" "[header] 'Z-User' required" +renderSparError (SAML.CustomError SparNotInTeam) = StdError $ Wai.mkError status403 "no-team-member" "Requesting user is not a team member or not a member of this team." renderSparError (SAML.CustomError (SparNoPermission perm)) = - Right $ + StdError $ Wai.mkError status403 "insufficient-permissions" ("You need permission " <> perm <> ".") -renderSparError (SAML.CustomError SparSSODisabled) = Right $ Wai.mkError status403 "sso-disabled" "Please ask customer support to enable this feature for your team." -renderSparError SAML.UnknownError = Right $ Wai.mkError status500 "server-error" "Unknown server error." -renderSparError (SAML.BadServerConfig msg) = Right $ Wai.mkError status500 "server-error" ("Error in server config: " <> msg) -renderSparError (SAML.InvalidCert msg) = Right $ Wai.mkError status500 "invalid-certificate" ("Error in idp certificate: " <> msg) +renderSparError (SAML.CustomError SparSSODisabled) = StdError $ Wai.mkError status403 "sso-disabled" "Please ask customer support to enable this feature for your team." +renderSparError SAML.UnknownError = StdError $ Wai.mkError status500 "server-error" "Unknown server error." +renderSparError (SAML.BadServerConfig msg) = StdError $ Wai.mkError status500 "server-error" ("Error in server config: " <> msg) +renderSparError (SAML.InvalidCert msg) = StdError $ Wai.mkError status500 "invalid-certificate" ("Error in idp certificate: " <> msg) -- Errors related to IdP creation -renderSparError (SAML.CustomError (SparNewIdPBadMetadata msg)) = Right $ Wai.mkError status400 "invalid-metadata" msg -renderSparError (SAML.CustomError SparNewIdPPubkeyMismatch) = Right $ Wai.mkError status400 "key-mismatch" "public keys in body, metadata do not match" -renderSparError (SAML.CustomError (SparNewIdPAlreadyInUse msg)) = Right $ Wai.mkError status400 "idp-already-in-use" msg -renderSparError (SAML.CustomError (SparNewIdPWantHttps msg)) = Right $ Wai.mkError status400 "idp-must-be-https" ("an idp request uri must be https, not http or other: " <> msg) -renderSparError (SAML.CustomError SparIdPHasBoundUsers) = Right $ Wai.mkError status412 "idp-has-bound-users" "an idp can only be deleted if it is empty" -renderSparError (SAML.CustomError SparIdPIssuerInUse) = Right $ Wai.mkError status400 "idp-issuer-in-use" "The issuer of your IdP is already in use. Remove the entry in the team that uses it, or construct a new IdP issuer." -renderSparError (SAML.CustomError SparIdPCannotDeleteOwnIdp) = Right $ Wai.mkError status409 "cannot-delete-own-idp" "You cannot delete the IdP used to login with your own account." -renderSparError (SAML.CustomError (IdpDbError InsertIdPConfigCannotMixApiVersions)) = Right $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot have two IdPs with the same issuerwhere one of them is using API V1 and one API V2." -renderSparError (SAML.CustomError (IdpDbError AttemptToGetV1IssuerViaV2API)) = Right $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot retrieve an API V1 IdP via API V2." -renderSparError (SAML.CustomError (IdpDbError AttemptToGetV2IssuerViaV1API)) = Right $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot retrieve an API V2 IdP via API V1." -renderSparError (SAML.CustomError (IdpDbError IdpNonUnique)) = Right $ Wai.mkError status409 "idp-non-unique" "We have found multiple IdPs with the same issuer. Please contact customer support." -renderSparError (SAML.CustomError (IdpDbError IdpWrongTeam)) = Right $ Wai.mkError status409 "idp-wrong-team" "The IdP is not part of this team." +renderSparError (SAML.CustomError (SparNewIdPBadMetadata msg)) = StdError $ Wai.mkError status400 "invalid-metadata" msg +renderSparError (SAML.CustomError SparNewIdPPubkeyMismatch) = StdError $ Wai.mkError status400 "key-mismatch" "public keys in body, metadata do not match" +renderSparError (SAML.CustomError (SparNewIdPAlreadyInUse msg)) = StdError $ Wai.mkError status400 "idp-already-in-use" msg +renderSparError (SAML.CustomError (SparNewIdPWantHttps msg)) = StdError $ Wai.mkError status400 "idp-must-be-https" ("an idp request uri must be https, not http or other: " <> msg) +renderSparError (SAML.CustomError SparIdPHasBoundUsers) = StdError $ Wai.mkError status412 "idp-has-bound-users" "an idp can only be deleted if it is empty" +renderSparError (SAML.CustomError SparIdPIssuerInUse) = StdError $ Wai.mkError status400 "idp-issuer-in-use" "The issuer of your IdP is already in use. Remove the entry in the team that uses it, or construct a new IdP issuer." +renderSparError (SAML.CustomError SparIdPCannotDeleteOwnIdp) = StdError $ Wai.mkError status409 "cannot-delete-own-idp" "You cannot delete the IdP used to login with your own account." +renderSparError (SAML.CustomError (IdpDbError InsertIdPConfigCannotMixApiVersions)) = StdError $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot have two IdPs with the same issuerwhere one of them is using API V1 and one API V2." +renderSparError (SAML.CustomError (IdpDbError AttemptToGetV1IssuerViaV2API)) = StdError $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot retrieve an API V1 IdP via API V2." +renderSparError (SAML.CustomError (IdpDbError AttemptToGetV2IssuerViaV1API)) = StdError $ Wai.mkError status409 "cannot-mix-idp-api-verions" "You cannot retrieve an API V2 IdP via API V1." +renderSparError (SAML.CustomError (IdpDbError IdpNonUnique)) = StdError $ Wai.mkError status409 "idp-non-unique" "We have found multiple IdPs with the same issuer. Please contact customer support." +renderSparError (SAML.CustomError (IdpDbError IdpWrongTeam)) = StdError $ Wai.mkError status409 "idp-wrong-team" "The IdP is not part of this team." renderSparError (SAML.CustomError (IdpDbError IdpNotFound)) = renderSparError (SAML.CustomError (SparIdPNotFound "")) -- Errors related to provisioning -renderSparError (SAML.CustomError (SparProvisioningMoreThanOneIdP msg)) = Right $ +renderSparError (SAML.CustomError (SparProvisioningMoreThanOneIdP msg)) = StdError $ Wai.mkError status400 "more-than-one-idp" do "Team can have at most one IdP configured: " <> case msg of ScimTokenAndSecondIdpForbidden -> "teams with SCIM tokens can only have at most one IdP" TwoIdpsAndScimTokenForbidden -> "SCIM tokens can only be created for a team with at most one IdP" -renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.mkError status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" +renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = StdError $ Wai.mkError status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" -- SCIM errors -renderSparError (SAML.CustomError (SparScimError err)) = Left $ Scim.scimToServerError err -renderSparError (SAML.CustomError (SparInternalError err)) = Right $ Wai.mkError status500 "server-error" ("Internal error: " <> err) +renderSparError (SAML.CustomError (SparScimError err)) = case Scim.scimToWaiError err of + (e, hs) -> RichError e () hs +renderSparError (SAML.CustomError (SparInternalError err)) = StdError $ Wai.mkError status500 "server-error" ("Internal error: " <> err) +renderSparError (SAML.CustomError (SparSomeHttpError err)) = err -- Other -renderSparError (SAML.CustomServant err) = Left err +renderSparError (SAML.CustomServant err) = serverErrorToHttpError err -- | If a call to another backend service fails, just respond with whatever it said. -- @@ -287,3 +296,17 @@ parseResponse serviceName resp = do bdy <- maybe (err "no body") pure $ responseBody resp either (err . LText.pack) pure $ eitherDecode' bdy + +mapScimSubsystemErrors :: (Member (Error SparError) r) => InterpreterFor (Error ScimSubsystemError) r +mapScimSubsystemErrors = + Polysemy.Error.mapError $ + SAML.CustomError . SparScimError . \case + ScimSubsystemError err -> + err + ScimSubsystemInvalidGroupMemberId badIds -> + Scim.notFound "group members" badIds + ScimSubsystemScimGroupWithNonScimMembers badIds -> + Scim.badRequest Scim.InvalidValue (Just $ "These users are not \"managed_by\" = \"scim\": " <> renderIds badIds) + where + renderIds :: [UserId] -> Text + renderIds = Text.intercalate ", " . fmap idToText diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index d6bf7840cc..9134cfc2d6 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- This file is part of the Wire Server implementation. @@ -20,6 +21,13 @@ -- | Reading the Spar config. module Spar.Options ( Opts (..), + Settings (..), + ZAuthOpts (..), + EmailSMSOpts (..), + BrandingOpts (..), + CustomerExtensions (..), + DomainsBlockedForRegistration (..), + ElasticSearchOpts (..), getOpts, readOptsFile, maxttlAuthreqDiffTime, @@ -28,24 +36,48 @@ where import Control.Exception import Data.Aeson hiding (fieldLabelModifier) +import Data.Domain (Domain) import Data.Time import qualified Data.Yaml as Yaml +import qualified Database.Bloodhound.Types as ES import Imports +import qualified Network.AMQP.Extended as Q import Options.Applicative import SAML2.WebSSO import qualified SAML2.WebSSO as SAML -import System.Logger.Extended (LogFormat) +import System.Logger.Extended (Level, LogFormat) import URI.ByteString import Util.Options +import Util.Timeout (Timeout) +import Wire.API.Allowlists (AllowlistEmailDomains) +import Wire.API.Routes.FederationDomainConfig (FederationDomainConfig, FederationStrategy) import Wire.API.Routes.Version +import Wire.API.User (EmailAddress, EmailVisibilityConfig, Locale) import Wire.API.User.Orphans () import Wire.API.User.Saml +import Wire.AWSSubsystem.AWS (AWSOpts) +import Wire.AuthenticationSubsystem.Config (ZAuthSettings) +import Wire.AuthenticationSubsystem.Cookie.Limit (CookieThrottle) +import Wire.DeleteQueue.Types (InternalEventsOpts) +import Wire.RateLimit.Interpreter (RateLimitConfig) +import Wire.StompSubsystem.Stomp (StompOpts) data Opts = Opts { saml :: !SAML.Config, brig :: !Endpoint, galley :: !Endpoint, + gundeck :: !Endpoint, cassandra :: !CassandraOpts, + elasticsearch :: !ElasticSearchOpts, + -- | Postgresql settings, the key values must be in libpq format. + postgresql :: !(Map Text Text), + postgresqlPassword :: !(Maybe FilePathSecrets), + -- | Federator address + federatorInternal :: !(Maybe Endpoint), + -- | RabbitMQ settings, required when federation is enabled. + rabbitmq :: !(Maybe Q.AmqpEndpoint), + -- | STOMP broker settings + stompOptions :: !(Maybe StompOpts), maxttlAuthreq :: !(TTL "authreq"), maxttlAuthresp :: !(TTL "authresp"), -- | The maximum number of SCIM tokens that we will allow teams to have. @@ -55,14 +87,131 @@ data Opts = Opts -- | Wire/AWS specific; optional; used to discover Cassandra instance -- IPs using describe-instances. discoUrl :: !(Maybe Text), + -- | Event queue for Spar-generated events + internalEvents :: !InternalEventsOpts, + -- | ZAuth settings + zauth :: !ZAuthOpts, + -- | Email and SMS settings + emailSMS :: !EmailSMSOpts, + -- | Log level + logLevel :: !Level, logNetStrings :: !(Maybe (Last Bool)), logFormat :: !(Maybe (Last LogFormat)), disabledAPIVersions :: !(Set VersionExp), - scimBaseUri :: URI + scimBaseUri :: URI, + aws :: !AWSOpts, + -- | Runtime settings + settings :: !Settings } - deriving (Show, Generic) + deriving stock (Show, Generic) + deriving anyclass (FromJSON) -instance FromJSON Opts +-- | Options that persist as runtime settings +data Settings = Settings + { -- | FederationDomain is required, even when not wanting to federate + federationDomain :: !Domain, + -- | See https://docs.wire.com/understand/federation/backend-communication.html#configuring-remote-connections + federationStrategy :: !(Maybe FederationStrategy), + -- | Federation domain configs + federationDomainConfigs :: !(Maybe [FederationDomainConfig]), + -- | How long until a new TURN configuration should be fetched, in seconds + federationDomainConfigsUpdateFreq :: !(Maybe Int), + -- | Password hashing options + passwordHashingOptions :: !PasswordHashingOptions, + -- | Rate limit config for password hashing + passwordHashingRateLimit :: !RateLimitConfig, + -- | STOMP broker credentials + stomp :: !(Maybe FilePathSecrets), + -- | The amount of time in milliseconds to wait after reading from an SQS queue + sqsThrottleMillis :: !(Maybe Int), + -- | Whether to expose user emails and to whom + emailVisibility :: !EmailVisibilityConfig, + -- | Default locale to use for users + defaultUserLocale :: !(Maybe Locale), + -- | When true, search only returns users from the same team + searchSameTeamOnly :: !(Maybe Bool), + -- | Max. # of members in a team (should be in sync with galley) + maxTeamSize :: !Word32, + -- | Activation timeout, in seconds + activationTimeout :: !Timeout, + -- | Customer extensions - blocked domains for registration + customerExtensions :: !(Maybe CustomerExtensions), + -- | Whitelist of allowed emails/phones + allowlistEmailDomains :: !(Maybe AllowlistEmailDomains), + -- | Minimum age of a user cookie before it is renewed during token refresh + userCookieRenewAge :: !Integer, + -- | Max. # of cookies per user and cookie type + userCookieLimit :: !Int, + -- | Throttling settings for user cookies + userCookieThrottle :: !CookieThrottle + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +-- | Customer extensions for blocked domains +data CustomerExtensions = CustomerExtensions + { domainsBlockedForRegistration :: !DomainsBlockedForRegistration + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +newtype DomainsBlockedForRegistration = DomainsBlockedForRegistration (HashSet Domain) + deriving stock (Show) + deriving newtype (FromJSON) + +-- | ZAuth options +data ZAuthOpts = ZAuthOpts + { -- | Private key file + privateKeys :: !FilePath, + -- | Public key file + publicKeys :: !FilePath, + -- | Other settings + authSettings :: !ZAuthSettings + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +-- | Email and SMS settings (simplified for Spar) +data EmailSMSOpts = EmailSMSOpts + { -- | Template directory + templateDir :: !FilePath, + -- | Email sender address + emailSender :: !EmailAddress, + -- | Customizable branding text + templateBranding :: !BrandingOpts + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +data BrandingOpts = BrandingOpts + { brand :: !Text, + brandUrl :: !Text, + brandLabelUrl :: !Text, + brandLogoUrl :: !Text, + brandService :: !Text, + copyright :: !Text, + misuse :: !Text, + legal :: !Text, + forgot :: !Text, + support :: !Text + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) + +data ElasticSearchOpts = ElasticSearchOpts + { -- | ElasticSearch URL + url :: !ES.Server, + -- | The name of the ElasticSearch user index + index :: !ES.IndexName, + -- | Elasticsearch credentials + credentials :: !(Maybe FilePathSecrets), + -- | Credentials for additional ES index (maily used for migrations) + additionalCredentials :: !(Maybe FilePathSecrets), + insecureSkipVerifyTls :: Bool, + caCert :: Maybe FilePath + } + deriving stock (Show, Generic) + deriving anyclass (FromJSON) maxttlAuthreqDiffTime :: Opts -> NominalDiffTime maxttlAuthreqDiffTime = ttlToNominalDiffTime . maxttlAuthreq @@ -77,7 +226,7 @@ getOpts = do -- | This should not leave this module. It is only for callling 'sparResponseURI' before the 'Spar' -- monad is fully initialized. newtype WithConfig a = WithConfig (Reader Opts a) - deriving (Functor, Applicative, Monad) + deriving newtype (Functor, Applicative, Monad) instance SAML.HasConfig WithConfig where getConfig = WithConfig $ asks saml diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 77503964c9..c8af6103c4 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -31,18 +31,34 @@ where import qualified Bilge import Cassandra as Cas import Cassandra.Util (initCassandraForService) -import Control.Lens (to, (^.)) +import Control.Exception (ErrorCall (ErrorCall), throwIO) +import Control.Lens (to, (^.), (^?), _Just) +import qualified Data.ByteString.UTF8 as UTF8 +import Data.Coerce (coerce) +import Data.Credentials (Credentials (..)) +import Data.Domain +import qualified Data.HashSet as HashSet import Data.Id +import Data.LanguageCodes (ISO639_1 (EN)) import Data.Metrics.Servant (servantPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) +import Data.Qualified +import qualified Data.Set as Set import Data.Text.Encoding +import qualified Database.Bloodhound as ES +import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) +import qualified Hasql.Pool.Extended as Hasql import Imports +import Network.HTTP.Client (Manager, ManagerSettings (..), newManager, responseTimeoutMicro) +import Network.HTTP.Client.OpenSSL (opensslManagerSettings) +import Network.URI import Network.Wai (Application) import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Gunzip as GZip import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as WU +import qualified OpenSSL.Session as SSL import qualified SAML2.WebSSO as SAML import Spar.API (SparAPI, app) import Spar.App @@ -53,9 +69,22 @@ import Spar.Orphans () import System.Logger (Logger) import qualified System.Logger as Log import qualified System.Logger.Extended as Log +import qualified URI.ByteString as URI import Util.Options +import qualified Web.Scim.Schema.Common as Scim import Wire.API.Routes.Version (expandVersionExp) import Wire.API.Routes.Version.Wai +import Wire.API.User (Language (Language), Locale (Locale)) +import qualified Wire.AWSSubsystem.AWS as AWSI +import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig (..), ZAuthEnv) +import qualified Wire.AuthenticationSubsystem.Config as AuthenticationSubsystem +import Wire.DeleteQueue.Types (InternalEventsOpts (..), QueueEnv (..), QueueOpts (..)) +import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..)) +import Wire.IndexedUserStore.ElasticSearch (ESConn (..), IndexedUserStoreConfig (..)) +import Wire.RateLimit.Interpreter (newRateLimitEnv) +import Wire.ScimSubsystem.Interpreter +import qualified Wire.StompSubsystem.Stomp as Stomp +import Wire.UserSubsystem.UserSubsystemConfig (UserSubsystemConfig (..)) ---------------------------------------------------------------------- -- cassandra @@ -69,6 +98,34 @@ initCassandra opts lgr = (Just Data.schemaVersion) lgr +initZAuth :: Opts -> IO ZAuthEnv +initZAuth o = do + let zOpts = Opt.zauth o + privateKeys = Opt.privateKeys zOpts + publicKeys = Opt.publicKeys zOpts + sk <- AuthenticationSubsystem.readKeys privateKeys + pk <- AuthenticationSubsystem.readKeys publicKeys + case (sk, pk) of + (Nothing, _) -> error ("No private key in: " <> privateKeys) + (_, Nothing) -> error ("No public key in: " <> publicKeys) + (Just s, Just p) -> AuthenticationSubsystem.mkZAuthEnv s p (Opt.authSettings zOpts) + +---------------------------------------------------------------------- +-- internal events queue + +initInternalEvents :: Logger -> Opts -> AWSI.Env -> IO QueueEnv +initInternalEvents lgr opts aws = case opts.internalEvents.internalEventsQueue of + StompQueueOpts q -> do + stomp :: Stomp.Env <- case (opts.stompOptions, opts.settings.stomp) of + (Just s, Just c) -> Stomp.mkEnv lgr s <$> initCredentials c + (Just _, Nothing) -> error "STOMP is configured but stomp credentials are not set" + (Nothing, Just _) -> error "stomp credentials are present but STOMP is not configured" + (Nothing, Nothing) -> error "stomp is selected for internal events, but not configured" + pure (StompQueueEnv stomp q) + SqsQueueOpts q -> do + let throttleMillis = fromMaybe 500 opts.settings.sqsThrottleMillis + SqsQueueEnv aws throttleMillis <$> AWSI.getQueueUrl (aws ^. AWSI.amazonkaEnv) q + ---------------------------------------------------------------------- -- servant / wai / warp @@ -90,6 +147,7 @@ mkApp sparCtxOpts = do sparCtxLogger <- Log.mkLogger logLevel (logNetStrings sparCtxOpts) (logFormat sparCtxOpts) sparCtxCas <- initCassandra sparCtxOpts sparCtxLogger sparCtxHttpManager <- Bilge.newManager Bilge.defaultManagerSettings + sparCtxHttp2Manager <- initHttp2Manager let sparCtxHttpBrig = Bilge.host (sparCtxOpts ^. to brig . to host . to encodeUtf8) . Bilge.port (sparCtxOpts ^. to brig . to port) @@ -98,7 +156,91 @@ mkApp sparCtxOpts = do Bilge.host (sparCtxOpts ^. to galley . to host . to encodeUtf8) . Bilge.port (sparCtxOpts ^. to galley . to port) $ Bilge.empty + let sparCtxHttpGalleyEndpoint = galley sparCtxOpts + let disabledVersions = Set.fromList . mconcat $ Set.toList . expandVersionExp <$> Set.toList sparCtxOpts.disabledAPIVersions let sparCtxRequestId = RequestId defRequestId + + (sparCtxScimSubsystemConfig, sparCtxLocalUnit) <- do + let bsUri :: URI.URI + bsUri = sparCtxOpts.scimBaseUri + + crash :: String -> IO a + crash msg = throwIO (ErrorCall $ "spar.yaml: scimBaseUri must be absolute URI containing server domain: " <> show (bsUri, msg)) + + scimUri :: Scim.URI <- do + maybe (crash "no parse") (pure . Scim.URI) + . parseURI + . UTF8.toString + . URI.normalizeURIRef' URI.noNormalization + $ bsUri + + localUnit :: Local () <- do + bs <- + maybe (crash "no host") (pure . URI.hostBS) + . (^? URI.authorityL . _Just . URI.authorityHostL) + $ bsUri + either crash (pure . (`toLocalUnsafe` ())) (mkDomainFromBS bs) + + pure (ScimSubsystemConfig scimUri, localUnit) + + -- Initialize all the required subsystem configs + let sparCtxHttpGundeckEndpoint = gundeck sparCtxOpts + sparCtxZAuthEnv <- initZAuth sparCtxOpts + let localUnit = toLocalUnsafe sparCtxOpts.settings.federationDomain () + sparCtxAuthenticationSubsystemConfig = + AuthenticationSubsystemConfig + { zauthEnv = sparCtxZAuthEnv, + allowlistEmailDomains = sparCtxOpts.settings.allowlistEmailDomains, + local = localUnit, + userCookieRenewAge = sparCtxOpts.settings.userCookieRenewAge, + userCookieLimit = sparCtxOpts.settings.userCookieLimit, + userCookieThrottle = sparCtxOpts.settings.userCookieThrottle + } + sparCtxPasswordHashingOptions = sparCtxOpts.settings.passwordHashingOptions + let sparCtxUserTemplates = undefined + let sparCtxTeamTemplates = undefined + let sparCtxTemplateBranding = undefined + -- sparCtxUserTemplates <- loadUserTemplates (emailSMS sparCtxOpts).templateDir + -- sparCtxTeamTemplates <- loadTeamTemplates (emailSMS sparCtxOpts).templateDir + -- let sparCtxTemplateBranding = genTemplateBranding (emailSMS sparCtxOpts).templateBranding + sparCtxRateLimit <- newRateLimitEnv sparCtxOpts.settings.passwordHashingRateLimit + (esEnv, esIndexName) <- mkIndexEnv sparCtxOpts.elasticsearch + let sparCtxFederationAPIAccessConfig = + FederationAPIAccessConfig + { ownDomain = sparCtxOpts.settings.federationDomain, + federatorEndpoint = sparCtxOpts.federatorInternal, + http2Manager = sparCtxHttp2Manager, + requestId = sparCtxRequestId + } + mainESEnv = esEnv + sparCtxIndexedUserStoreConfig = + IndexedUserStoreConfig + { conn = + ESConn + { env = mainESEnv, + indexName = esIndexName + }, + additionalConn = Nothing + } + blockedDomains = + sparCtxOpts.settings.customerExtensions + ^? _Just + . to (coerce @_ @(HashSet Domain) . Opt.domainsBlockedForRegistration) + & fromMaybe HashSet.empty + sparCtxUserSubsystemConfig = + UserSubsystemConfig + { emailVisibilityConfig = sparCtxOpts.settings.emailVisibility, + defaultLocale = fromMaybe (Locale (Language EN) Nothing) sparCtxOpts.settings.defaultUserLocale, + searchSameTeamOnly = fromMaybe False sparCtxOpts.settings.searchSameTeamOnly, + maxTeamSize = sparCtxOpts.settings.maxTeamSize, + activationCodeTimeout = sparCtxOpts.settings.activationTimeout, + blockedDomains = blockedDomains + } + sparCtxHasqlPool <- Hasql.initPostgresPool (postgresql sparCtxOpts) (postgresqlPassword sparCtxOpts) + let sparCtxSmtp = Nothing -- Spar doesn't send emails directly + sparCtxAws <- AWSI.mkEnv sparCtxLogger sparCtxOpts.aws Nothing sparCtxHttpManager + sparCtxInternalEvents <- initInternalEvents sparCtxLogger sparCtxOpts sparCtxAws + let ctx0 = Env {..} let heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) heavyLogOnly out@(req, _) = @@ -119,3 +261,53 @@ mkApp sparCtxOpts = do -- outages. . SAML.setHttpCachePolicy pure (middleware $ app ctx0, ctx0) + +mkIndexEnv :: Opt.ElasticSearchOpts -> IO (ES.BHEnv, ES.IndexName) +mkIndexEnv esOpts = do + mEsCreds :: Maybe Credentials <- for esOpts.credentials initCredentials + + let mkBhEnv skipVerifyTls mCustomCa mCreds url = do + mgr <- initHttpManagerWithTLSConfig skipVerifyTls mCustomCa + let bhe = ES.mkBHEnv url mgr + pure $ maybe bhe (\creds -> bhe {ES.bhRequestHook = ES.basicAuthHook (ES.EsUsername creds.username) (ES.EsPassword creds.password)}) mCreds + bhEnv <- mkBhEnv esOpts.insecureSkipVerifyTls esOpts.caCert mEsCreds esOpts.url + pure (bhEnv, esOpts.index) + +initHttpManagerWithTLSConfig :: Bool -> Maybe FilePath -> IO Manager +initHttpManagerWithTLSConfig skipTlsVerify mCustomCa = do + -- See Note [SSL context] + ctx <- SSL.context + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 + SSL.contextSetCiphers ctx "HIGH" + if skipTlsVerify + then SSL.contextSetVerificationMode ctx SSL.VerifyNone + else + SSL.contextSetVerificationMode ctx $ + SSL.VerifyPeer True True Nothing + case mCustomCa of + Nothing -> SSL.contextSetDefaultVerifyPaths ctx + Just customCa -> do + filePath <- canonicalizePath customCa + SSL.contextSetCAFile ctx filePath + -- Unfortunately, there are quite some AWS services we talk to + -- (e.g. SES, Dynamo) that still only support TLSv1. + -- Ideally: SSL.contextAddOption ctx SSL_OP_NO_TLSv1 + newManager + (opensslManagerSettings (pure ctx)) + { managerConnCount = 1024, + managerIdleConnectionCount = 4096, + managerResponseTimeout = responseTimeoutMicro 10000000 + } + +initHttp2Manager :: IO Http2Manager +initHttp2Manager = do + ctx <- SSL.context + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 + SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 + SSL.contextAddOption ctx SSL.SSL_OP_NO_TLSv1 + SSL.contextSetCiphers ctx "HIGH" + SSL.contextSetVerificationMode ctx $ + SSL.VerifyPeer True True Nothing + SSL.contextSetDefaultVerifyPaths ctx + http2ManagerWithSSLCtx ctx diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 0d66908bbe..18060c4d64 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -80,6 +80,7 @@ import Spar.Error ) import Spar.Options import Spar.Scim.Auth +import Spar.Scim.Group () import Spar.Scim.User import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.GalleyAccess (GalleyAccess) @@ -91,7 +92,7 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import System.Logger (Msg) import qualified Web.Scim.Capabilities.MetaSchema as Scim.Meta -import qualified Web.Scim.Class.Auth as Scim.Auth +import qualified Web.Scim.Class.Group as Scim.Group import qualified Web.Scim.Class.User as Scim.User import qualified Web.Scim.Handler as Scim import qualified Web.Scim.Schema.Error as Scim @@ -99,6 +100,7 @@ import qualified Web.Scim.Schema.Schema as Scim.Schema import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar import Wire.API.User.Scim +import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import Wire.Sem.Now (Now) import Wire.Sem.Random (Random) @@ -120,6 +122,7 @@ apiScim :: Member (Error SparError) r, Member GalleyAccess r, Member BrigAccess r, + Member ScimSubsystem r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member ScimTokenStore r, @@ -178,15 +181,15 @@ apiScim = -- No exceptions! Good. pure x --- | This is similar to 'Scim.siteServer, but does not include the 'Scim.groupServer', --- as we don't support it (we don't implement 'Web.Scim.Class.Group.GroupDB'). +-- | This is similar to 'Scim.siteServer'. server :: forall tag m. - (Scim.User.UserDB tag m, Scim.Auth.AuthDB tag m) => + (Scim.User.UserDB tag m, Scim.Group.GroupDB tag m) => Scim.Meta.Configuration -> ScimSite tag (AsServerT (Scim.ScimHandler m)) server conf = ScimSite { config = toServant $ Scim.configServer conf, - users = \authData -> toServant (Scim.userServer @tag authData) + users = \authData -> toServant (Scim.userServer @tag authData), + groups = \authData -> toServant (Scim.groupServer @tag authData) } diff --git a/services/spar/src/Spar/Scim/Group.hs b/services/spar/src/Spar/Scim/Group.hs new file mode 100644 index 0000000000..ff8ca57eb7 --- /dev/null +++ b/services/spar/src/Spar/Scim/Group.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- 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 Spar.Scim.Group where + +import Data.Aeson qualified as Aeson +import Imports +import Polysemy +import Web.Scim.Class.Auth +import Web.Scim.Class.Group qualified as SCG +import Web.Scim.Handler +import Web.Scim.Schema.ListResponse +import Wire.API.User.Scim +import Wire.ScimSubsystem + +---------------------------------------------------------------------------- +-- GroupDB instance + +instance (AuthDB SparTag (Sem r), Member ScimSubsystem r) => SCG.GroupDB SparTag (Sem r) where + getGroups :: + AuthInfo SparTag -> + ScimHandler m (ListResponse (SCG.StoredGroup SparTag)) + getGroups = undefined + + -- \| Get a single group by ID. + -- + -- Should throw 'notFound' if the group does not. + getGroup :: + AuthInfo SparTag -> + SCG.GroupId SparTag -> + ScimHandler m (SCG.StoredGroup SparTag) + getGroup = undefined + + -- \| Create a new group. + -- + -- Should throw 'conflict' if uniqueness constraints are violated. + postGroup :: + AuthInfo SparTag -> + SCG.Group -> + ScimHandler (Sem r) (SCG.StoredGroup SparTag) + postGroup ((.stiTeam) -> team) grp = lift $ scimCreateUserGroup team grp + + -- no additional helpers + + -- \| Overwrite an existing group. + -- + -- Should throw 'notFound' if the group does not exist, and 'conflict' if uniqueness + -- constraints are violated. + putGroup :: + AuthInfo SparTag -> + SCG.GroupId SparTag -> + SCG.Group -> + ScimHandler m (SCG.StoredGroup SparTag) + putGroup = undefined + + -- \| Modify an existing group. + -- + -- Should throw 'notFound' if the group doesn't exist, and 'conflict' if uniqueness + -- constraints are violated. + -- + -- FUTUREWORK: add types for PATCH (instead of 'Aeson.Value'). + -- See + patchGroup :: + AuthInfo SparTag -> + SCG.GroupId SparTag -> + -- \| PATCH payload + Aeson.Value -> + ScimHandler m (SCG.StoredGroup SparTag) + patchGroup = undefined + + -- \| Delete a group. + -- + -- Should throw 'notFound' if the group does not exist. + deleteGroup :: + AuthInfo SparTag -> + SCG.GroupId SparTag -> + ScimHandler m () + deleteGroup = undefined diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs index 5a4e845584..680c8c0ec7 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs @@ -30,6 +30,7 @@ import Polysemy import qualified SAML2.WebSSO.Types as SAML import Spar.Data.Instances () import Spar.Sem.DefaultSsoCode +import {- instance Cql SAML.IdPId -} Wire.DomainRegistrationStore.Cassandra () defaultSsoCodeToCassandra :: forall m r a. diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs index 545395af4c..76936239c7 100644 --- a/services/spar/src/Spar/Sem/GalleyAccess.hs +++ b/services/spar/src/Spar/Sem/GalleyAccess.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.GalleyAccess +module Spar.Sem.GalleyAccess -- TODO: use GalleyAPIAccess from wire-subsystems instead. ( GalleyAccess (..), getTeamMembers, getTeamMember, diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs index 56f60c6c4f..e537f54b3b 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs @@ -40,6 +40,7 @@ import Spar.Sem.IdPConfigStore (IdPConfigStore (..), Replaced (..), Replacing (. import URI.ByteString import Wire.API.User.IdentityProvider hiding (apiVersion, oldIssuers, replacedBy, team) import qualified Wire.API.User.IdentityProvider as IP +import {- instance Cql SAML.IdPId -} Wire.DomainRegistrationStore.Cassandra () idPToCassandra :: forall m r a. diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs index 91af9fb54a..812442d958 100644 --- a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs @@ -30,6 +30,7 @@ import Polysemy import qualified SAML2.WebSSO as SAML import Spar.Data.Instances () import Spar.Sem.IdPRawMetadataStore +import {- instance Cql SAML.IdPId -} Wire.DomainRegistrationStore.Cassandra () idpRawMetadataStoreToCassandra :: forall m r a. diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index 70dc4e223d..d708b2f011 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -34,6 +34,7 @@ import Spar.Data.Instances () import Spar.Sem.ScimTokenStore import Text.RawString.QQ import Wire.API.User.Scim +import {- instance Cql SAML.IdPId -} Wire.DomainRegistrationStore.Cassandra () import qualified Prelude scimTokenStoreToCassandra :: diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 4262ba062c..b91241aff1 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -275,7 +275,25 @@ mkEnv tstOpts opts = do sparCtxHttpManager = mgr sparCtxHttpBrig = brig empty sparCtxHttpGalley = galley empty + sparCtxHttpGalleyEndpoint = undefined + sparCtxHttpGundeckEndpoint = undefined + disabledVersions = undefined sparCtxRequestId = RequestId "" + sparCtxScimSubsystemConfig = error "mkEnv: implement sparCtxScimSubsystemConfig when needed" + sparCtxLocalUnit = error "mkEnv: implement sparCtxLocalUnit when needed" + sparCtxAuthenticationSubsystemConfig = undefined + sparCtxPasswordHashingOptions = undefined + sparCtxUserTemplates = undefined + sparCtxTeamTemplates = undefined + sparCtxTemplateBranding = undefined + sparCtxRateLimit = undefined + sparCtxFederationAPIAccessConfig = undefined + sparCtxIndexedUserStoreConfig = undefined + sparCtxUserSubsystemConfig = undefined + sparCtxHasqlPool = undefined + sparCtxSmtp = undefined + sparCtxAws = undefined + sparCtxInternalEvents = undefined pure $ TestEnv mgr From b822d071d64bd90f8f1e45c901adcb524fa276e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Markus=20L=C3=A4ll?= Date: Thu, 30 Oct 2025 17:41:09 +0200 Subject: [PATCH 02/30] Add postgresPool to Spar config --- services/spar/spar.integration.yaml | 6 ++++++ services/spar/src/Spar/Options.hs | 2 ++ services/spar/src/Spar/Run.hs | 2 +- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 7a71829fa5..7ccc0e174c 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -48,6 +48,12 @@ postgresql: database: spar_test user: postgres +postgresqlPool: + size: 20 + acquisitionTimeout: 10s + agingTimeout: 1d + idlenessTimeout: 10m + # Wire/AWS specific, optional # discoUrl: "https://" diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index 9134cfc2d6..c6ceaaab18 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -42,6 +42,7 @@ import qualified Data.Yaml as Yaml import qualified Database.Bloodhound.Types as ES import Imports import qualified Network.AMQP.Extended as Q +import qualified Hasql.Pool.Extended as Hasql import Options.Applicative import SAML2.WebSSO import qualified SAML2.WebSSO as SAML @@ -72,6 +73,7 @@ data Opts = Opts -- | Postgresql settings, the key values must be in libpq format. postgresql :: !(Map Text Text), postgresqlPassword :: !(Maybe FilePathSecrets), + postgresqlPool :: !Hasql.PoolConfig, -- | Federator address federatorInternal :: !(Maybe Endpoint), -- | RabbitMQ settings, required when federation is enabled. diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index c8af6103c4..466be151ea 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -236,7 +236,7 @@ mkApp sparCtxOpts = do activationCodeTimeout = sparCtxOpts.settings.activationTimeout, blockedDomains = blockedDomains } - sparCtxHasqlPool <- Hasql.initPostgresPool (postgresql sparCtxOpts) (postgresqlPassword sparCtxOpts) + sparCtxHasqlPool <- Hasql.initPostgresPool (postgresqlPool sparCtxOpts) (postgresql sparCtxOpts) (postgresqlPassword sparCtxOpts) let sparCtxSmtp = Nothing -- Spar doesn't send emails directly sparCtxAws <- AWSI.mkEnv sparCtxLogger sparCtxOpts.aws Nothing sparCtxHttpManager sparCtxInternalEvents <- initInternalEvents sparCtxLogger sparCtxOpts sparCtxAws From 83e0035bd0bd9f0ef478310af53de51ff9713ee6 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Fri, 31 Oct 2025 23:25:34 +0100 Subject: [PATCH 03/30] fix: format --- libs/wire-subsystems/src/Wire/ConnectionStore.hs | 1 + services/brig/src/Brig/Run.hs | 2 +- services/spar/src/Spar/Options.hs | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ConnectionStore.hs b/libs/wire-subsystems/src/Wire/ConnectionStore.hs index f9c1cc979b..bd9b037beb 100644 --- a/libs/wire-subsystems/src/Wire/ConnectionStore.hs +++ b/libs/wire-subsystems/src/Wire/ConnectionStore.hs @@ -19,6 +19,7 @@ module Wire.ConnectionStore ( ConnectionStore (..), + -- * Operations insertConnection, updateConnection, diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index de03f1f89d..627fd00816 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -32,7 +32,6 @@ import Brig.Effects.UserPendingActivationStore qualified as UsersPendingActivati import Brig.InternalEvent.Process qualified as Internal import Brig.Options hiding (internalEvents) import Brig.Version -import Wire.DeleteQueue.Listen qualified as Queue import Control.Concurrent.Async qualified as Async import Control.Exception.Safe (catchAny) import Control.Lens ((.~)) @@ -71,6 +70,7 @@ import Wire.API.User (AccountStatus (PendingInvitation)) import Wire.AWSSubsystem qualified as AWS import Wire.AWSSubsystem.AWS qualified as AWSI import Wire.DeleteQueue +import Wire.DeleteQueue.Listen qualified as Queue import Wire.OpenTelemetry (withTracer) import Wire.PostgresMigrations import Wire.Sem.Paging qualified as P diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index c6ceaaab18..7c2ecf7ef6 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -40,9 +40,9 @@ import Data.Domain (Domain) import Data.Time import qualified Data.Yaml as Yaml import qualified Database.Bloodhound.Types as ES +import qualified Hasql.Pool.Extended as Hasql import Imports import qualified Network.AMQP.Extended as Q -import qualified Hasql.Pool.Extended as Hasql import Options.Applicative import SAML2.WebSSO import qualified SAML2.WebSSO as SAML From 5f0106c100b49b3ce3cad078fe5251e987577b11 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sat, 1 Nov 2025 12:36:36 +0100 Subject: [PATCH 04/30] fix: test & hlint --- libs/wire-subsystems/src/Wire/Events/Interpreter.hs | 2 -- services/brig/brig.cabal | 1 + services/brig/src/Brig/IO/Intra.hs | 2 -- .../brig}/test/resources/internal-notification.json | 0 services/brig/test/unit/Test/Brig/InternalNotification.hs | 2 +- services/spar/src/Spar/App.hs | 1 - 6 files changed, 2 insertions(+), 6 deletions(-) rename {libs/wire-subsystems => services/brig}/test/resources/internal-notification.json (100%) diff --git a/libs/wire-subsystems/src/Wire/Events/Interpreter.hs b/libs/wire-subsystems/src/Wire/Events/Interpreter.hs index d4436c0f90..9a2a1a75b4 100644 --- a/libs/wire-subsystems/src/Wire/Events/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/Events/Interpreter.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 8b834884f0..81294fd280 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -17,6 +17,7 @@ extra-source-files: docs/swagger-v4.json docs/swagger-v5.json docs/swagger.md + test/resources/internal-notification.json common common-all default-language: GHC2021 diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index e3d6dc26ca..f37070cc27 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/libs/wire-subsystems/test/resources/internal-notification.json b/services/brig/test/resources/internal-notification.json similarity index 100% rename from libs/wire-subsystems/test/resources/internal-notification.json rename to services/brig/test/resources/internal-notification.json diff --git a/services/brig/test/unit/Test/Brig/InternalNotification.hs b/services/brig/test/unit/Test/Brig/InternalNotification.hs index a7c80fb465..fed7ff008f 100644 --- a/services/brig/test/unit/Test/Brig/InternalNotification.hs +++ b/services/brig/test/unit/Test/Brig/InternalNotification.hs @@ -34,7 +34,7 @@ tests = checkGolden :: IO () checkGolden = do -- This file was generated from ToJSON of the format prior to 67993ab1 - ns <- BSL.readFile "../../../../libs/wire-subsystems/test/resources/internal-notification.json" + ns <- BSL.readFile "test/resources/internal-notification.json" let eith = A.eitherDecode @InternalNotification ns case eith of Left err -> assertFailure ("Could not parse InternalNotification: " <> show err) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index ef33968ed3..136bc218dd 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -- Disabling to stop warnings on HasCallStack {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} From 994da9f6ed6ec7c389bd341eedfeee2d6986386b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Nov 2025 09:25:06 +0100 Subject: [PATCH 05/30] Fix credential paths in spar.integration.yaml. --- services/spar/spar.integration.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 7ccc0e174c..429f847342 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -72,8 +72,8 @@ internalEvents: queueName: integration-brig-events-internal zauth: - privateKeys: test/resources/zauth/privkeys.txt - publicKeys: test/resources/zauth/pubkeys.txt + privateKeys: ../../libs/wire-subsystems/test/resources/zauth/privkeys.txt + publicKeys: ../../libs/wire-subsystems/test/resources/zauth/pubkeys.txt authSettings: keyIndex: 1 userTokenTimeout: 120 From 35704729e35e7337eebc4c5dba50bc97a69b6c41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Markus=20L=C3=A4ll?= Date: Fri, 31 Oct 2025 17:09:52 +0200 Subject: [PATCH 06/30] Fix paths in spar.integration.yaml --- services/spar/spar.integration.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 429f847342..4085731ebe 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -38,8 +38,8 @@ cassandra: elasticsearch: url: https://localhost:9200 index: directory_test_spar - credentials: test/resources/elasticsearch-credentials.yaml - caCert: test/resources/elasticsearch-ca.pem + credentials: ../../libs/wire-subsystems/test/resources/elasticsearch-credentials.yaml + caCert: ../../libs/wire-subsystems/test/resources/elasticsearch-ca.pem insecureSkipVerifyTls: false postgresql: From 9554bb42ef28b4cd0b300ca54336167eb9502cab Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Nov 2025 14:18:20 +0100 Subject: [PATCH 07/30] Fix json syntax in test. --- integration/test/Test/Spar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index adf8c240e0..fdf42bda06 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -375,8 +375,8 @@ testSparScimCreateUserGroup = do "displayName" .= "ze groop", "members" .= [ object - [ "typ" .= "User", - "$ref" .= "https://...", -- TODO: we should probably validate these? or just ignore them? + [ "type" .= "User", + "$ref" .= "https://example.org/v2/scim/User/ea2e4bf0-aa5e-11f0-96ad-e776a606779b", -- TODO: or something imilar. we should probably validate these? or just ignore them? "value" .= "ea2e4bf0-aa5e-11f0-96ad-e776a606779b" ] ] From 987e3fb532eb6a0dd092ff99c0d1488fbde158b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Markus=20L=C3=A4ll?= Date: Mon, 3 Nov 2025 14:42:57 +0200 Subject: [PATCH 08/30] Get queue name from integration-user-events.fifo --- libs/wire-subsystems/src/Wire/Events/Journal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/Events/Journal.hs b/libs/wire-subsystems/src/Wire/Events/Journal.hs index 94a8bbd424..db29d45ebb 100644 --- a/libs/wire-subsystems/src/Wire/Events/Journal.hs +++ b/libs/wire-subsystems/src/Wire/Events/Journal.hs @@ -104,7 +104,7 @@ journalEvent :: Maybe Name -> Sem r () journalEvent typ uid em loc tid nm = do - queueUrl <- AWS.getQueueUrl "user.events" + queueUrl <- AWS.getQueueUrl "integration-user-events.fifo" ts <- now rnd <- embed nextRandom let userEvent :: Proto.UserEvent = From 4fc1efd57bfdbdebebb446dab6ff36283cb4a09d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Nov 2025 15:16:18 +0100 Subject: [PATCH 09/30] Fix journal queue url computation (for real this time?) --- libs/wire-subsystems/src/Wire/AWSSubsystem.hs | 1 + .../src/Wire/AWSSubsystem/AWS.hs | 13 +++++++-- .../src/Wire/Events/Journal.hs | 29 ++++++++++--------- 3 files changed, 26 insertions(+), 17 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem.hs index 7df83ea0ed..57cce1a041 100644 --- a/libs/wire-subsystems/src/Wire/AWSSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem.hs @@ -47,6 +47,7 @@ data AWSSubsystem m r where a -> AWSSubsystem m (AWS.AWSResponse a) GetQueueUrl :: Text -> AWSSubsystem m Text + GetJournalQueueUrl :: AWSSubsystem m (Maybe Text) Listen :: forall a m. (FromJSON a, Show a) => Int -> Text -> (a -> m ()) -> AWSSubsystem m () EnqueueStandard :: Text -> BL.ByteString -> AWSSubsystem m SQS.SendMessageResponse EnqueueFIFO :: Text -> Text -> UUID -> BL.ByteString -> AWSSubsystem m SQS.SendMessageResponse diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs index 4607c7fb13..5f7bf9a403 100644 --- a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs @@ -240,6 +240,14 @@ runAwsRequestThrow e cmd = liftIO (runAwsRequest e cmd) >>= either (throwM . Gen retry5x :: (Monad m) => RetryPolicyM m retry5x = limitRetries 5 <> exponentialBackoff 100000 +getQueueUrlImpl :: Env -> Text -> IO Text +getQueueUrlImpl env queueName = do + resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) + pure $ view SQS.getQueueUrlResponse_queueUrl resp + +getJournalQueueUrlImpl :: Env -> IO (Maybe Text) +getJournalQueueUrlImpl env = forM (env ^. userJournalQueue) (getQueueUrlImpl env) + -------------------------------------------------------------------------------- -- Polysemy Interpreter @@ -253,9 +261,8 @@ runAWSSubsystem :: runAWSSubsystem env = interpretFinal $ \case RunAwsRequest x -> liftS @IO $ runAwsRequest env._amazonkaEnv x RunAwsRequestThrow x -> liftS @IO $ runAwsRequestThrow env._amazonkaEnv x - GetQueueUrl queueName -> liftS @IO $ do - resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) - pure $ view SQS.getQueueUrlResponse_queueUrl resp + GetQueueUrl queueName -> liftS @IO $ getQueueUrlImpl env queueName + GetJournalQueueUrl -> liftS @IO $ getJournalQueueUrlImpl env EnqueueStandard url message -> liftS $ do runResourceT $ runReaderT ((enqueueStandard url message).unAmazon) env EnqueueFIFO url group dedupId message -> liftS $ do diff --git a/libs/wire-subsystems/src/Wire/Events/Journal.hs b/libs/wire-subsystems/src/Wire/Events/Journal.hs index db29d45ebb..899ad39aef 100644 --- a/libs/wire-subsystems/src/Wire/Events/Journal.hs +++ b/libs/wire-subsystems/src/Wire/Events/Journal.hs @@ -104,20 +104,21 @@ journalEvent :: Maybe Name -> Sem r () journalEvent typ uid em loc tid nm = do - queueUrl <- AWS.getQueueUrl "integration-user-events.fifo" - ts <- now - rnd <- embed nextRandom - let userEvent :: Proto.UserEvent = - defMessage - & U.eventType .~ typ - & U.userId .~ toBytes uid - & U.utcTime .~ ts - & U.maybe'email .~ (toByteString' <$> em) - & U.maybe'locale .~ (pack . show <$> loc) - & U.maybe'teamId .~ (toBytes <$> tid) - & U.maybe'name .~ (toByteString' <$> nm) - encoded = fromStrict $ B64.encode $ encodeMessage userEvent - void $ AWS.enqueueFIFO queueUrl "user.events" rnd encoded + mbQueueUrl <- AWS.getJournalQueueUrl + forM_ mbQueueUrl $ \queueUrl -> do + ts <- now + rnd <- embed nextRandom + let userEvent :: Proto.UserEvent = + defMessage + & U.eventType .~ typ + & U.userId .~ toBytes uid + & U.utcTime .~ ts + & U.maybe'email .~ (toByteString' <$> em) + & U.maybe'locale .~ (pack . show <$> loc) + & U.maybe'teamId .~ (toBytes <$> tid) + & U.maybe'name .~ (toByteString' <$> nm) + encoded = fromStrict $ B64.encode $ encodeMessage userEvent + void $ AWS.enqueueFIFO queueUrl "user.events" rnd encoded -- | Journal a Wire.API.UserEvent by pattern matching on its constructors journalUserEvent :: From 9da14df8e981aa46117459172a5f057bec870571 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 3 Nov 2025 19:34:56 +0100 Subject: [PATCH 10/30] Gardening. --- .../src/Wire/AWSSubsystem/AWS.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs index 5f7bf9a403..01d666ae4d 100644 --- a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs @@ -149,6 +149,7 @@ mkEnv lgr opts emailOpts mgr = do --------------------------------------------------------- +-- | Variant of getQueueUrlImpl for calling during Env construction. getQueueUrl :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> @@ -156,6 +157,14 @@ getQueueUrl :: m Text getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> runAwsRequestThrow e (SQS.newGetQueueUrl q) +getQueueUrlImpl :: Env -> Text -> IO Text +getQueueUrlImpl env queueName = do + resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) + pure $ view SQS.getQueueUrlResponse_queueUrl resp + +getJournalQueueUrlImpl :: Env -> IO (Maybe Text) +getJournalQueueUrlImpl env = forM (env ^. userJournalQueue) (getQueueUrlImpl env) + listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO x) -> Amazon y listen throttleMillis url callback = forever . handleAny unexpectedError $ do msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> send receive @@ -240,14 +249,6 @@ runAwsRequestThrow e cmd = liftIO (runAwsRequest e cmd) >>= either (throwM . Gen retry5x :: (Monad m) => RetryPolicyM m retry5x = limitRetries 5 <> exponentialBackoff 100000 -getQueueUrlImpl :: Env -> Text -> IO Text -getQueueUrlImpl env queueName = do - resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) - pure $ view SQS.getQueueUrlResponse_queueUrl resp - -getJournalQueueUrlImpl :: Env -> IO (Maybe Text) -getJournalQueueUrlImpl env = forM (env ^. userJournalQueue) (getQueueUrlImpl env) - -------------------------------------------------------------------------------- -- Polysemy Interpreter From 2fe7c175c943a9635e8f846d634d8d207939ee49 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 08:49:48 +0100 Subject: [PATCH 11/30] Fix unit test; remove forgotten `focus`. --- .../unit/Wire/ScimSubsystem/InterpreterSpec.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 4cf2bbbab7..4cb4590aa3 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -74,7 +74,7 @@ mkScimGroupMember (idToText . User.userId -> value) = in Group.Member {..} spec :: Spec -spec = focus . UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do +spec = UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do describe "scimCreateUserGroup" $ do prop "creates a group returns it" $ \(team :: UGS.ArbitraryTeam) (newScimGroup_ :: Group.Group) -> let newScimGroup = @@ -94,15 +94,15 @@ spec = focus . UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do Right (createdGroup, retrievedGroup) -> Just createdGroup.thing.id === ((.id_) <$> retrievedGroup) - it "does not allow non-scim members" $ do - team :: UGS.ArbitraryTeam <- generate arbitrary - newScimGroup :: Group.Group <- do - generate arbitrary <&> \g -> g {Group.members = take 2 $ mkScimGroupMember <$> UGS.allUsers team} - let have = + prop "does not allow non-scim members" $ \team newScimGroup_ -> do + let newScimGroup = newScimGroup_ {Group.members = mkScimGroupMember <$> groupMembers} + groupMembers = take 2 (UGS.allUsers team) + have = runDependencies (UGS.allUsers team) (UGS.galleyTeam team) $ do scimCreateUserGroup team.tid newScimGroup + want = - if all (\u -> u.userManagedBy == ManagedByScim) (UGS.allUsers team) + if all (\u -> u.userManagedBy == ManagedByScim) groupMembers then isRight else isLeft unless (want have) do From 8ef035d03bc4c497971fd665b31a3020da51c8ae Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 11:08:21 +0100 Subject: [PATCH 12/30] Fix: queue url is already ready in Env, no need to compute it here. --- libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs index 01d666ae4d..7503df9f61 100644 --- a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs @@ -163,7 +163,7 @@ getQueueUrlImpl env queueName = do pure $ view SQS.getQueueUrlResponse_queueUrl resp getJournalQueueUrlImpl :: Env -> IO (Maybe Text) -getJournalQueueUrlImpl env = forM (env ^. userJournalQueue) (getQueueUrlImpl env) +getJournalQueueUrlImpl env = pure (env ^. userJournalQueue) listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO x) -> Amazon y listen throttleMillis url callback = forever . handleAny unexpectedError $ do From ac6af4b8cd7615b46ef01d5d597795415135fbaa Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 11:56:19 +0100 Subject: [PATCH 13/30] re-inline stuff. --- libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs index 7503df9f61..c17a7b07c3 100644 --- a/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs +++ b/libs/wire-subsystems/src/Wire/AWSSubsystem/AWS.hs @@ -157,14 +157,6 @@ getQueueUrl :: m Text getQueueUrl e q = view SQS.getQueueUrlResponse_queueUrl <$> runAwsRequestThrow e (SQS.newGetQueueUrl q) -getQueueUrlImpl :: Env -> Text -> IO Text -getQueueUrlImpl env queueName = do - resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) - pure $ view SQS.getQueueUrlResponse_queueUrl resp - -getJournalQueueUrlImpl :: Env -> IO (Maybe Text) -getJournalQueueUrlImpl env = pure (env ^. userJournalQueue) - listen :: (FromJSON a, Show a) => Int -> Text -> (a -> IO x) -> Amazon y listen throttleMillis url callback = forever . handleAny unexpectedError $ do msgs <- fromMaybe [] . view SQS.receiveMessageResponse_messages <$> send receive @@ -262,8 +254,10 @@ runAWSSubsystem :: runAWSSubsystem env = interpretFinal $ \case RunAwsRequest x -> liftS @IO $ runAwsRequest env._amazonkaEnv x RunAwsRequestThrow x -> liftS @IO $ runAwsRequestThrow env._amazonkaEnv x - GetQueueUrl queueName -> liftS @IO $ getQueueUrlImpl env queueName - GetJournalQueueUrl -> liftS @IO $ getJournalQueueUrlImpl env + GetQueueUrl queueName -> liftS @IO $ do + resp <- runResourceT $ AWS.send env._amazonkaEnv (SQS.newGetQueueUrl queueName) + pure $ view SQS.getQueueUrlResponse_queueUrl resp + GetJournalQueueUrl -> liftS $ pure (env ^. userJournalQueue) EnqueueStandard url message -> liftS $ do runResourceT $ runReaderT ((enqueueStandard url message).unAmazon) env EnqueueFIFO url group dedupId message -> liftS $ do From c4af06d5c3901a92a015fb08a5113824c01216e8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 17:03:24 +0100 Subject: [PATCH 14/30] Implement formerly undefined error type converters. --- libs/wire-subsystems/src/Wire/Error.hs | 33 +++++++++++-- .../test/unit/Wire/ErrorSpec.hs | 46 +++++++++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 2 + 3 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs diff --git a/libs/wire-subsystems/src/Wire/Error.hs b/libs/wire-subsystems/src/Wire/Error.hs index 8834dcca32..1ffd4deda0 100644 --- a/libs/wire-subsystems/src/Wire/Error.hs +++ b/libs/wire-subsystems/src/Wire/Error.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE RecordWildCards #-} + module Wire.Error where import Data.Aeson import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString qualified as BS +import Data.ByteString.UTF8 qualified as UTF8BS import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding (decodeUtf8With) +import Debug.Trace import Hasql.Pool import Imports import Network.HTTP.Types import Network.Wai.Utilities.Error qualified as Wai import Network.Wai.Utilities.JSONResponse -import Servant (ServerError) +import Servant (ServerError (..)) -- | Error thrown to the user data HttpError where @@ -29,6 +35,10 @@ instance Show HttpError where instance Exception HttpError +errorCode :: HttpError -> Status +errorCode (StdError e) = Wai.code e +errorCode (RichError e _ _) = Wai.code e + errorLabel :: HttpError -> LText errorLabel (StdError e) = Wai.label e errorLabel (RichError e _ _) = Wai.label e @@ -59,8 +69,25 @@ postgresUsageErrorToHttpError err = case err of ConnectionUsageError _ -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err)) AcquisitionTimeoutUsageError -> StdError (Wai.mkError status500 "server-error" (LT.pack $ "postgres: " <> show err)) +-- | Extract the wai error from an HttpError and convert into a +-- servant error. `RichError` extra data is discarded! httpErrorToServerError :: HttpError -> ServerError -httpErrorToServerError = undefined +httpErrorToServerError err = + ServerError + (statusCode $ errorCode err) + (UTF8BS.toString $ statusMessage $ errorCode err) + (encode err) + [] +-- | Construct a StdError from a servant error. serverErrorToHttpError :: ServerError -> HttpError -serverErrorToHttpError = undefined +serverErrorToHttpError ServerError {..} = + StdError $ + Wai.mkError + (Status errHTTPCode (UTF8BS.fromString errReasonPhrase)) + lbl + msg + where + (lbl, msg) = case decode @Wai.Error errBody of + Just err -> (err.label :: LText, err.message :: LText) + Nothing -> ("unknown-error", decodeUtf8With lenientDecode errBody) -- just make something up. diff --git a/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs b/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs new file mode 100644 index 0000000000..b093bfac14 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Wire.ErrorSpec (spec) where + +import Data.Aeson +import Data.ByteString.UTF8 qualified as UTF8BS +import Data.Text.Lazy qualified as LT +import Imports +import Network.HTTP.Types +import Network.Wai.Utilities.Error qualified as Wai +import Servant +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.Error + +spec :: Spec +spec = describe "httpErrorToServerError, serverErrorToHttpError" do + prop "serverErrorToHttpError == httpErrorToServerError^(-1) (kinda)" $ \waiError -> + let httpError = StdError waiError + in serverErrorToHttpError (httpErrorToServerError httpError) === httpError + + prop "httpErrorToServerError == serverErrorToHttpError^(-1)" $ \serverError -> + httpErrorToServerError (serverErrorToHttpError serverError) === serverError + + prop "servant error not containing a wai error in its body" $ \serverError_ -> + let serverError = serverError_ {errBody = "..."} + in httpErrorToServerError (serverErrorToHttpError serverError) === serverError + +instance Arbitrary ServerError where + -- headers are lost in translation + arbitrary = + ServerError + <$> (abs <$> arbitrary) + <*> arbitrary + <*> (encode <$> (arbitrary @Wai.Error)) + <*> pure [] + shrink _ = [] + +instance Arbitrary Wai.Error where + arbitrary = + Wai.mkError + <$> (Status <$> (abs <$> arbitrary) <*> (UTF8BS.fromString <$> arbitrary)) + <*> (LT.pack <$> arbitrary) + <*> (LT.pack <$> arbitrary) + shrink _ = [] diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 76f5fbafe4..42480a8a7b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -171,6 +171,7 @@ common common-all , unliftio , unordered-containers , uri-bytestring + , utf8-string , uuid , vector , wai-utilities @@ -439,6 +440,7 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.BrigAPIAccess.RpcSpec Wire.EnterpriseLoginSubsystem.InterpreterSpec + Wire.ErrorSpec Wire.HashPassword.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters From 94a875489c65e9a7171a7bca370f10cc0d87a5ff Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 17:19:19 +0100 Subject: [PATCH 15/30] Fixup --- libs/wire-subsystems/src/Wire/Error.hs | 8 ++++++-- libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs | 15 +++++++-------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Error.hs b/libs/wire-subsystems/src/Wire/Error.hs index 1ffd4deda0..ee34abec9d 100644 --- a/libs/wire-subsystems/src/Wire/Error.hs +++ b/libs/wire-subsystems/src/Wire/Error.hs @@ -11,7 +11,7 @@ import Data.Text.Encoding qualified as Text import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding (decodeUtf8With) -import Debug.Trace +import Data.Text.Lazy.Encoding qualified as LText import Hasql.Pool import Imports import Network.HTTP.Types @@ -43,6 +43,10 @@ errorLabel :: HttpError -> LText errorLabel (StdError e) = Wai.label e errorLabel (RichError e _ _) = Wai.label e +errorMessage :: HttpError -> LText +errorMessage (StdError e) = Wai.message e +errorMessage (RichError e _ _) = Wai.message e + instance ToJSON HttpError where toJSON (StdError e) = toJSON e toJSON (RichError e x _) = case (toJSON e, toJSON x) of @@ -76,7 +80,7 @@ httpErrorToServerError err = ServerError (statusCode $ errorCode err) (UTF8BS.toString $ statusMessage $ errorCode err) - (encode err) + (if errorLabel err == "unknown-error" then LText.encodeUtf8 (errorMessage err) else encode err) [] -- | Construct a StdError from a servant error. diff --git a/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs b/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs index b093bfac14..3f38ab0ca1 100644 --- a/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ErrorSpec.hs @@ -27,15 +27,15 @@ spec = describe "httpErrorToServerError, serverErrorToHttpError" do let serverError = serverError_ {errBody = "..."} in httpErrorToServerError (serverErrorToHttpError serverError) === serverError +-- there are a lot of contraints for the ""isomorphism"" to work! here are the instances. + instance Arbitrary ServerError where -- headers are lost in translation - arbitrary = - ServerError - <$> (abs <$> arbitrary) - <*> arbitrary - <*> (encode <$> (arbitrary @Wai.Error)) - <*> pure [] - shrink _ = [] + arbitrary = do + code <- abs <$> arbitrary + phrase <- arbitrary + waiErr <- (arbitrary @Wai.Error) <&> \e -> e {Wai.code = e.code {statusCode = code}} + pure $ ServerError code phrase (encode waiErr) [] instance Arbitrary Wai.Error where arbitrary = @@ -43,4 +43,3 @@ instance Arbitrary Wai.Error where <$> (Status <$> (abs <$> arbitrary) <*> (UTF8BS.fromString <$> arbitrary)) <*> (LT.pack <$> arbitrary) <*> (LT.pack <$> arbitrary) - shrink _ = [] From 3776fbe9899ce4fc29bed7393a9af27d5d333ce6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 4 Nov 2025 17:25:10 +0100 Subject: [PATCH 16/30] Cleanup --- libs/wire-subsystems/src/Wire/Error.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/Error.hs b/libs/wire-subsystems/src/Wire/Error.hs index ee34abec9d..f181833477 100644 --- a/libs/wire-subsystems/src/Wire/Error.hs +++ b/libs/wire-subsystems/src/Wire/Error.hs @@ -35,17 +35,12 @@ instance Show HttpError where instance Exception HttpError -errorCode :: HttpError -> Status -errorCode (StdError e) = Wai.code e -errorCode (RichError e _ _) = Wai.code e +httpErrorToWaiError :: HttpError -> Wai.Error +httpErrorToWaiError (StdError e) = e +httpErrorToWaiError (RichError e _ _) = e errorLabel :: HttpError -> LText -errorLabel (StdError e) = Wai.label e -errorLabel (RichError e _ _) = Wai.label e - -errorMessage :: HttpError -> LText -errorMessage (StdError e) = Wai.message e -errorMessage (RichError e _ _) = Wai.message e +errorLabel = (.label) . httpErrorToWaiError instance ToJSON HttpError where toJSON (StdError e) = toJSON e @@ -78,9 +73,12 @@ postgresUsageErrorToHttpError err = case err of httpErrorToServerError :: HttpError -> ServerError httpErrorToServerError err = ServerError - (statusCode $ errorCode err) - (UTF8BS.toString $ statusMessage $ errorCode err) - (if errorLabel err == "unknown-error" then LText.encodeUtf8 (errorMessage err) else encode err) + (statusCode (httpErrorToWaiError err).code) + (UTF8BS.toString $ statusMessage $ (httpErrorToWaiError err).code) + ( if (httpErrorToWaiError err).label == "unknown-error" + then LText.encodeUtf8 (httpErrorToWaiError err).message + else encode err + ) [] -- | Construct a StdError from a servant error. From 5bd03f0ed296de383391c8efd232b6af71c3d168 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Tue, 4 Nov 2025 22:04:01 +0100 Subject: [PATCH 17/30] refactor: move to brigapiaccess --- .../src/Data/HavePendingInvitations.hs | 7 + .../src/Wire/API/Routes/Internal/Brig.hs | 86 ++++++- libs/wire-subsystems/default.nix | 3 + .../wire-subsystems/src/Wire/BrigAPIAccess.hs | 8 + .../src/Wire/BrigAPIAccess/Rpc.hs | 46 ++++ .../src/Wire/ScimSubsystem/Interpreter.hs | 27 ++- .../wire-subsystems/src/Wire/UserSubsystem.hs | 17 +- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- .../Wire/MockInterpreters/UserSubsystem.hs | 2 +- .../Wire/ScimSubsystem/InterpreterSpec.hs | 29 +++ services/brig/src/Brig/API/Internal.hs | 30 +++ services/spar/default.nix | 3 - services/spar/spar.cabal | 2 - .../spar/src/Spar/CanonicalInterpreter.hs | 228 +++--------------- tools/stern/src/Stern/Intra.hs | 6 +- 15 files changed, 268 insertions(+), 228 deletions(-) diff --git a/libs/types-common/src/Data/HavePendingInvitations.hs b/libs/types-common/src/Data/HavePendingInvitations.hs index 03afbe6c77..e72185c2b2 100644 --- a/libs/types-common/src/Data/HavePendingInvitations.hs +++ b/libs/types-common/src/Data/HavePendingInvitations.hs @@ -1,5 +1,8 @@ module Data.HavePendingInvitations where +import Data.Aeson (FromJSON, ToJSON) +import Data.OpenApi qualified as S +import Data.Schema import Imports import Wire.Arbitrary @@ -8,6 +11,10 @@ data HavePendingInvitations | NoPendingInvitations deriving (Eq, Show, Ord, Generic) deriving (Arbitrary) via GenericUniform HavePendingInvitations + deriving (FromJSON, ToJSON, S.ToSchema) via Schema HavePendingInvitations + +instance ToSchema HavePendingInvitations where + schema = enum @Bool "HavePendingInvitations" $ mconcat [element True WithPendingInvitations, element False NoPendingInvitations] fromBool :: Bool -> HavePendingInvitations fromBool True = WithPendingInvitations diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index a2f8fe68e6..a3cae52f18 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -35,6 +35,8 @@ module Wire.API.Routes.Internal.Brig PutAccountConferenceCallingConfig, DeleteAccountConferenceCallingConfig, GetRichInfoMultiResponse (..), + GetBy (..), + CreateGroupFullRequest (..), swaggerDoc, module Wire.API.Routes.Internal.Brig.EJPD, FoundInvitationCode (..), @@ -43,20 +45,23 @@ module Wire.API.Routes.Internal.Brig where import Control.Lens ((.~), (?~)) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON, Value (Null)) import Data.Code qualified as Code import Data.CommaSeparatedList +import Data.Default (Default (..)) import Data.Domain (Domain) import Data.Handle (Handle) +import Data.HavePendingInvitations (HavePendingInvitations (..)) import Data.Id as Id import Data.Misc (PlainTextPassword8) import Data.OpenApi (HasInfo (info), HasTitle (title), OpenApi) import Data.OpenApi qualified as S -import Data.Qualified (Qualified) +import Data.Qualified (Qualified, qualifiedSchema) import Data.Schema hiding (swaggerDoc) import Data.Text qualified as Text import GHC.TypeLits import Imports hiding (head) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) import Network.HTTP.Client qualified as HTTP import Servant hiding (Handler, addHeader, respond) import Servant.Client qualified as Servant @@ -91,6 +96,61 @@ import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.API.User.Client import Wire.API.User.RichInfo +import Wire.API.UserGroup (NewUserGroup, UserGroup) + +-- | Parameters for getting user accounts by various criteria +data GetBy = GetBy + { includePendingInvitations :: HavePendingInvitations, + getByUserId :: [UserId], + getByHandle :: [Handle] + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform GetBy + deriving (FromJSON, ToJSON, S.ToSchema) via Schema GetBy + +instance Default GetBy where + def = + GetBy + { includePendingInvitations = NoPendingInvitations, + getByUserId = [], + getByHandle = [] + } + +instance ToSchema GetBy where + schema = + object "GetBy" $ + GetBy + <$> (.includePendingInvitations) .= field "include_pending_invitations" schema + <*> (.getByUserId) .= field "ids" (array schema) + <*> (.getByHandle) .= field "handles" (array schema) + +instance ToSchema (Qualified GetBy) where + schema = qualifiedSchema "GetBy" "get_by" schema + +deriving via (Schema (Qualified GetBy)) instance FromJSON (Qualified GetBy) + +deriving via (Schema (Qualified GetBy)) instance ToJSON (Qualified GetBy) + +deriving via (Schema (Qualified GetBy)) instance S.ToSchema (Qualified GetBy) + +-- | Request type for creating user groups with full control +data CreateGroupFullRequest = CreateGroupFullRequest + { managedBy :: ManagedBy, + teamId :: TeamId, + creatorUserId :: Maybe UserId, + newGroup :: NewUserGroup + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema CreateGroupFullRequest + +instance ToSchema CreateGroupFullRequest where + schema = + object "CreateGroupFullRequest" $ + CreateGroupFullRequest + <$> (.managedBy) .= field "managed_by" schema + <*> (.teamId) .= field "team_id" schema + <*> (.creatorUserId) .= optField "creator_user_id" (maybeWithDefault Null schema) + <*> (.newGroup) .= field "new_group" schema type EJPDRequest = Named @@ -163,6 +223,26 @@ type GetAllConnections = :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2 :> Post '[Servant.JSON] [ConnectionStatusV2] +type GetAccountsByInternal = + Named + "i-get-accounts-by" + ( Summary "Get user accounts by various criteria (internal)" + :> "users" + :> "accounts-by" + :> ReqBody '[Servant.JSON] (Qualified GetBy) + :> Post '[Servant.JSON] [User] + ) + +type CreateGroupFullInternal = + Named + "i-create-group-full" + ( Summary "Create user group with full control (internal)" + :> "user-groups" + :> "full" + :> ReqBody '[Servant.JSON] CreateGroupFullRequest + :> Post '[Servant.JSON] UserGroup + ) + type AccountAPI = Named "get-account-conference-calling-config" GetAccountConferenceCallingConfig :<|> Named "i-put-account-conference-calling-config" PutAccountConferenceCallingConfig @@ -469,6 +549,8 @@ type AccountAPI = :> Capture "uid" UserId :> Delete '[Servant.JSON] NoContent ) + :<|> GetAccountsByInternal + :<|> CreateGroupFullInternal -- | The missing ref is implicit by the capture data NewKeyPackageRef = NewKeyPackageRef diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 1f3f362676..41365a4485 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -109,6 +109,7 @@ , unliftio , unordered-containers , uri-bytestring +, utf8-string , uuid , vector , wai @@ -223,6 +224,7 @@ mkDerivation { unliftio unordered-containers uri-bytestring + utf8-string uuid vector wai-utilities @@ -333,6 +335,7 @@ mkDerivation { unliftio unordered-containers uri-bytestring + utf8-string uuid vector wai diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index 95a9036a43..80370ba57f 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -20,6 +20,7 @@ module Wire.BrigAPIAccess getRichInfoMultiUser, getUserExportData, updateSearchIndex, + getAccountsBy, -- * Teams getSize, @@ -43,6 +44,9 @@ module Wire.BrigAPIAccess -- * Bots deleteBot, + + -- * User Groups + createGroupFull, ) where @@ -58,6 +62,7 @@ import Polysemy.Error import Wire.API.Connection import Wire.API.Error.Galley import Wire.API.MLS.CipherSuite +import Wire.API.Routes.Internal.Brig (GetBy) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export @@ -68,6 +73,7 @@ import Wire.API.User.Auth.ReAuth import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.RichInfo +import Wire.API.UserGroup (NewUserGroup, UserGroup) -- | When receiving tokens from other services which are 'just passing through' -- it's error-prone useless extra work to parse and render them from JSON over and over again. @@ -124,6 +130,8 @@ data BrigAPIAccess m a where GetUserExportData :: UserId -> BrigAPIAccess m (Maybe TeamExportUser) DeleteBot :: ConvId -> BotId -> BrigAPIAccess m () UpdateSearchIndex :: UserId -> BrigAPIAccess m () + GetAccountsBy :: Local GetBy -> BrigAPIAccess m [User] + CreateGroupFull :: ManagedBy -> TeamId -> Maybe UserId -> NewUserGroup -> BrigAPIAccess m UserGroup makeSem ''BrigAPIAccess diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index 2d23fe14d7..328fecc7aa 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -26,6 +26,7 @@ import Web.HttpApiData import Wire.API.Connection import Wire.API.Error.Galley import Wire.API.MLS.CipherSuite +import Wire.API.Routes.Internal.Brig (CreateGroupFullRequest (..), GetBy) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export @@ -37,7 +38,9 @@ import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Client import Wire.API.User.Client.Prekey +import Wire.API.User.Profile (ManagedBy) import Wire.API.User.RichInfo +import Wire.API.UserGroup (NewUserGroup, UserGroup) import Wire.BrigAPIAccess (BrigAPIAccess (..), OpaqueAuthToken (..)) import Wire.ParseException import Wire.Rpc @@ -98,6 +101,10 @@ interpretBrigAccess brigEndpoint = DeleteBot convId botId -> deleteBot convId botId UpdateSearchIndex uid -> updateSearchIndex uid + GetAccountsBy localGetBy -> + getAccountsBy localGetBy + CreateGroupFull managedBy teamId creatorUserId newGroup -> + createGroupFull managedBy teamId creatorUserId newGroup brigRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) brigRequest req = do @@ -509,3 +516,42 @@ updateSearchIndex uid = do method POST . paths ["i", "index", "update", toByteString' uid] . expect2xx + +-- | Calls 'Brig.API.Internal.getAccountsByInternalH'. +getAccountsBy :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Local GetBy -> + Sem r [User] +getAccountsBy localGetBy = do + let qualifiedGetBy = tUntagged localGetBy + r <- + brigRequest $ + method POST + . path "/i/users/accounts-by" + . json qualifiedGetBy + . expect2xx + decodeBodyOrThrow "brig" r + +-- | Calls 'Brig.API.Internal.createGroupFullInternalH'. +createGroupFull :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + ManagedBy -> + TeamId -> + Maybe UserId -> + NewUserGroup -> + Sem r UserGroup +createGroupFull managedBy teamId creatorUserId newGroup = do + let req = + CreateGroupFullRequest + { managedBy, + teamId, + creatorUserId, + newGroup + } + r <- + brigRequest $ + method POST + . path "/i/user-groups/full" + . json req + . expect2xx + decodeBodyOrThrow "brig" r diff --git a/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs index aecb43402d..f0b772556a 100644 --- a/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs @@ -19,8 +19,9 @@ import Web.Scim.Schema.ResourceType qualified as RT import Wire.API.User import Wire.API.User.Scim (SparTag) import Wire.API.UserGroup +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.BrigAPIAccess qualified as BrigAPI import Wire.ScimSubsystem -import Wire.UserGroupSubsystem import Wire.UserSubsystem data ScimSubsystemConfig = ScimSubsystemConfig @@ -28,11 +29,10 @@ data ScimSubsystemConfig = ScimSubsystemConfig } interpretScimSubsystem :: - ( Member UserGroupSubsystem r, - Member (Input ScimSubsystemConfig) r, + ( Member (Input ScimSubsystemConfig) r, Member (Error ScimSubsystemError) r, - Member UserSubsystem r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member BrigAPIAccess r ) => InterpreterFor ScimSubsystem r interpretScimSubsystem = interpret $ \case @@ -49,11 +49,10 @@ scimThrow = throw . ScimSubsystemError createScimGroupImpl :: forall r. - ( Member UserGroupSubsystem r, - Member (Input ScimSubsystemConfig) r, + ( Member (Input ScimSubsystemConfig) r, Member (Error ScimSubsystemError) r, - Member UserSubsystem r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member BrigAPIAccess r ) => TeamId -> SCG.Group -> @@ -65,9 +64,11 @@ createScimGroupImpl teamId grp = do let thrw = throw . ScimSubsystemInvalidGroupMemberId in forM uidsAsText $ either (thrw . Text.pack) pure . parseIdFromText getby :: Local GetBy <- inputQualifyLocal def {getByUserId = uids} - getAccountsBy getby - <&> filter (\u -> u.userManagedBy /= ManagedByScim) - <&> fmap userId + users <- BrigAPI.getAccountsBy getby + pure $ + users + & filter (\u -> u.userManagedBy /= ManagedByScim) + & fmap userId unless (null membersNotManagedByScim) do throw (ScimSubsystemScimGroupWithNonScimMembers membersNotManagedByScim) @@ -82,7 +83,7 @@ createScimGroupImpl teamId grp = do in go `mapM` grp.members let newGroup = NewUserGroup {name = ugName, members = V.fromList ugMemberIds} - ug <- createGroupFull ManagedByScim teamId Nothing newGroup + ug <- BrigAPI.createGroupFull ManagedByScim teamId Nothing newGroup ScimSubsystemConfig scimBaseUri <- input pure $ toStoredGroup scimBaseUri ug diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index df9f2f768f..9924eddfc2 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -4,6 +4,7 @@ module Wire.UserSubsystem ( module Wire.UserSubsystem, module Data.HavePendingInvitations, + GetBy (..), ) where @@ -32,6 +33,7 @@ import Wire.API.Team.Member (IsPerm (..), TeamMember) import Wire.API.User import Wire.API.User.Activation import Wire.API.User.IdentityProvider hiding (team) +import Wire.API.Routes.Internal.Brig (GetBy (..)) import Wire.API.User.Search import Wire.ActivationCodeStore import Wire.Arbitrary @@ -91,21 +93,6 @@ instance Default UserProfileUpdate where supportedProtocols = Nothing } --- | Parameters for `getExternalAccountsBy` operation below. -data GetBy = MkGetBy - { -- | whether or not to include pending invitations when getting users by ids. - includePendingInvitations :: HavePendingInvitations, - -- | get accounts by 'UserId'. - getByUserId :: [UserId], - -- | get accounts by their 'Handle' - getByHandle :: [Handle] - } - deriving stock (Eq, Ord, Show, Generic) - deriving (Arbitrary) via GenericUniform GetBy - -instance Default GetBy where - def = MkGetBy NoPendingInvitations [] [] - -- | Outcome of email change invariant checks. data ChangeEmailResult = -- | The request was successful, user needs to verify the new email address diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index af2fd6dfe7..a867baa79a 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -976,7 +976,7 @@ getAccountsByImpl :: ) => Local GetBy -> Sem r [User] -getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByHandle, getByUserId})) = do +getAccountsByImpl (tSplit -> (domain, GetBy {includePendingInvitations, getByHandle, getByUserId})) = do storedToExtAcc <- do config <- input pure $ mkUserFromStored domain config.defaultLocale diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 5007192df5..0b2a03bee0 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -27,7 +27,7 @@ userSubsystemTestInterpreter initialUsers = GetLocalUserProfiles luids -> let uids = qUnqualified $ tUntagged luids in pure (toProfile <$> filter (\u -> userId u `elem` uids) initialUsers) - GetAccountsBy (tUnqualified -> MkGetBy NoPendingInvitations uids []) -> + GetAccountsBy (tUnqualified -> GetBy NoPendingInvitations uids []) -> pure (filter (\u -> userId u `elem` uids) initialUsers) GetAccountsBy _ -> error "GetAccountsBy: implement on demand (userSubsystemInterpreter)" GetAccountNoFilter _ -> error "GetAccountNoFilter: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 4cb4590aa3..2c6adf1678 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -4,7 +4,10 @@ module Wire.ScimSubsystem.InterpreterSpec (spec) where import Data.Id +import Data.Json.Util (toUTCTimeMillis) +import Data.Qualified import Data.Text qualified as Text +import Data.UUID qualified as UUID import Imports import Network.URI import Polysemy @@ -17,10 +20,12 @@ import Test.QuickCheck import Web.Scim.Class.Group qualified as Group import Web.Scim.Schema.Common qualified as Common import Web.Scim.Schema.Meta qualified as Common +import Wire.API.Routes.Internal.Brig (GetBy (..)) import Wire.API.Team.Member as TM import Wire.API.User as User import Wire.API.User.Scim import Wire.API.UserGroup +import Wire.BrigAPIAccess (BrigAPIAccess (..)) import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter import Wire.UserGroupSubsystem qualified as UGS @@ -31,6 +36,7 @@ type AllDependencies = [ ScimSubsystem, Input ScimSubsystemConfig, Error ScimSubsystemError, + BrigAPIAccess, UGS.UserGroupSubsystem ] `Append` UGS.AllDependencies @@ -45,6 +51,7 @@ runDependencies initialUsers initialTeams = run . lowerLevelStuff . UGS.interpretUserGroupSubsystem + . mockBrigAPIAccess initialUsers . runError . runInputConst (ScimSubsystemConfig scimBaseUri) . interpretScimSubsystem @@ -57,6 +64,28 @@ runDependencies initialUsers initialTeams = where crashOnLowerErrors = fmap (either (error . show) id) . runError + -- Mock BrigAPIAccess interpreter for tests + mockBrigAPIAccess :: [User] -> InterpreterFor BrigAPIAccess r + mockBrigAPIAccess users = interpret $ \case + GetAccountsBy localGetBy -> do + let getBy = tUnqualified localGetBy + pure $ filter (\u -> User.userId u `elem` getBy.getByUserId) users + CreateGroupFull managedBy _teamId _creatorUserId newGroup -> do + -- For tests, just create a minimal UserGroup + let gid = Id UUID.nil -- Using nil UUID for tests + pure $ + UserGroup_ + { id_ = gid, + name = newGroup.name, + members = Identity newGroup.members, + membersCount = Nothing, + channels = Nothing, + channelsCount = Nothing, + managedBy = managedBy, + createdAt = toUTCTimeMillis (read "2024-01-01 00:00:00 UTC") + } + _ -> error "Unimplemented BrigAPIAccess operation in mock" + instance Arbitrary Group.Group where arbitrary = do name <- Text.pack . take 4000 <$> ((:) <$> arbitrary <*> arbitrary) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 28f922736a..d86af1ed5a 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -84,6 +84,7 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Federation.Error (FederationError (..)) import Wire.API.MLS.CipherSuite import Wire.API.Routes.FederationDomainConfig +import Wire.API.Routes.Internal.Brig (CreateGroupFullRequest (..)) import Wire.API.Routes.Internal.Brig qualified as BrigIRoutes import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named @@ -94,6 +95,7 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserEvent +import Wire.API.UserGroup (UserGroup) import Wire.ActivationCodeStore (ActivationCodeStore) import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig) @@ -282,6 +284,8 @@ accountAPI = :<|> Named @"iAddClient" addClientInternalH :<|> Named @"iLegalholdAddClient" legalHoldClientRequestedH :<|> Named @"iLegalholdDeleteClient" removeLegalHoldClientH + :<|> Named @"i-get-accounts-by" getAccountsByInternalH + :<|> Named @"i-create-group-full" createGroupFullInternalH teamsAPI :: ( Member GalleyAPIAccess r, @@ -983,3 +987,29 @@ getUserExportDataH :: UserId -> Handler r (Maybe TeamExportUser) getUserExportDataH = lift . liftSem . getUserExportData + +getAccountsByInternalH :: + ( Member UserSubsystem r, + Member (Input (Local ())) r + ) => + Qualified GetBy -> + Handler r [User] +getAccountsByInternalH qGetBy = case qGetBy of + Qualified getByData domain -> do + loc <- lift $ liftSem input + if tDomain loc == domain + then lift . liftSem $ getAccountsBy (qualifyAs loc getByData) + else throwStd (errorToWai @'E.InvalidUser) + +createGroupFullInternalH :: + ( Member UserGroupSubsystem r + ) => + CreateGroupFullRequest -> + Handler r UserGroup +createGroupFullInternalH req = + lift . liftSem $ + createGroupFull + req.managedBy + req.teamId + req.creatorUserId + req.newGroup diff --git a/services/spar/default.nix b/services/spar/default.nix index ddf82c585e..9fad496dd6 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -81,7 +81,6 @@ , wai-utilities , warp , wire-api -, wire-api-federation , wire-subsystems , xml-conduit , yaml @@ -150,10 +149,8 @@ mkDerivation { wai-utilities warp wire-api - wire-api-federation wire-subsystems yaml - zauth ]; executableHaskellDepends = [ aeson diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 96a3d0d45b..2bf83cf330 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -208,10 +208,8 @@ library , wai-utilities , warp , wire-api - , wire-api-federation , wire-subsystems , yaml - , zauth default-language: Haskell2010 diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 04b078b096..19d3513d26 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -29,7 +29,6 @@ import Control.Exception (ErrorCall (..)) import Control.Lens ((^.)) import Control.Monad.Except hiding (mapError) import Data.Qualified -import Data.ZAuth.CryptoSign (CryptoSign, runCryptoSign) import qualified Hasql.Pool as Hasql import Imports import Polysemy @@ -76,143 +75,94 @@ import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSpa import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog -import Wire.API.Federation.Client -import Wire.API.Federation.Error import Wire.API.User.Saml import Wire.AWSSubsystem (AWSSubsystem) import Wire.AWSSubsystem.AWS (runAWSSubsystem) import qualified Wire.AWSSubsystem.AWS as AWSI -import Wire.AppStore -import Wire.AppStore.Postgres -import Wire.AuthenticationSubsystem -import Wire.AuthenticationSubsystem.Config -import Wire.AuthenticationSubsystem.Error -import Wire.AuthenticationSubsystem.Interpreter -import Wire.BlockListStore -import Wire.BlockListStore.Cassandra (interpretBlockListStoreToCassandra) -import Wire.ConnectionStore (ConnectionStore) -import Wire.ConnectionStore.Cassandra (connectionStoreToCassandra) -import Wire.DeleteQueue -import Wire.DeleteQueue.Interpreter (runDeleteQueue) -import Wire.DomainRegistrationStore -import Wire.DomainRegistrationStore.Cassandra (interpretDomainRegistrationStoreToCassandra) +import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) import Wire.EmailSending (EmailSending) import Wire.EmailSending.Core (EmailSendingInterpreterConfig (EmailSendingInterpreterConfig), emailSendingInterpreter) -import Wire.EmailSubsystem -import Wire.EmailSubsystem.Interpreter (emailSubsystemInterpreter) import Wire.Error -import Wire.Events -import Wire.Events.Interpreter (runEvents) -import Wire.FederationAPIAccess -import Wire.FederationAPIAccess.Interpreter (interpretFederationAPIAccess) -import Wire.FederationConfigStore -import Wire.FederationConfigStore.Cassandra (interpretFederationDomainConfig) import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.GundeckAPIAccess -import Wire.HashPassword -import Wire.HashPassword.Interpreter (runHashPassword) -import Wire.IndexedUserStore -import Wire.IndexedUserStore.ElasticSearch (interpretIndexedUserStoreES) -import Wire.InvitationStore -import Wire.InvitationStore.Cassandra (interpretInvitationStoreToCassandra) import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter import Wire.ParseException (ParseException, parseExceptionToHttpError) -import Wire.PasswordResetCodeStore -import Wire.PasswordResetCodeStore.Cassandra (passwordResetCodeStoreToCassandra) -import Wire.PasswordStore (PasswordStore) -import Wire.PasswordStore.Cassandra (interpretPasswordStore) import Wire.RateLimit -import Wire.RateLimit.Interpreter (interpretRateLimit) import Wire.Rpc (Rpc, runRpcWithHttp) import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter -import Wire.Sem.Concurrency -import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Delay import Wire.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) -import Wire.Sem.Metrics -import Wire.Sem.Metrics.IO (runMetricsToIO) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIO) -import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.Sem.Random (Random) import Wire.Sem.Random.IO (randomToIO) -import Wire.SessionStore -import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) import Wire.TeamSubsystem import Wire.TeamSubsystem.GalleyAPI import Wire.UserGroupStore import qualified Wire.UserGroupStore as Store import Wire.UserGroupStore.Postgres -import Wire.UserGroupSubsystem import Wire.UserGroupSubsystem.Interpreter -import Wire.UserKeyStore -import Wire.UserKeyStore.Cassandra (interpretUserKeyStoreCassandra) import Wire.UserStore import Wire.UserStore.Cassandra -import Wire.UserSubsystem (UserSubsystem) -import Wire.UserSubsystem.Error -import Wire.UserSubsystem.Interpreter type CanonicalEffs = - '[ScimSubsystem, UserGroupSubsystem, UserSubsystem, AuthenticationSubsystem] + '[ScimSubsystem] `Append` LowerLevelCanonicalEffs type LowerLevelCanonicalEffs = - '[ SAML2, + '[ BrigAPIAccess, + SAML2, SamlProtocolSettings, AssIDStore, AReqIDStore, VerdictFormatStore, Error UserGroupSubsystemError, Store.UserGroupStore, - Events, AWSSubsystem, NotificationSubsystem, GundeckAPIAccess, P.Async, Delay, TeamSubsystem, - GalleyAPIAccess + GalleyAPIAccess, + Error ErrorCall, + Error ParseException, + Rpc, + Input (Local ()), + Input ScimSubsystemConfig, + Error ScimSubsystemError, + ScimExternalIdStore, + ScimUserTimesStore, + ScimTokenStore, + DefaultSsoCode, + IdPConfigStore, + IdPRawMetadataStore, + SAMLUserStore, + Embed Cas.Client, + BrigAccess, + GalleyAccess, + UserStore, + Error RateLimitExceeded, + Error IdpDbError, + Error TTLError, + Input Hasql.Pool, + Error Hasql.UsageError, + Error SparError, + Reporter, + EmailSending, + Logger String, + Logger (TinyLog.Msg -> TinyLog.Msg), + Input Opts, + Input TinyLog.Logger, + Random, + Now, + Embed IO, + Final IO ] - `Append` AuthSubsystemLowerEffects - `Append` UserSubsystemLowerEffects - `Append` '[ Error ErrorCall, - Error ParseException, - Rpc, - Input (Local ()), - Input ScimSubsystemConfig, - Error ScimSubsystemError, - ScimExternalIdStore, - ScimUserTimesStore, - ScimTokenStore, - DefaultSsoCode, - IdPConfigStore, - IdPRawMetadataStore, - SAMLUserStore, - Embed Cas.Client, - BrigAccess, - GalleyAccess, - UserStore, - Error RateLimitExceeded, - Error IdpDbError, - Error TTLError, - Input Hasql.Pool, - Error Hasql.UsageError, - Error SparError, - Reporter, - EmailSending, - Logger String, - Logger (TinyLog.Msg -> TinyLog.Msg), - Input Opts, - Input TinyLog.Logger, - Random, - Now, - Embed IO, - Final IO - ] runSparToIO :: Env -> Sem CanonicalEffs a -> IO (Either SparError a) runSparToIO ctx = @@ -249,8 +199,6 @@ runSparToIO ctx = . runRpcWithHttp ctx.sparCtxHttpManager ctx.sparCtxRequestId . iParseException . iErrorCall - . interpretUserSubsystemLowerEffects ctx - . interpretAuthSubsystemLowerEffects ctx . iGalleyAPIAccess ctx . intepreterTeamSubsystemToGalleyAPI . runDelay @@ -258,7 +206,6 @@ runSparToIO ctx = . iGundeckAPIAccess ctx . iNotificationSubsystem ctx . runAWSSubsystem ctx.sparCtxAws - . runEvents . iUserGroupStore . iUserGroupSubsystemError . verdictFormatStoreToCassandra @@ -266,19 +213,9 @@ runSparToIO ctx = . assIDStoreToCassandra . sparRouteToServant (saml $ sparCtxOpts ctx) . saml2ToSaml2WebSso - . iUserAuthDoubleSubsystem - . interpretUserGroupSubsystem + . interpretBrigAccess ctx.sparCtxOpts.brig . interpretScimSubsystem -iUserAuthDoubleSubsystem :: (Members LowerLevelCanonicalEffs r) => InterpretersFor '[UserSubsystem, AuthenticationSubsystem] r -iUserAuthDoubleSubsystem = authSubsystemInterpreter . userSubsystemInterpreter - where - userSubsystemInterpreter :: (Members LowerLevelCanonicalEffs r) => InterpreterFor UserSubsystem r - userSubsystemInterpreter = runUserSubsystem authSubsystemInterpreter - - authSubsystemInterpreter :: (Members LowerLevelCanonicalEffs r) => InterpreterFor AuthenticationSubsystem r - authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter - iGalleyAPIAccess :: ( Member (Error ParseException) r, Member Rpc r, @@ -331,91 +268,6 @@ iErrorCall = Polysemy.Error.mapError errorCallToSparError errorCallToSparError :: ErrorCall -> SparError errorCallToSparError (ErrorCallWithLocation msg _) = SAML.CustomError (SparInternalError (fromString msg)) -type UserSubsystemLowerEffects = - '[ UserStore, - AppStore, - UserKeyStore, - BlockListStore, - ConnectionStore InternalPaging, - DomainRegistrationStore, - FederationAPIAccess FederatorClient, - Concurrency 'Unsafe, - Error FederationError, - Error UserSubsystemError, - DeleteQueue, - IndexedUserStore, - FederationConfigStore, - Metrics, - InvitationStore, - Input UserSubsystemConfig - ] - -interpretUserSubsystemLowerEffects :: - ( Member (Input Hasql.Pool) r, - Member UserStore r, - Member (Error Hasql.UsageError) r, - Member (Error SparError) r, - Member (Final IO) r, - Member (Embed IO) r, - Member (Embed Cas.Client) r, - Member TinyLog r, - Member (Error ErrorCall) r - ) => - Env -> - InterpretersFor UserSubsystemLowerEffects r -interpretUserSubsystemLowerEffects env = - runInputConst env.sparCtxUserSubsystemConfig - . interpretInvitationStoreToCassandra env.sparCtxCas - . runMetricsToIO - . interpretFederationDomainConfig env.sparCtxCas Nothing mempty - . interpretIndexedUserStoreES env.sparCtxIndexedUserStoreConfig - . runDeleteQueue env.sparCtxInternalEvents - . mapError (httpErrorToSparError . userSubsystemErrorToHttpError) - . mapError (httpErrorToSparError . StdError . federationErrorToWai) - . unsafelyPerformConcurrency - . interpretFederationAPIAccess env.sparCtxFederationAPIAccessConfig - . interpretDomainRegistrationStoreToCassandra env.sparCtxCas - . connectionStoreToCassandra - . interpretBlockListStoreToCassandra env.sparCtxCas - . interpretUserKeyStoreCassandra env.sparCtxCas - . interpretAppStoreToPostgres - . interpretUserStoreCassandra env.sparCtxCas - -type AuthSubsystemLowerEffects = - '[ PasswordResetCodeStore, - Error AuthenticationSubsystemError, - HashPassword, - SessionStore, - Input AuthenticationSubsystemConfig, - PasswordStore, - EmailSubsystem, - RateLimit, - CryptoSign, - Random - ] - -interpretAuthSubsystemLowerEffects :: - ( Member (Error SparError) r, - Member (Embed Cas.Client) r, - Member EmailSending r, - Member (Error RateLimitExceeded) r, - Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - Env -> - InterpretersFor AuthSubsystemLowerEffects r -interpretAuthSubsystemLowerEffects env = - randomToIO - . runCryptoSign - . interpretRateLimit env.sparCtxRateLimit - . emailSubsystemInterpreter env.sparCtxUserTemplates env.sparCtxTeamTemplates env.sparCtxTemplateBranding - . interpretPasswordStore env.sparCtxCas - . runInputConst env.sparCtxAuthenticationSubsystemConfig - . interpretSessionStoreCassandra env.sparCtxCas - . runHashPassword env.sparCtxPasswordHashingOptions - . mapError (httpErrorToSparError . authenticationSubsystemErrorToHttpError) - . passwordResetCodeStoreToCassandra @Cas.Client - runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do liftIO (runSparToIO ctx spar) >>= \case diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index a234fea22f..b81c11fb59 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -116,7 +116,7 @@ import Wire.API.EnterpriseLogin import Wire.API.Internal.Notification import Wire.API.OAuth (OAuthClient, OAuthClientConfig, OAuthClientCredentials) import Wire.API.Properties -import Wire.API.Routes.Internal.Brig +import Wire.API.Routes.Internal.Brig qualified as BrigAPI import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra @@ -1049,7 +1049,7 @@ deleteOAuthClient cid = do ---------------------------------------------------------------------- -enterpriseLogin :: SS.ServerT EnterpriseLoginApi Handler +enterpriseLogin :: SS.ServerT BrigAPI.EnterpriseLoginApi Handler enterpriseLogin = Named @"domain-registration-lock" (runClientToHandler . domRegLock) :<|> Named @"domain-registration-unlock" (runClientToHandler . domRegUnlock) @@ -1080,4 +1080,4 @@ domRegGet :: Domain -> SC.ClientM (DomainRegistrationResponse V10) :<|> domRegDelete :<|> domRegGet ) = - SC.client (Proxy @("i" :> EnterpriseLoginApi)) + SC.client (Proxy @("i" :> BrigAPI.EnterpriseLoginApi)) From 2cf977fff95a26e5d05e41842a096f1d69af6358 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 08:35:48 +0100 Subject: [PATCH 18/30] Make test case more readable (and less wrong). --- .../test/unit/Wire/ScimSubsystem/InterpreterSpec.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 2c6adf1678..01196e57fa 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -109,9 +109,8 @@ spec = UGS.timeoutHook $ describe "ScimSubsystem.Interpreter" $ do let newScimGroup = newScimGroup_ { Group.members = - let all_ = UGS.allUsers team - nonscim_ = filter (\u -> u.userManagedBy == ManagedByScim) all_ - in mkScimGroupMember <$> nonscim_ + let scimMembers = filter (\u -> u.userManagedBy == ManagedByScim) (UGS.allUsers team) + in mkScimGroupMember <$> scimMembers } resultOrError = do runDependencies (UGS.allUsers team) (UGS.galleyTeam team) $ do From c743275d920d34e426c18c00f767fd1671bf6895 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 08:44:35 +0100 Subject: [PATCH 19/30] linting. --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 2 +- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 2 +- .../test/unit/Wire/ScimSubsystem/InterpreterSpec.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index a3cae52f18..caa68e5d2a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -61,7 +61,6 @@ import Data.Schema hiding (swaggerDoc) import Data.Text qualified as Text import GHC.TypeLits import Imports hiding (head) -import Wire.Arbitrary (Arbitrary, GenericUniform (..)) import Network.HTTP.Client qualified as HTTP import Servant hiding (Handler, addHeader, respond) import Servant.Client qualified as Servant @@ -97,6 +96,7 @@ import Wire.API.User.Auth.Sso import Wire.API.User.Client import Wire.API.User.RichInfo import Wire.API.UserGroup (NewUserGroup, UserGroup) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- | Parameters for getting user accounts by various criteria data GetBy = GetBy diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 9924eddfc2..7932178761 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -26,6 +26,7 @@ import SAML2.WebSSO qualified as SAML import Text.Email.Parser import Wire.API.EnterpriseLogin import Wire.API.Federation.Error +import Wire.API.Routes.Internal.Brig (GetBy (..)) import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) import Wire.API.Team.Export (TeamExportUser) import Wire.API.Team.Feature @@ -33,7 +34,6 @@ import Wire.API.Team.Member (IsPerm (..), TeamMember) import Wire.API.User import Wire.API.User.Activation import Wire.API.User.IdentityProvider hiding (team) -import Wire.API.Routes.Internal.Brig (GetBy (..)) import Wire.API.User.Search import Wire.ActivationCodeStore import Wire.Arbitrary diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 01196e57fa..a7fcf95431 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -72,7 +72,7 @@ runDependencies initialUsers initialTeams = pure $ filter (\u -> User.userId u `elem` getBy.getByUserId) users CreateGroupFull managedBy _teamId _creatorUserId newGroup -> do -- For tests, just create a minimal UserGroup - let gid = Id UUID.nil -- Using nil UUID for tests + let gid = Id UUID.nil -- Using nil UUID for tests pure $ UserGroup_ { id_ = gid, From a88fc72333260c5ad997f96c3ae17f3999f8103f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 09:04:36 +0100 Subject: [PATCH 20/30] Fix unit test. --- .../Wire/ScimSubsystem/InterpreterSpec.hs | 20 +++---------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index a7fcf95431..03c4ff5235 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -4,10 +4,8 @@ module Wire.ScimSubsystem.InterpreterSpec (spec) where import Data.Id -import Data.Json.Util (toUTCTimeMillis) import Data.Qualified import Data.Text qualified as Text -import Data.UUID qualified as UUID import Imports import Network.URI import Polysemy @@ -65,25 +63,13 @@ runDependencies initialUsers initialTeams = crashOnLowerErrors = fmap (either (error . show) id) . runError -- Mock BrigAPIAccess interpreter for tests - mockBrigAPIAccess :: [User] -> InterpreterFor BrigAPIAccess r + mockBrigAPIAccess :: (Member UGS.UserGroupSubsystem r) => [User] -> InterpreterFor BrigAPIAccess r mockBrigAPIAccess users = interpret $ \case + CreateGroupFull managedBy teamId creatorUserId newGroup -> do + UGS.createGroupFull managedBy teamId creatorUserId newGroup GetAccountsBy localGetBy -> do let getBy = tUnqualified localGetBy pure $ filter (\u -> User.userId u `elem` getBy.getByUserId) users - CreateGroupFull managedBy _teamId _creatorUserId newGroup -> do - -- For tests, just create a minimal UserGroup - let gid = Id UUID.nil -- Using nil UUID for tests - pure $ - UserGroup_ - { id_ = gid, - name = newGroup.name, - members = Identity newGroup.members, - membersCount = Nothing, - channels = Nothing, - channelsCount = Nothing, - managedBy = managedBy, - createdAt = toUTCTimeMillis (read "2024-01-01 00:00:00 UTC") - } _ -> error "Unimplemented BrigAPIAccess operation in mock" instance Arbitrary Group.Group where From d255422f39eaab7607be83e32cca0a4e6fb27017 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 09:25:17 +0100 Subject: [PATCH 21/30] changelog. --- changelog.d/5-internal/scim-create-group | 4 ++++ changelog.d/scim-create-group | 1 + 2 files changed, 5 insertions(+) create mode 100644 changelog.d/5-internal/scim-create-group create mode 100644 changelog.d/scim-create-group diff --git a/changelog.d/5-internal/scim-create-group b/changelog.d/5-internal/scim-create-group new file mode 100644 index 0000000000..f18bdb9ba9 --- /dev/null +++ b/changelog.d/5-internal/scim-create-group @@ -0,0 +1,4 @@ +Introducing user groups in SCIM involved a lot of refactorings: +- some of Brig.CanonicalInterpreters has been moved (copied?) to wire-subsystems (notably stomp, aws, events) +- Spar.CanonicalInterpreter has been extended to make use of the subsystems formerly only used by brig (somme of the interpreters are undefined because unused) +- since that running brig code in spar wasn't always feasible: brig internal api has been extended to expose UserGroupSubsystem to spar diff --git a/changelog.d/scim-create-group b/changelog.d/scim-create-group new file mode 100644 index 0000000000..fe9fd4c440 --- /dev/null +++ b/changelog.d/scim-create-group @@ -0,0 +1 @@ +Create user groups with SCIM. \ No newline at end of file From 60d9b51a2e526dcde43a90e183fe2f418751c5e2 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 11:27:53 +0100 Subject: [PATCH 22/30] Simplify getAccountsBy internal end-point (no need to talk federation). --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 2 +- libs/wire-subsystems/src/Wire/BrigAPIAccess.hs | 2 +- libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs | 6 +++--- .../src/Wire/ScimSubsystem/Interpreter.hs | 6 +----- .../test/unit/Wire/ScimSubsystem/InterpreterSpec.hs | 4 +--- services/brig/src/Brig/API/Internal.hs | 11 ++++------- 6 files changed, 11 insertions(+), 20 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index caa68e5d2a..2839007875 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -229,7 +229,7 @@ type GetAccountsByInternal = ( Summary "Get user accounts by various criteria (internal)" :> "users" :> "accounts-by" - :> ReqBody '[Servant.JSON] (Qualified GetBy) + :> ReqBody '[Servant.JSON] GetBy :> Post '[Servant.JSON] [User] ) diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index 80370ba57f..dad24dd215 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -130,7 +130,7 @@ data BrigAPIAccess m a where GetUserExportData :: UserId -> BrigAPIAccess m (Maybe TeamExportUser) DeleteBot :: ConvId -> BotId -> BrigAPIAccess m () UpdateSearchIndex :: UserId -> BrigAPIAccess m () - GetAccountsBy :: Local GetBy -> BrigAPIAccess m [User] + GetAccountsBy :: GetBy -> BrigAPIAccess m [User] CreateGroupFull :: ManagedBy -> TeamId -> Maybe UserId -> NewUserGroup -> BrigAPIAccess m UserGroup makeSem ''BrigAPIAccess diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index 328fecc7aa..6235ec09e7 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -20,6 +20,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog +import System.IO.Unsafe import System.Logger.Message qualified as Logger import Util.Options import Web.HttpApiData @@ -520,15 +521,14 @@ updateSearchIndex uid = do -- | Calls 'Brig.API.Internal.getAccountsByInternalH'. getAccountsBy :: (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => - Local GetBy -> + GetBy -> Sem r [User] getAccountsBy localGetBy = do - let qualifiedGetBy = tUntagged localGetBy r <- brigRequest $ method POST . path "/i/users/accounts-by" - . json qualifiedGetBy + . json localGetBy . expect2xx decodeBodyOrThrow "brig" r diff --git a/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs index f0b772556a..000f012b1c 100644 --- a/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/ScimSubsystem/Interpreter.hs @@ -3,7 +3,6 @@ module Wire.ScimSubsystem.Interpreter where import Data.Default import Data.Id import Data.Json.Util -import Data.Qualified import Data.Text qualified as Text import Data.Vector qualified as V import Imports @@ -31,7 +30,6 @@ data ScimSubsystemConfig = ScimSubsystemConfig interpretScimSubsystem :: ( Member (Input ScimSubsystemConfig) r, Member (Error ScimSubsystemError) r, - Member (Input (Local ())) r, Member BrigAPIAccess r ) => InterpreterFor ScimSubsystem r @@ -51,7 +49,6 @@ createScimGroupImpl :: forall r. ( Member (Input ScimSubsystemConfig) r, Member (Error ScimSubsystemError) r, - Member (Input (Local ())) r, Member BrigAPIAccess r ) => TeamId -> @@ -63,8 +60,7 @@ createScimGroupImpl teamId grp = do uids :: [UserId] <- let thrw = throw . ScimSubsystemInvalidGroupMemberId in forM uidsAsText $ either (thrw . Text.pack) pure . parseIdFromText - getby :: Local GetBy <- inputQualifyLocal def {getByUserId = uids} - users <- BrigAPI.getAccountsBy getby + users <- BrigAPI.getAccountsBy def {getByUserId = uids} pure $ users & filter (\u -> u.userManagedBy /= ManagedByScim) diff --git a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs index 03c4ff5235..88c8279e97 100644 --- a/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/ScimSubsystem/InterpreterSpec.hs @@ -4,7 +4,6 @@ module Wire.ScimSubsystem.InterpreterSpec (spec) where import Data.Id -import Data.Qualified import Data.Text qualified as Text import Imports import Network.URI @@ -67,8 +66,7 @@ runDependencies initialUsers initialTeams = mockBrigAPIAccess users = interpret $ \case CreateGroupFull managedBy teamId creatorUserId newGroup -> do UGS.createGroupFull managedBy teamId creatorUserId newGroup - GetAccountsBy localGetBy -> do - let getBy = tUnqualified localGetBy + GetAccountsBy getBy -> do pure $ filter (\u -> User.userId u `elem` getBy.getByUserId) users _ -> error "Unimplemented BrigAPIAccess operation in mock" diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d86af1ed5a..ff79ded9de 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -992,14 +992,11 @@ getAccountsByInternalH :: ( Member UserSubsystem r, Member (Input (Local ())) r ) => - Qualified GetBy -> + GetBy -> Handler r [User] -getAccountsByInternalH qGetBy = case qGetBy of - Qualified getByData domain -> do - loc <- lift $ liftSem input - if tDomain loc == domain - then lift . liftSem $ getAccountsBy (qualifyAs loc getByData) - else throwStd (errorToWai @'E.InvalidUser) +getAccountsByInternalH getByData = do + loc <- lift $ liftSem input + lift . liftSem $ getAccountsBy (qualifyAs loc getByData) createGroupFullInternalH :: ( Member UserGroupSubsystem r From 6083ca530d75de4f6eb3d12a86dd70ff5d9f22e5 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 5 Nov 2025 12:45:12 +0100 Subject: [PATCH 23/30] fix: clean interpreters --- services/integration.yaml | 8 - services/spar/src/Spar/App.hs | 31 +--- .../spar/src/Spar/CanonicalInterpreter.hs | 107 +----------- services/spar/src/Spar/Options.hs | 24 --- services/spar/src/Spar/Run.hs | 160 ------------------ 5 files changed, 2 insertions(+), 328 deletions(-) diff --git a/services/integration.yaml b/services/integration.yaml index 427aa761d1..e6795f2609 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -19,10 +19,6 @@ galley: host: 127.0.0.1 port: 8085 -gundeck: - host: 127.0.0.1 - port: 8086 - proxy: host: 127.0.0.1 port: 8087 @@ -59,10 +55,6 @@ nginxIngress: host: localhost port: 8443 -federatorInternal: - host: 127.0.0.1 - port: 8097 - federatorExternal: host: 127.0.0.1 port: 8098 diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 136bc218dd..2190cbd51c 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -37,7 +37,6 @@ where import Bilge import qualified Cassandra as Cas -import Cassandra.Options (Endpoint) import Control.Exception (assert) import Control.Lens hiding ((.=)) import Data.Aeson as Aeson (encode, object, (.=)) @@ -56,7 +55,6 @@ import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText import Data.These -import qualified Hasql.Pool as Hasql import Imports hiding (MonadReader, asks, log) import qualified Network.HTTP.Types.Status as Http import qualified Network.Wai.Utilities.Error as Wai @@ -96,28 +94,17 @@ import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import qualified System.Logger as TinyLog import URI.ByteString as URI -import Util.Options (PasswordHashingOptions) import Web.Cookie (SetCookie, renderSetCookie) -import Wire.API.Routes.Version import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User import Wire.API.User.IdentityProvider import Wire.API.User.Saml -import qualified Wire.AWSSubsystem.AWS as AWSI -import Wire.AuthenticationSubsystem.Config -import Wire.DeleteQueue.Types (QueueEnv) -import Wire.EmailSending.SMTP (SMTP) -import Wire.EmailSubsystem.Template (Localised, TeamTemplates, TemplateBranding, UserTemplates) import Wire.Error -import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig) -import Wire.IndexedUserStore.ElasticSearch (IndexedUserStoreConfig) -import Wire.RateLimit.Interpreter (RateLimitEnv) import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Random (Random) import qualified Wire.Sem.Random as Random -import Wire.UserSubsystem.UserSubsystemConfig (UserSubsystemConfig) throwSparSem :: (Member (Error SparError) r) => SparCustomError -> Sem r a throwSparSem = throw . SAML.CustomError @@ -129,25 +116,9 @@ data Env = Env sparCtxHttpManager :: Bilge.Manager, sparCtxHttpBrig :: Bilge.Request, sparCtxHttpGalley :: Bilge.Request, - sparCtxHttpGalleyEndpoint :: Endpoint, - sparCtxHttpGundeckEndpoint :: Endpoint, - disabledVersions :: Set Version, sparCtxRequestId :: RequestId, sparCtxLocalUnit :: Local (), - sparCtxScimSubsystemConfig :: ScimSubsystemConfig, - sparCtxAuthenticationSubsystemConfig :: AuthenticationSubsystemConfig, - sparCtxPasswordHashingOptions :: PasswordHashingOptions, - sparCtxUserTemplates :: Localised UserTemplates, - sparCtxTeamTemplates :: Localised TeamTemplates, - sparCtxTemplateBranding :: TemplateBranding, - sparCtxRateLimit :: RateLimitEnv, - sparCtxFederationAPIAccessConfig :: FederationAPIAccessConfig, - sparCtxIndexedUserStoreConfig :: IndexedUserStoreConfig, - sparCtxUserSubsystemConfig :: UserSubsystemConfig, - sparCtxHasqlPool :: Hasql.Pool, - sparCtxSmtp :: Maybe SMTP, - sparCtxAws :: AWSI.Env, - sparCtxInternalEvents :: QueueEnv + sparCtxScimSubsystemConfig :: ScimSubsystemConfig } -- | Get a user by UserRef, no matter what the team. diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 19d3513d26..bd3b3d82db 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -25,19 +25,14 @@ module Spar.CanonicalInterpreter where import qualified Cassandra as Cas -import Control.Exception (ErrorCall (..)) -import Control.Lens ((^.)) import Control.Monad.Except hiding (mapError) import Data.Qualified -import qualified Hasql.Pool as Hasql import Imports import Polysemy -import qualified Polysemy.Async as P import Polysemy.Error import Polysemy.Input (Input, runInputConst) import Polysemy.Internal.Kind import Polysemy.TinyLog hiding (err) -import qualified SAML2.WebSSO as SAML import Servant import Spar.App hiding (sparToServerErrorWithLogging) import Spar.Error @@ -75,39 +70,18 @@ import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSpa import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog -import Wire.API.User.Saml -import Wire.AWSSubsystem (AWSSubsystem) -import Wire.AWSSubsystem.AWS (runAWSSubsystem) -import qualified Wire.AWSSubsystem.AWS as AWSI +import Wire.API.User.Saml (TTLError) import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) -import Wire.EmailSending (EmailSending) -import Wire.EmailSending.Core (EmailSendingInterpreterConfig (EmailSendingInterpreterConfig), emailSendingInterpreter) -import Wire.Error -import Wire.GalleyAPIAccess -import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) -import Wire.GundeckAPIAccess -import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Interpreter import Wire.ParseException (ParseException, parseExceptionToHttpError) -import Wire.RateLimit import Wire.Rpc (Rpc, runRpcWithHttp) import Wire.ScimSubsystem import Wire.ScimSubsystem.Interpreter -import Wire.Sem.Delay import Wire.Sem.Logger.TinyLog (loggerToTinyLog, stringLoggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIO) import Wire.Sem.Random (Random) import Wire.Sem.Random.IO (randomToIO) -import Wire.TeamSubsystem -import Wire.TeamSubsystem.GalleyAPI -import Wire.UserGroupStore -import qualified Wire.UserGroupStore as Store -import Wire.UserGroupStore.Postgres -import Wire.UserGroupSubsystem.Interpreter -import Wire.UserStore -import Wire.UserStore.Cassandra type CanonicalEffs = '[ScimSubsystem] @@ -120,16 +94,6 @@ type LowerLevelCanonicalEffs = AssIDStore, AReqIDStore, VerdictFormatStore, - Error UserGroupSubsystemError, - Store.UserGroupStore, - AWSSubsystem, - NotificationSubsystem, - GundeckAPIAccess, - P.Async, - Delay, - TeamSubsystem, - GalleyAPIAccess, - Error ErrorCall, Error ParseException, Rpc, Input (Local ()), @@ -145,15 +109,10 @@ type LowerLevelCanonicalEffs = Embed Cas.Client, BrigAccess, GalleyAccess, - UserStore, - Error RateLimitExceeded, Error IdpDbError, Error TTLError, - Input Hasql.Pool, - Error Hasql.UsageError, Error SparError, Reporter, - EmailSending, Logger String, Logger (TinyLog.Msg -> TinyLog.Msg), Input Opts, @@ -174,15 +133,10 @@ runSparToIO ctx = . runInputConst (sparCtxOpts ctx) . loggerToTinyLog (sparCtxLogger ctx) . stringLoggerToTinyLog - . emailSendingInterpreter (EmailSendingInterpreterConfig ctx.sparCtxSmtp (ctx.sparCtxAws ^. AWSI.amazonkaEnv) ctx.sparCtxLogger) . reporterToTinyLogWai . runError @SparError - . iHasqlUsageError - . runInputConst ctx.sparCtxHasqlPool . ttlErrorToSparError . idpDbErrorToSparError - . mapError (httpErrorToSparError . rateLimitExceededToHttpError) - . interpretUserStoreCassandra ctx.sparCtxCas . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) @@ -198,16 +152,6 @@ runSparToIO ctx = . runInputConst (ctx.sparCtxLocalUnit) . runRpcWithHttp ctx.sparCtxHttpManager ctx.sparCtxRequestId . iParseException - . iErrorCall - . iGalleyAPIAccess ctx - . intepreterTeamSubsystemToGalleyAPI - . runDelay - . P.asyncToIOFinal - . iGundeckAPIAccess ctx - . iNotificationSubsystem ctx - . runAWSSubsystem ctx.sparCtxAws - . iUserGroupStore - . iUserGroupSubsystemError . verdictFormatStoreToCassandra . aReqIDStoreToCassandra . assIDStoreToCassandra @@ -216,58 +160,9 @@ runSparToIO ctx = . interpretBrigAccess ctx.sparCtxOpts.brig . interpretScimSubsystem -iGalleyAPIAccess :: - ( Member (Error ParseException) r, - Member Rpc r, - Member TinyLog r - ) => - Env -> - InterpreterFor GalleyAPIAccess r -iGalleyAPIAccess env = interpretGalleyAPIAccessToRpc env.disabledVersions env.sparCtxHttpGalleyEndpoint - -iGundeckAPIAccess :: - ( Member (Embed IO) r, - Member Rpc r - ) => - Env -> - InterpreterFor GundeckAPIAccess r -iGundeckAPIAccess env = runGundeckAPIAccess (sparCtxHttpGundeckEndpoint env) - -iNotificationSubsystem :: - ( Member GundeckAPIAccess r, - Member TinyLog r, - Member Delay r, - Member P.Async r, - Member (Final IO) r - ) => - Env -> - InterpreterFor NotificationSubsystem r -iNotificationSubsystem env = runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig env.sparCtxRequestId) - -iUserGroupStore :: - ( Member (Input (Local ())) r, - Member (Embed IO) r, - Member (Input Hasql.Pool) r, - Member (Error Hasql.UsageError) r - ) => - InterpreterFor UserGroupStore r -iUserGroupStore = interpretUserGroupStoreToPostgres - -iUserGroupSubsystemError :: (Member (Error SparError) r) => InterpreterFor (Error UserGroupSubsystemError) r -iUserGroupSubsystemError = Polysemy.Error.mapError (httpErrorToSparError . userGroupSubsystemErrorToHttpError) - -iHasqlUsageError :: (Member (Error SparError) r) => InterpreterFor (Error Hasql.UsageError) r -iHasqlUsageError = Polysemy.Error.mapError (httpErrorToSparError . postgresUsageErrorToHttpError) - iParseException :: (Member (Error SparError) r) => InterpreterFor (Error ParseException) r iParseException = Polysemy.Error.mapError (httpErrorToSparError . parseExceptionToHttpError) -iErrorCall :: (Member (Error SparError) r) => InterpreterFor (Error ErrorCall) r -iErrorCall = Polysemy.Error.mapError errorCallToSparError - where - errorCallToSparError :: ErrorCall -> SparError - errorCallToSparError (ErrorCallWithLocation msg _) = SAML.CustomError (SparInternalError (fromString msg)) - runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do liftIO (runSparToIO ctx spar) >>= \case diff --git a/services/spar/src/Spar/Options.hs b/services/spar/src/Spar/Options.hs index 7c2ecf7ef6..e9ef2a7742 100644 --- a/services/spar/src/Spar/Options.hs +++ b/services/spar/src/Spar/Options.hs @@ -40,9 +40,7 @@ import Data.Domain (Domain) import Data.Time import qualified Data.Yaml as Yaml import qualified Database.Bloodhound.Types as ES -import qualified Hasql.Pool.Extended as Hasql import Imports -import qualified Network.AMQP.Extended as Q import Options.Applicative import SAML2.WebSSO import qualified SAML2.WebSSO as SAML @@ -56,30 +54,15 @@ import Wire.API.Routes.Version import Wire.API.User (EmailAddress, EmailVisibilityConfig, Locale) import Wire.API.User.Orphans () import Wire.API.User.Saml -import Wire.AWSSubsystem.AWS (AWSOpts) import Wire.AuthenticationSubsystem.Config (ZAuthSettings) import Wire.AuthenticationSubsystem.Cookie.Limit (CookieThrottle) -import Wire.DeleteQueue.Types (InternalEventsOpts) import Wire.RateLimit.Interpreter (RateLimitConfig) -import Wire.StompSubsystem.Stomp (StompOpts) data Opts = Opts { saml :: !SAML.Config, brig :: !Endpoint, galley :: !Endpoint, - gundeck :: !Endpoint, cassandra :: !CassandraOpts, - elasticsearch :: !ElasticSearchOpts, - -- | Postgresql settings, the key values must be in libpq format. - postgresql :: !(Map Text Text), - postgresqlPassword :: !(Maybe FilePathSecrets), - postgresqlPool :: !Hasql.PoolConfig, - -- | Federator address - federatorInternal :: !(Maybe Endpoint), - -- | RabbitMQ settings, required when federation is enabled. - rabbitmq :: !(Maybe Q.AmqpEndpoint), - -- | STOMP broker settings - stompOptions :: !(Maybe StompOpts), maxttlAuthreq :: !(TTL "authreq"), maxttlAuthresp :: !(TTL "authresp"), -- | The maximum number of SCIM tokens that we will allow teams to have. @@ -89,19 +72,12 @@ data Opts = Opts -- | Wire/AWS specific; optional; used to discover Cassandra instance -- IPs using describe-instances. discoUrl :: !(Maybe Text), - -- | Event queue for Spar-generated events - internalEvents :: !InternalEventsOpts, - -- | ZAuth settings - zauth :: !ZAuthOpts, - -- | Email and SMS settings - emailSMS :: !EmailSMSOpts, -- | Log level logLevel :: !Level, logNetStrings :: !(Maybe (Last Bool)), logFormat :: !(Maybe (Last LogFormat)), disabledAPIVersions :: !(Set VersionExp), scimBaseUri :: URI, - aws :: !AWSOpts, -- | Runtime settings settings :: !Settings } diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index 466be151ea..25495f2797 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -34,23 +34,13 @@ import Cassandra.Util (initCassandraForService) import Control.Exception (ErrorCall (ErrorCall), throwIO) import Control.Lens (to, (^.), (^?), _Just) import qualified Data.ByteString.UTF8 as UTF8 -import Data.Coerce (coerce) -import Data.Credentials (Credentials (..)) import Data.Domain -import qualified Data.HashSet as HashSet import Data.Id -import Data.LanguageCodes (ISO639_1 (EN)) import Data.Metrics.Servant (servantPrometheusMiddleware) import Data.Proxy (Proxy (Proxy)) import Data.Qualified -import qualified Data.Set as Set import Data.Text.Encoding -import qualified Database.Bloodhound as ES -import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) -import qualified Hasql.Pool.Extended as Hasql import Imports -import Network.HTTP.Client (Manager, ManagerSettings (..), newManager, responseTimeoutMicro) -import Network.HTTP.Client.OpenSSL (opensslManagerSettings) import Network.URI import Network.Wai (Application) import qualified Network.Wai as Wai @@ -58,7 +48,6 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Gunzip as GZip import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as WU -import qualified OpenSSL.Session as SSL import qualified SAML2.WebSSO as SAML import Spar.API (SparAPI, app) import Spar.App @@ -74,17 +63,7 @@ import Util.Options import qualified Web.Scim.Schema.Common as Scim import Wire.API.Routes.Version (expandVersionExp) import Wire.API.Routes.Version.Wai -import Wire.API.User (Language (Language), Locale (Locale)) -import qualified Wire.AWSSubsystem.AWS as AWSI -import Wire.AuthenticationSubsystem.Config (AuthenticationSubsystemConfig (..), ZAuthEnv) -import qualified Wire.AuthenticationSubsystem.Config as AuthenticationSubsystem -import Wire.DeleteQueue.Types (InternalEventsOpts (..), QueueEnv (..), QueueOpts (..)) -import Wire.FederationAPIAccess.Interpreter (FederationAPIAccessConfig (..)) -import Wire.IndexedUserStore.ElasticSearch (ESConn (..), IndexedUserStoreConfig (..)) -import Wire.RateLimit.Interpreter (newRateLimitEnv) import Wire.ScimSubsystem.Interpreter -import qualified Wire.StompSubsystem.Stomp as Stomp -import Wire.UserSubsystem.UserSubsystemConfig (UserSubsystemConfig (..)) ---------------------------------------------------------------------- -- cassandra @@ -98,34 +77,6 @@ initCassandra opts lgr = (Just Data.schemaVersion) lgr -initZAuth :: Opts -> IO ZAuthEnv -initZAuth o = do - let zOpts = Opt.zauth o - privateKeys = Opt.privateKeys zOpts - publicKeys = Opt.publicKeys zOpts - sk <- AuthenticationSubsystem.readKeys privateKeys - pk <- AuthenticationSubsystem.readKeys publicKeys - case (sk, pk) of - (Nothing, _) -> error ("No private key in: " <> privateKeys) - (_, Nothing) -> error ("No public key in: " <> publicKeys) - (Just s, Just p) -> AuthenticationSubsystem.mkZAuthEnv s p (Opt.authSettings zOpts) - ----------------------------------------------------------------------- --- internal events queue - -initInternalEvents :: Logger -> Opts -> AWSI.Env -> IO QueueEnv -initInternalEvents lgr opts aws = case opts.internalEvents.internalEventsQueue of - StompQueueOpts q -> do - stomp :: Stomp.Env <- case (opts.stompOptions, opts.settings.stomp) of - (Just s, Just c) -> Stomp.mkEnv lgr s <$> initCredentials c - (Just _, Nothing) -> error "STOMP is configured but stomp credentials are not set" - (Nothing, Just _) -> error "stomp credentials are present but STOMP is not configured" - (Nothing, Nothing) -> error "stomp is selected for internal events, but not configured" - pure (StompQueueEnv stomp q) - SqsQueueOpts q -> do - let throttleMillis = fromMaybe 500 opts.settings.sqsThrottleMillis - SqsQueueEnv aws throttleMillis <$> AWSI.getQueueUrl (aws ^. AWSI.amazonkaEnv) q - ---------------------------------------------------------------------- -- servant / wai / warp @@ -147,7 +98,6 @@ mkApp sparCtxOpts = do sparCtxLogger <- Log.mkLogger logLevel (logNetStrings sparCtxOpts) (logFormat sparCtxOpts) sparCtxCas <- initCassandra sparCtxOpts sparCtxLogger sparCtxHttpManager <- Bilge.newManager Bilge.defaultManagerSettings - sparCtxHttp2Manager <- initHttp2Manager let sparCtxHttpBrig = Bilge.host (sparCtxOpts ^. to brig . to host . to encodeUtf8) . Bilge.port (sparCtxOpts ^. to brig . to port) @@ -156,8 +106,6 @@ mkApp sparCtxOpts = do Bilge.host (sparCtxOpts ^. to galley . to host . to encodeUtf8) . Bilge.port (sparCtxOpts ^. to galley . to port) $ Bilge.empty - let sparCtxHttpGalleyEndpoint = galley sparCtxOpts - let disabledVersions = Set.fromList . mconcat $ Set.toList . expandVersionExp <$> Set.toList sparCtxOpts.disabledAPIVersions let sparCtxRequestId = RequestId defRequestId (sparCtxScimSubsystemConfig, sparCtxLocalUnit) <- do @@ -183,64 +131,6 @@ mkApp sparCtxOpts = do pure (ScimSubsystemConfig scimUri, localUnit) - -- Initialize all the required subsystem configs - let sparCtxHttpGundeckEndpoint = gundeck sparCtxOpts - sparCtxZAuthEnv <- initZAuth sparCtxOpts - let localUnit = toLocalUnsafe sparCtxOpts.settings.federationDomain () - sparCtxAuthenticationSubsystemConfig = - AuthenticationSubsystemConfig - { zauthEnv = sparCtxZAuthEnv, - allowlistEmailDomains = sparCtxOpts.settings.allowlistEmailDomains, - local = localUnit, - userCookieRenewAge = sparCtxOpts.settings.userCookieRenewAge, - userCookieLimit = sparCtxOpts.settings.userCookieLimit, - userCookieThrottle = sparCtxOpts.settings.userCookieThrottle - } - sparCtxPasswordHashingOptions = sparCtxOpts.settings.passwordHashingOptions - let sparCtxUserTemplates = undefined - let sparCtxTeamTemplates = undefined - let sparCtxTemplateBranding = undefined - -- sparCtxUserTemplates <- loadUserTemplates (emailSMS sparCtxOpts).templateDir - -- sparCtxTeamTemplates <- loadTeamTemplates (emailSMS sparCtxOpts).templateDir - -- let sparCtxTemplateBranding = genTemplateBranding (emailSMS sparCtxOpts).templateBranding - sparCtxRateLimit <- newRateLimitEnv sparCtxOpts.settings.passwordHashingRateLimit - (esEnv, esIndexName) <- mkIndexEnv sparCtxOpts.elasticsearch - let sparCtxFederationAPIAccessConfig = - FederationAPIAccessConfig - { ownDomain = sparCtxOpts.settings.federationDomain, - federatorEndpoint = sparCtxOpts.federatorInternal, - http2Manager = sparCtxHttp2Manager, - requestId = sparCtxRequestId - } - mainESEnv = esEnv - sparCtxIndexedUserStoreConfig = - IndexedUserStoreConfig - { conn = - ESConn - { env = mainESEnv, - indexName = esIndexName - }, - additionalConn = Nothing - } - blockedDomains = - sparCtxOpts.settings.customerExtensions - ^? _Just - . to (coerce @_ @(HashSet Domain) . Opt.domainsBlockedForRegistration) - & fromMaybe HashSet.empty - sparCtxUserSubsystemConfig = - UserSubsystemConfig - { emailVisibilityConfig = sparCtxOpts.settings.emailVisibility, - defaultLocale = fromMaybe (Locale (Language EN) Nothing) sparCtxOpts.settings.defaultUserLocale, - searchSameTeamOnly = fromMaybe False sparCtxOpts.settings.searchSameTeamOnly, - maxTeamSize = sparCtxOpts.settings.maxTeamSize, - activationCodeTimeout = sparCtxOpts.settings.activationTimeout, - blockedDomains = blockedDomains - } - sparCtxHasqlPool <- Hasql.initPostgresPool (postgresqlPool sparCtxOpts) (postgresql sparCtxOpts) (postgresqlPassword sparCtxOpts) - let sparCtxSmtp = Nothing -- Spar doesn't send emails directly - sparCtxAws <- AWSI.mkEnv sparCtxLogger sparCtxOpts.aws Nothing sparCtxHttpManager - sparCtxInternalEvents <- initInternalEvents sparCtxLogger sparCtxOpts sparCtxAws - let ctx0 = Env {..} let heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) heavyLogOnly out@(req, _) = @@ -261,53 +151,3 @@ mkApp sparCtxOpts = do -- outages. . SAML.setHttpCachePolicy pure (middleware $ app ctx0, ctx0) - -mkIndexEnv :: Opt.ElasticSearchOpts -> IO (ES.BHEnv, ES.IndexName) -mkIndexEnv esOpts = do - mEsCreds :: Maybe Credentials <- for esOpts.credentials initCredentials - - let mkBhEnv skipVerifyTls mCustomCa mCreds url = do - mgr <- initHttpManagerWithTLSConfig skipVerifyTls mCustomCa - let bhe = ES.mkBHEnv url mgr - pure $ maybe bhe (\creds -> bhe {ES.bhRequestHook = ES.basicAuthHook (ES.EsUsername creds.username) (ES.EsPassword creds.password)}) mCreds - bhEnv <- mkBhEnv esOpts.insecureSkipVerifyTls esOpts.caCert mEsCreds esOpts.url - pure (bhEnv, esOpts.index) - -initHttpManagerWithTLSConfig :: Bool -> Maybe FilePath -> IO Manager -initHttpManagerWithTLSConfig skipTlsVerify mCustomCa = do - -- See Note [SSL context] - ctx <- SSL.context - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 - SSL.contextSetCiphers ctx "HIGH" - if skipTlsVerify - then SSL.contextSetVerificationMode ctx SSL.VerifyNone - else - SSL.contextSetVerificationMode ctx $ - SSL.VerifyPeer True True Nothing - case mCustomCa of - Nothing -> SSL.contextSetDefaultVerifyPaths ctx - Just customCa -> do - filePath <- canonicalizePath customCa - SSL.contextSetCAFile ctx filePath - -- Unfortunately, there are quite some AWS services we talk to - -- (e.g. SES, Dynamo) that still only support TLSv1. - -- Ideally: SSL.contextAddOption ctx SSL_OP_NO_TLSv1 - newManager - (opensslManagerSettings (pure ctx)) - { managerConnCount = 1024, - managerIdleConnectionCount = 4096, - managerResponseTimeout = responseTimeoutMicro 10000000 - } - -initHttp2Manager :: IO Http2Manager -initHttp2Manager = do - ctx <- SSL.context - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 - SSL.contextAddOption ctx SSL.SSL_OP_NO_TLSv1 - SSL.contextSetCiphers ctx "HIGH" - SSL.contextSetVerificationMode ctx $ - SSL.VerifyPeer True True Nothing - SSL.contextSetDefaultVerifyPaths ctx - http2ManagerWithSSLCtx ctx From 797766ba5da28499808300c2669f88aaa8b8274c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 12:56:13 +0100 Subject: [PATCH 24/30] Fix integration test [WIP] --- integration/test/Test/Spar.hs | 55 +++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index fdf42bda06..111c75ec1b 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -16,6 +16,7 @@ import qualified Data.Aeson.Types as A import qualified Data.CaseInsensitive as CI import Data.String.Conversions (cs) import qualified Data.Text as ST +import Debug.Trace import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified SAML2.WebSSO.Test.Util as SAML @@ -367,8 +368,53 @@ testSparCreateScimTokenWithName = do testSparScimCreateUserGroup :: (HasCallStack) => App () testSparScimCreateUserGroup = do - (owner, _, _) <- createTeam OwnDomain 1 + (owner, tid, _) <- createTeam OwnDomain 1 tok <- createScimTokenV6 owner def >>= \resp -> resp.json %. "token" >>= asString + + -- f0, f1, ... are stolen from other tests in this module, but they don't wokr quite yet. + + {- + let _f0 :: App String + _f0 = do + void $ setTeamFeatureStatus owner tid "sso" "enabled" + void $ registerTestIdPWithMeta owner >>= getJSON 201 + email <- randomEmail + extId <- randomExternalId + scimUser <- randomScimUserWithEmail extId email + scimUserId <- createScimUser OwnDomain tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + bindResponse (getUsersId OwnDomain [scimUserId]) $ \res -> do + res.status `shouldMatchInt` 200 + asString (res.json %. "[0].id") `shouldMatch` [scimUserId] + pure scimUserId + + -} + + let f1 :: App String + f1 = do + assertSuccess =<< setTeamFeatureStatus owner tid "validateSAMLemails" "disabled" + assertSuccess =<< setTeamFeatureStatus owner tid "sso" "enabled" + void $ registerTestIdPWithMetaWithPrivateCreds owner + + scimUser <- + randomScimUserWith + def + { mkExternalId = randomEmail, + prependExternalIdToEmails = False, + mkOtherEmails = pure [] + } + uid <- createScimUser owner tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + + getScimUser OwnDomain tok uid `bindResponse` \res -> do + res.status `shouldMatchInt` 200 + res.json %. "id" `shouldMatch` uid + traceM (show owner) + traceM (show tid) + traceM . show =<< res.json -- if this looks right (team, + -- id), then maybe there is another bug in scim group + -- creation, not the test? + pure uid + + scimUserId :: String <- f1 let scimUserGroup = object [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"], @@ -376,8 +422,11 @@ testSparScimCreateUserGroup = do "members" .= [ object [ "type" .= "User", - "$ref" .= "https://example.org/v2/scim/User/ea2e4bf0-aa5e-11f0-96ad-e776a606779b", -- TODO: or something imilar. we should probably validate these? or just ignore them? - "value" .= "ea2e4bf0-aa5e-11f0-96ad-e776a606779b" + "$ref" .= "...", -- something like + -- "https://example.org/v2/scim/User/ea2e4bf0-aa5e-11f0-96ad-e776a606779b"? + -- but since we're just receiving this it's ok + -- to ignore. + "value" .= scimUserId ] ] ] From 3926d142ae2a0b2b4b5ee6f713998e4b90512833 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 5 Nov 2025 13:09:34 +0100 Subject: [PATCH 25/30] fix: clean config --- services/integration.yaml | 8 ++++ services/spar/spar.integration.yaml | 61 ----------------------------- 2 files changed, 8 insertions(+), 61 deletions(-) diff --git a/services/integration.yaml b/services/integration.yaml index e6795f2609..427aa761d1 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -19,6 +19,10 @@ galley: host: 127.0.0.1 port: 8085 +gundeck: + host: 127.0.0.1 + port: 8086 + proxy: host: 127.0.0.1 port: 8087 @@ -55,6 +59,10 @@ nginxIngress: host: localhost port: 8443 +federatorInternal: + host: 127.0.0.1 + port: 8097 + federatorExternal: host: 127.0.0.1 port: 8098 diff --git a/services/spar/spar.integration.yaml b/services/spar/spar.integration.yaml index 4085731ebe..251c651cb8 100644 --- a/services/spar/spar.integration.yaml +++ b/services/spar/spar.integration.yaml @@ -24,10 +24,6 @@ galley: host: 127.0.0.1 port: 8085 -gundeck: - host: 127.0.0.1 - port: 8086 - cassandra: endpoint: host: 127.0.0.1 @@ -35,25 +31,6 @@ cassandra: keyspace: spar_test filterNodesByDatacentre: datacenter1 -elasticsearch: - url: https://localhost:9200 - index: directory_test_spar - credentials: ../../libs/wire-subsystems/test/resources/elasticsearch-credentials.yaml - caCert: ../../libs/wire-subsystems/test/resources/elasticsearch-ca.pem - insecureSkipVerifyTls: false - -postgresql: - host: 127.0.0.1 - port: "5432" - database: spar_test - user: postgres - -postgresqlPool: - size: 20 - acquisitionTimeout: 10s - agingTimeout: 1d - idlenessTimeout: 10m - # Wire/AWS specific, optional # discoUrl: "https://" @@ -67,47 +44,9 @@ maxttlAuthresp: 7200 # seconds. do not set this to 1h or less, as that is what maxScimTokens: 8 # Token limit {#RefScimToken} richInfoLimit: 5000 # should be in sync with Brig -internalEvents: - queueType: sqs - queueName: integration-brig-events-internal - -zauth: - privateKeys: ../../libs/wire-subsystems/test/resources/zauth/privkeys.txt - publicKeys: ../../libs/wire-subsystems/test/resources/zauth/pubkeys.txt - authSettings: - keyIndex: 1 - userTokenTimeout: 120 - sessionTokenTimeout: 20 - accessTokenTimeout: 30 - providerTokenTimeout: 60 - legacySessionTokenTimeout: 120 - legalHoldUserTokenTimeout: 120 - legalHoldAccessTokenTimeout: 30 - -emailSMS: - templateDir: ../../libs/wire-subsystems/templates - emailSender: backend-integration@wire.com - templateBranding: - brand: Wire - brandUrl: https://wire.com - brandLabelUrl: wire.com - brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png - brandService: Wire Service Provider - copyright: © WIRE SWISS GmbH - misuse: misuse@wire.com - legal: https://wire.com/legal/ - forgot: https://wire.com/forgot/ - support: https://support.wire.com/ - logLevel: Warn logNetStrings: False # log using netstrings encoding (see http://cr.yp.to/proto/netstrings.txt) -aws: - sesEndpoint: http://localhost:4579 # Amazon SES endpoint (fake-sqs/fake-ses) - sqsEndpoint: http://localhost:4568 # Amazon SQS endpoint (fake-sqs/fake-ses) - dynamoDBEndpoint: http://localhost:4567 # Amazon DynamoDB endpoint (fake-dynamodb) - prekeyTable: integration-brig-prekeys - settings: federationDomain: example.com passwordHashingOptions: From 1d884be90a731dce805df5171a91640e5f8e70e8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 17:19:28 +0100 Subject: [PATCH 26/30] Completely rewrite scim-post-group handler for readability. --- .../Wire/UserGroupSubsystem/Interpreter.hs | 37 ++++++++++++------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs index 32b8f51454..c11f180b8e 100644 --- a/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserGroupSubsystem/Interpreter.hs @@ -5,7 +5,7 @@ import Control.Lens ((^.)) import Data.Default import Data.Id import Data.Json.Util -import Data.Qualified (Local, Qualified (qUnqualified), qualifyAs) +import Data.Qualified import Data.Set qualified as Set import Data.Vector (Vector) import Imports @@ -89,6 +89,7 @@ createUserGroup creator newGroup = do createUserGroupFullImpl ManagedByWire team (Just creator) newGroup createUserGroupFullImpl :: + forall r. ( Member UserSubsystem r, Member (Error UserGroupSubsystemError) r, Member Store.UserGroupStore r, @@ -103,20 +104,30 @@ createUserGroupFullImpl :: NewUserGroup -> Sem r UserGroup createUserGroupFullImpl managedBy team mbCreator newGroup = do - luids <- qualifyLocal $ toList newGroup.members - profiles <- getLocalUserProfiles luids - let existingIds = Set.fromList $ fmap (qUnqualified . profileQualifiedId) profiles - let actualIds = Set.fromList $ toList newGroup.members - let allInSameTeam = all (\p -> p.profileTeam == Just team) profiles - when (existingIds /= actualIds || not allInSameTeam) $ - throw $ - UserGroupMemberIsNotInTheSameTeam + guardMembersInTeam ug <- Store.createUserGroup team newGroup managedBy - admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team - pushNotifications - [ mmkEvent mbCreator (UserGroupCreated ug.id_) admins - ] + notifyAdmins ug pure ug + where + guardMembersInTeam :: Sem r () + guardMembersInTeam = do + groupMembersFound :: [UserProfile] <- getLocalUserProfiles =<< qualifyLocal (toList newGroup.members) + let groupMemberIdsRequested :: [UserId] = toList newGroup.members + groupMemberIdsFound :: [UserId] = qUnqualified . profileQualifiedId <$> groupMembersFound + nobodyMissing = Set.fromList groupMemberIdsRequested == Set.fromList groupMemberIdsFound + + allTeams :: [Maybe TeamId] = nub $ profileTeam <$> groupMembersFound + nobodyFromOtherTeam = allTeams == [Just team] || null (toList newGroup.members) + + unless (nobodyMissing && nobodyFromOtherTeam) do + throw UserGroupMemberIsNotInTheSameTeam + + notifyAdmins :: UserGroup -> Sem r () + notifyAdmins ug = do + admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team + pushNotifications + [ mmkEvent mbCreator (UserGroupCreated ug.id_) admins + ] getTeamAsAdmin :: ( Member UserSubsystem r, From 6876035241d800a984584294800a7fc2127917e2 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 5 Nov 2025 17:44:35 +0100 Subject: [PATCH 27/30] Fix integration test. --- integration/test/Test/Spar.hs | 60 ++++++++++++++--------------------- 1 file changed, 24 insertions(+), 36 deletions(-) diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index 111c75ec1b..904a1c7671 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -16,7 +16,6 @@ import qualified Data.Aeson.Types as A import qualified Data.CaseInsensitive as CI import Data.String.Conversions (cs) import qualified Data.Text as ST -import Debug.Trace import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified SAML2.WebSSO.Test.Util as SAML @@ -371,50 +370,39 @@ testSparScimCreateUserGroup = do (owner, tid, _) <- createTeam OwnDomain 1 tok <- createScimTokenV6 owner def >>= \resp -> resp.json %. "token" >>= asString - -- f0, f1, ... are stolen from other tests in this module, but they don't wokr quite yet. - - {- - let _f0 :: App String - _f0 = do - void $ setTeamFeatureStatus owner tid "sso" "enabled" - void $ registerTestIdPWithMeta owner >>= getJSON 201 - email <- randomEmail - extId <- randomExternalId - scimUser <- randomScimUserWithEmail extId email - scimUserId <- createScimUser OwnDomain tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString - bindResponse (getUsersId OwnDomain [scimUserId]) $ \res -> do - res.status `shouldMatchInt` 200 - asString (res.json %. "[0].id") `shouldMatch` [scimUserId] - pure scimUserId - - -} - - let f1 :: App String - f1 = do + let -- this function looks messy and may be overdoing it in the head + -- of the debate with the compiler. its only purpose is to make + -- a team member that satisfies all conditions for being added + -- to a scim group. + mkMemberCandidate :: App String + mkMemberCandidate = do assertSuccess =<< setTeamFeatureStatus owner tid "validateSAMLemails" "disabled" assertSuccess =<< setTeamFeatureStatus owner tid "sso" "enabled" void $ registerTestIdPWithMetaWithPrivateCreds owner - scimUser <- - randomScimUserWith - def - { mkExternalId = randomEmail, - prependExternalIdToEmails = False, - mkOtherEmails = pure [] - } + scimUserEmail <- randomEmail + scimUser <- randomScimUserWith def {mkExternalId = pure scimUserEmail} uid <- createScimUser owner tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + quid <- do + dom <- make OwnDomain >>= asString + pure $ object ["domain" .= dom, "id" .= uid] getScimUser OwnDomain tok uid `bindResponse` \res -> do res.status `shouldMatchInt` 200 res.json %. "id" `shouldMatch` uid - traceM (show owner) - traceM (show tid) - traceM . show =<< res.json -- if this looks right (team, - -- id), then maybe there is another bug in scim group - -- creation, not the test? - pure uid - - scimUserId :: String <- f1 + + registerInvitedUser OwnDomain tid scimUserEmail + + getSelf quid `bindResponse` \res -> do + res.status `shouldMatchInt` 200 + res.json %. "id" `shouldMatch` uid + res.json %. "team" `shouldMatch` tid + res.json %. "status" `shouldMatch` "active" + res.json %. "managed_by" `shouldMatch` "scim" + + pure uid + + scimUserId <- mkMemberCandidate let scimUserGroup = object [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:Group"], From 1a6c529d5e4d5f33a4edefa8f9aab014b48fdb95 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 5 Nov 2025 20:44:56 +0100 Subject: [PATCH 28/30] refactor: merge spar BrigAccess to wire-subsystem BrigAPIAccess --- .../wire-subsystems/src/Wire/BrigAPIAccess.hs | 49 ++ .../src/Wire/BrigAPIAccess/Rpc.hs | 445 ++++++++++++++++- libs/wire-subsystems/wire-subsystems.cabal | 2 + services/galley/src/Galley/API/LegalHold.hs | 2 +- services/spar/spar.cabal | 15 +- services/spar/src/Spar/API.hs | 36 +- services/spar/src/Spar/App.hs | 26 +- .../spar/src/Spar/CanonicalInterpreter.hs | 9 +- services/spar/src/Spar/Intra/Brig.hs | 455 ------------------ services/spar/src/Spar/Intra/BrigApp.hs | 12 +- services/spar/src/Spar/Scim.hs | 4 +- services/spar/src/Spar/Scim/Auth.hs | 20 +- services/spar/src/Spar/Scim/User.hs | 101 ++-- services/spar/src/Spar/Sem/BrigAccess.hs | 86 ---- services/spar/src/Spar/Sem/BrigAccess/Http.hs | 67 --- services/spar/src/Spar/Sem/Utils.hs | 11 - services/spar/test-integration/Main.hs | 2 - .../test-integration/Test/Spar/APISpec.hs | 4 +- .../Test/Spar/Intra/BrigSpec.hs | 65 --- .../Test/Spar/Scim/UserSpec.hs | 62 +-- services/spar/test-integration/Util/Core.hs | 18 +- .../spar/test/Test/Spar/Intra/BrigSpec.hs | 75 --- services/spar/test/Test/Spar/Scim/UserSpec.hs | 37 +- 23 files changed, 651 insertions(+), 952 deletions(-) delete mode 100644 services/spar/src/Spar/Intra/Brig.hs delete mode 100644 services/spar/src/Spar/Sem/BrigAccess.hs delete mode 100644 services/spar/src/Spar/Sem/BrigAccess/Http.hs delete mode 100644 services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs delete mode 100644 services/spar/test/Test/Spar/Intra/BrigSpec.hs diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs index dad24dd215..73c58d93c8 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess.hs @@ -21,6 +21,27 @@ module Wire.BrigAPIAccess getUserExportData, updateSearchIndex, getAccountsBy, + createSAML, + createNoSAML, + updateEmail, + getAccount, + getByHandle, + getByEmail, + setName, + setHandle, + setManagedBy, + setSSOId, + setRichInfo, + setLocale, + getRichInfo, + checkHandleAvailable, + ensureReAuthorised, + ssoLogin, + getStatus, + getStatusMaybe, + setStatus, + getDefaultUserLocale, + checkAdminGetTeamId, -- * Teams getSize, @@ -52,6 +73,9 @@ where import Data.Aeson import Data.ByteString.Conversion +import Data.Code as Code +import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id import Data.Misc import Data.Qualified @@ -59,14 +83,18 @@ import Imports import Network.HTTP.Types.Status import Polysemy import Polysemy.Error +import SAML2.WebSSO qualified as SAML +import Web.Cookie import Wire.API.Connection import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig (GetBy) import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Team.Export import Wire.API.Team.Feature +import Wire.API.Team.Role import Wire.API.Team.Size import Wire.API.User import Wire.API.User.Auth.ReAuth @@ -132,6 +160,27 @@ data BrigAPIAccess m a where UpdateSearchIndex :: UserId -> BrigAPIAccess m () GetAccountsBy :: GetBy -> BrigAPIAccess m [User] CreateGroupFull :: ManagedBy -> TeamId -> Maybe UserId -> NewUserGroup -> BrigAPIAccess m UserGroup + CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAPIAccess m UserId + CreateNoSAML :: Text -> EmailAddress -> UserId -> TeamId -> Name -> Maybe Locale -> Role -> BrigAPIAccess m UserId + UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAPIAccess m () + GetAccount :: HavePendingInvitations -> UserId -> BrigAPIAccess m (Maybe User) + GetByHandle :: Handle -> BrigAPIAccess m (Maybe User) + GetByEmail :: EmailAddress -> BrigAPIAccess m (Maybe User) + SetName :: UserId -> Name -> BrigAPIAccess m () + SetHandle :: UserId -> Handle -> BrigAPIAccess m () + SetManagedBy :: UserId -> ManagedBy -> BrigAPIAccess m () + SetSSOId :: UserId -> UserSSOId -> BrigAPIAccess m () + SetRichInfo :: UserId -> RichInfo -> BrigAPIAccess m () + SetLocale :: UserId -> Maybe Locale -> BrigAPIAccess m () + GetRichInfo :: UserId -> BrigAPIAccess m RichInfo + CheckHandleAvailable :: Handle -> BrigAPIAccess m Bool + EnsureReAuthorised :: Maybe UserId -> Maybe PlainTextPassword6 -> Maybe Code.Value -> Maybe VerificationAction -> BrigAPIAccess m () + SsoLogin :: UserId -> BrigAPIAccess m SetCookie + GetStatus :: UserId -> BrigAPIAccess m AccountStatus + GetStatusMaybe :: UserId -> BrigAPIAccess m (Maybe AccountStatus) + SetStatus :: UserId -> AccountStatus -> BrigAPIAccess m () + GetDefaultUserLocale :: BrigAPIAccess m Locale + CheckAdminGetTeamId :: UserId -> BrigAPIAccess m TeamId makeSem ''BrigAPIAccess diff --git a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs index 6235ec09e7..c5bbb5409d 100644 --- a/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/BrigAPIAccess/Rpc.hs @@ -1,15 +1,20 @@ module Wire.BrigAPIAccess.Rpc where import Bilge +import Brig.Types.Intra (NewUserScimInvitation (..)) import Control.Monad.Catch (throwM) import Data.Aeson import Data.ByteString.Char8 qualified as BSC import Data.ByteString.Conversion +import Data.Code as Code +import Data.Handle (Handle (fromHandle)) +import Data.HavePendingInvitations import Data.Id import Data.Misc import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as Lazy import Imports import Network.HTTP.Client (HttpExceptionContent (..)) import Network.HTTP.Client qualified as Http @@ -20,12 +25,14 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog -import System.IO.Unsafe +import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Logger import Util.Options +import Web.Cookie import Web.HttpApiData import Wire.API.Connection import Wire.API.Error.Galley +import Wire.API.Locale import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig (CreateGroupFullRequest (..), GetBy) import Wire.API.Routes.Internal.Brig.Connection @@ -33,10 +40,12 @@ import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Mul import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.LegalHold.Internal +import Wire.API.Team.Role import Wire.API.Team.Size -import Wire.API.User (UpdateConnectionsInternal, User, UserIds (..), UserSet (..)) +import Wire.API.User (AccountStatus, AccountStatusResp (..), AccountStatusUpdate (..), EmailActivation (..), EmailAddress, EmailUpdate (..), HandleUpdate (..), LocaleUpdate (..), ManagedByUpdate (..), Name (..), NameUpdate (..), NewUserSpar (..), RichInfoUpdate (..), SelfProfile (..), UpdateConnectionsInternal, User, UserIds (..), UserSSOId (..), UserSet (..), VerificationAction, fromAccountStatusResp, userDeleted, userEmail, userId) import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth +import Wire.API.User.Auth.Sso qualified as UserSso import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.Profile (ManagedBy) @@ -106,6 +115,48 @@ interpretBrigAccess brigEndpoint = getAccountsBy localGetBy CreateGroupFull managedBy teamId creatorUserId newGroup -> createGroupFull managedBy teamId creatorUserId newGroup + CreateSAML uref uid teamid name managedBy handle richInfo mLocale role -> + createBrigUserSAML uref uid teamid name managedBy handle richInfo mLocale role + CreateNoSAML extId email uid teamid name locale role -> + createBrigUserNoSAML extId email uid teamid name locale role + UpdateEmail uid email activation -> + updateEmailAddress uid email activation + GetAccount havePending uid -> + getAccount havePending uid + GetByHandle handle -> + getByHandle handle + GetByEmail email -> + getByEmail email + SetName uid name -> + setName uid name + SetHandle uid handle -> + setHandle uid handle + SetManagedBy uid managedBy -> + setManagedBy uid managedBy + SetSSOId uid ssoId -> + setSSOId uid ssoId + SetRichInfo uid richInfo -> + setRichInfo uid richInfo + SetLocale uid locale -> + setLocale uid locale + GetRichInfo uid -> + getRichInfo uid + CheckHandleAvailable handle -> + checkHandleAvailable handle + EnsureReAuthorised muid mpwd mcode maction -> + ensureReAuthorised muid mpwd mcode maction + SsoLogin uid -> + ssoLogin uid + GetStatus uid -> + getAccountStatus uid + GetStatusMaybe uid -> + getAccountStatusMaybe uid + SetStatus uid status -> + setAccountStatus uid status + GetDefaultUserLocale -> + getDefaultUserLocale + CheckAdminGetTeamId uid -> + checkAdminGetTeamId uid brigRequest :: (Member Rpc r, Member (Input Endpoint) r) => (Request -> Request) -> Sem r (Response (Maybe LByteString)) brigRequest req = do @@ -555,3 +606,393 @@ createGroupFull managedBy teamId creatorUserId newGroup = do . json req . expect2xx decodeBodyOrThrow "brig" r + +-- | Helper function to convert response to SetCookie. +respToCookie :: (Member (Error ParseException) r) => ResponseLBS -> Sem r SetCookie +respToCookie resp = do + unless (statusCode resp == 200) $ throw $ ParseException "brig" "Expected 200 status code" + case getHeader "Set-Cookie" resp of + Nothing -> throw $ ParseException "brig" "Could not retrieve cookie" + Just cookieHeader -> pure $ parseSetCookie cookieHeader + +createBrigUserSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + SAML.UserRef -> + UserId -> + TeamId -> + Name -> + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + Maybe Locale -> + Role -> + Sem r UserId +createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do + let newUser = + NewUserSpar + { newUserSparUUID = buid, + newUserSparDisplayName = name, + newUserSparSSOId = UserSSOId uref, + newUserSparTeamId = teamid, + newUserSparManagedBy = managedBy, + newUserSparHandle = handle, + newUserSparRichInfo = richInfo, + newUserSparLocale = mLocale, + newUserSparRole = role + } + resp <- + brigRequest $ + method POST + . path "/i/users/spar" + . json newUser + if statusCode resp `elem` [200, 201] + then userId . selfUser <$> decodeBodyOrThrow @SelfProfile "brig" resp + else throw $ ParseException "brig" ("Failed to create SAML user: " ++ show (statusCode resp)) + +createBrigUserNoSAML :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Text -> + EmailAddress -> + UserId -> + TeamId -> + Name -> + Maybe Locale -> + Role -> + Sem r UserId +createBrigUserNoSAML extId email uid teamid uname locale role = do + let newUser = NewUserScimInvitation teamid uid extId locale uname email role + resp <- + brigRequest $ + method POST + . paths ["/i/teams", toByteString' teamid, "invitations"] + . json newUser + if statusCode resp `elem` [200, 201] + then userId <$> decodeBodyOrThrow @User "brig" resp + else throw $ ParseException "brig" ("Failed to create user from SCIM invitation: " ++ show (statusCode resp)) + +updateEmailAddress :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + EmailAddress -> + EmailActivation -> + Sem r () +updateEmailAddress buid email activation = do + resp <- + brigRequest $ + method PUT + . path "/i/self/email" + . header "Z-User" (toByteString' buid) + . query + [ ("activation", Just (toByteString' activation)), + ("validate", Just (boolToBS validate)), + ("activate", Just (boolToBS activate)) + ] + . json (EmailUpdate email) + case statusCode resp of + 204 -> pure () + 202 -> pure () + _ -> throw $ ParseException "brig" ("Failed to update email: " ++ show (statusCode resp)) + where + (validate, activate) = case activation of + AutoActivate -> (False, True) + SendActivationEmail -> (True, False) + boolToBS :: Bool -> ByteString + boolToBS True = "true" + boolToBS False = "false" + +getAccount :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + HavePendingInvitations -> + UserId -> + Sem r (Maybe User) +getAccount havePending buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users"] + . query + [ ("ids", Just $ toByteString' buid), + ( "includePendingInvitations", + Just . toByteString' $ + case havePending of + WithPendingInvitations -> True + NoPendingInvitations -> False + ) + ] + case statusCode resp of + 200 -> + decodeBodyOrThrow @[User] "brig" resp >>= \case + [account] -> + pure $ + if userDeleted account + then Nothing + else Just account + _ -> pure Nothing + 404 -> pure Nothing + _ -> throw $ ParseException "brig" ("Failed to get account: " ++ show (statusCode resp)) + +getByHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Handle -> + Sem r (Maybe User) +getByHandle handle = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "handles" (toByteString' handle) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + 404 -> pure Nothing + _ -> throw $ ParseException "brig" ("Failed to get user by handle: " ++ show (statusCode resp)) + +getByEmail :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + EmailAddress -> + Sem r (Maybe User) +getByEmail email = do + resp <- + brigRequest $ + method GET + . path "/i/users" + . queryItem "email" (toByteString' email) + . queryItem "includePendingInvitations" "true" + case statusCode resp of + 200 -> do + macc <- listToMaybe <$> decodeBodyOrThrow @[User] "brig" resp + case userEmail =<< macc of + Just email' | email' == email -> pure macc + _ -> pure Nothing + 404 -> pure Nothing + _ -> throw $ ParseException "brig" ("Failed to get user by email: " ++ show (statusCode resp)) + +setName :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Name -> + Sem r () +setName buid (Name name) = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "name"] + . json (NameUpdate name) + let sCode = statusCode resp + if sCode < 300 + then pure () + else throw $ ParseException "brig" ("Failed to set user name: " ++ show sCode) + +setHandle :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Handle -> + Sem r () +setHandle buid handle = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "handle"] + . json (HandleUpdate (fromHandle handle)) + case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of + (200, Nothing) -> + pure () + _ -> + throw $ ParseException "brig" ("Failed to set user handle: " ++ show (statusCode resp)) + +setManagedBy :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + ManagedBy -> + Sem r () +setManagedBy buid managedBy = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' buid, "managed-by"] + . json (ManagedByUpdate managedBy) + unless (statusCode resp == 200) $ + throw $ + ParseException "brig" ("Failed to set user managedBy: " ++ show (statusCode resp)) + +setSSOId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + UserSSOId -> + Sem r () +setSSOId buid ssoId = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "sso-id"] + . json ssoId + case statusCode resp of + 200 -> pure () + _ -> throw $ ParseException "brig" ("Failed to set user SSO ID: " ++ show (statusCode resp)) + +setRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + RichInfo -> + Sem r () +setRichInfo buid richInfo = do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "rich-info"] + . json (RichInfoUpdate $ unRichInfo richInfo) + unless (statusCode resp == 200) $ + throw $ + ParseException "brig" ("Failed to set user rich info: " ++ show (statusCode resp)) + +setLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Maybe Locale -> + Sem r () +setLocale buid = \case + Just locale -> do + resp <- + brigRequest $ + method PUT + . paths ["i", "users", toByteString' buid, "locale"] + . json (LocaleUpdate locale) + unless (statusCode resp == 200) $ + throw $ + ParseException "brig" ("Failed to set user locale: " ++ show (statusCode resp)) + Nothing -> do + resp <- + brigRequest $ + method DELETE + . paths ["i", "users", toByteString' buid, "locale"] + unless (statusCode resp == 200) $ + throw $ + ParseException "brig" ("Failed to delete user locale: " ++ show (statusCode resp)) + +getRichInfo :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Sem r RichInfo +getRichInfo buid = do + resp <- + brigRequest $ + method GET + . paths ["/i/users", toByteString' buid, "rich-info"] + case statusCode resp of + 200 -> decodeBodyOrThrow "brig" resp + _ -> throw $ ParseException "brig" ("Failed to get user rich info: " ++ show (statusCode resp)) + +checkHandleAvailable :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Handle -> + Sem r Bool +checkHandleAvailable hnd = do + resp <- + brigRequest $ + method HEAD + . paths ["/i/users/handles", toByteString' hnd] + let sCode = statusCode resp + if + | sCode == 200 -> pure False + | sCode == 404 -> pure True + | otherwise -> throw $ ParseException "brig" ("Failed to check handle availability: " ++ show sCode) + +ensureReAuthorised :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Maybe UserId -> + Maybe PlainTextPassword6 -> + Maybe Code.Value -> + Maybe VerificationAction -> + Sem r () +ensureReAuthorised Nothing _ _ _ = throw $ ParseException "brig" "Missing Z-User header" +ensureReAuthorised (Just uid) secret mbCode mbAction = do + resp <- + brigRequest $ + method GET + . paths ["/i/users", toByteString' uid, "reauthenticate"] + . json (ReAuthUser secret mbCode mbAction) + case (statusCode resp, errorLabel resp) of + (200, _) -> pure () + (403, Just "code-authentication-required") -> throw $ ParseException "brig" "Code authentication required" + (403, Just "code-authentication-failed") -> throw $ ParseException "brig" "Code authentication failed" + (403, _) -> throw $ ParseException "brig" "Re-authentication required" + (_, _) -> throw $ ParseException "brig" ("Re-authentication failed: " ++ show (statusCode resp)) + where + errorLabel :: ResponseLBS -> Maybe Lazy.Text + errorLabel = fmap Wai.label . responseJsonMaybe + +ssoLogin :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Sem r SetCookie +ssoLogin buid = do + resp <- + brigRequest $ + method POST + . path "/i/sso-login" + . json (UserSso.SsoLogin buid Nothing) + . queryItem "persist" "true" + if statusCode resp == 200 + then respToCookie resp + else throw $ ParseException "brig" ("SSO login failed: " ++ show (statusCode resp)) + +getAccountStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Sem r AccountStatus +getAccountStatus uid = do + resp <- getStatusResp uid + case statusCode resp of + 200 -> fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + _ -> throw $ ParseException "brig" ("Failed to get account status: " ++ show (statusCode resp)) + +getAccountStatusMaybe :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Sem r (Maybe AccountStatus) +getAccountStatusMaybe uid = do + resp <- getStatusResp uid + case statusCode resp of + 200 -> Just . fromAccountStatusResp <$> decodeBodyOrThrow @AccountStatusResp "brig" resp + 404 -> pure Nothing + _ -> throw $ ParseException "brig" ("Failed to get account status: " ++ show (statusCode resp)) + +getStatusResp :: + (Member Rpc r, Member (Input Endpoint) r) => + UserId -> + Sem r ResponseLBS +getStatusResp uid = brigRequest $ method GET . paths ["/i/users", toByteString' uid, "status"] + +setAccountStatus :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + AccountStatus -> + Sem r () +setAccountStatus uid status = do + resp <- + brigRequest $ + method PUT + . paths ["/i/users", toByteString' uid, "status"] + . json (AccountStatusUpdate status) + case statusCode resp of + 200 -> pure () + _ -> throw $ ParseException "brig" ("Failed to set account status: " ++ show (statusCode resp)) + +getDefaultUserLocale :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + Sem r Locale +getDefaultUserLocale = do + resp <- brigRequest $ method GET . paths ["/i/users/locale"] + case statusCode resp of + 200 -> luLocale <$> decodeBodyOrThrow @LocaleUpdate "brig" resp + _ -> throw $ ParseException "brig" ("Failed to get default user locale: " ++ show (statusCode resp)) + +checkAdminGetTeamId :: + (Member Rpc r, Member (Input Endpoint) r, Member (Error ParseException) r) => + UserId -> + Sem r TeamId +checkAdminGetTeamId uid = do + resp <- brigRequest $ method GET . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] + case statusCode resp of + 200 -> decodeBodyOrThrow @TeamId "brig" resp + _ -> throw $ ParseException "brig" ("Failed to check admin and get team ID: " ++ show (statusCode resp)) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 42480a8a7b..2b452e2f36 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -90,6 +90,7 @@ common common-all , base64-bytestring , bilge , bloodhound + , brig-types , bytestring , bytestring-conversion , case-insensitive @@ -97,6 +98,7 @@ common common-all , conduit , containers , contravariant + , cookie , cql , crypton , currency-codes diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 8de1a0c435..37dce697b2 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -77,7 +77,7 @@ import Wire.API.Team.LegalHold qualified as Public import Wire.API.Team.LegalHold.External hiding (userId) import Wire.API.Team.Member import Wire.API.User.Client.Prekey -import Wire.BrigAPIAccess +import Wire.BrigAPIAccess hiding (ensureReAuthorised) import Wire.ConversationStore import Wire.NotificationSubsystem import Wire.Sem.Now (Now) diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 2bf83cf330..833503458a 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -22,7 +22,6 @@ library Spar.Data Spar.Data.Instances Spar.Error - Spar.Intra.Brig Spar.Intra.BrigApp Spar.Intra.Galley Spar.Options @@ -61,8 +60,6 @@ library Spar.Sem.AssIDStore Spar.Sem.AssIDStore.Cassandra Spar.Sem.AssIDStore.Mem - Spar.Sem.BrigAccess - Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra Spar.Sem.DefaultSsoCode.Mem @@ -168,16 +165,10 @@ library , crypton-x509 , exceptions , extended - , hasql-pool , hscim - , HsOpenSSL , hspec - , http-client - , http-client-openssl , http-types - , http2-manager , imports - , iso639 , lens , metrics-wai , mtl @@ -199,7 +190,6 @@ library , tinylog , transformers , types-common - , unordered-containers , uri-bytestring , utf8-string , uuid @@ -285,7 +275,6 @@ executable spar-integration Test.Spar.APISpec Test.Spar.AppSpec Test.Spar.DataSpec - Test.Spar.Intra.BrigSpec Test.Spar.Scim.AuthSpec Test.Spar.Scim.UserSpec Util @@ -406,6 +395,7 @@ executable spar-integration , wai-extra , wai-utilities , wire-api + , wire-subsystems , xml-conduit , yaml , zauth @@ -557,7 +547,6 @@ test-suite spec Paths_spar Test.Spar.APISpec Test.Spar.DataSpec - Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString Test.Spar.Scim.UserSpec Test.Spar.ScimSpec @@ -647,12 +636,12 @@ test-suite spec , spar , string-conversions , text - , these , time , tinylog , types-common , uri-bytestring , uuid , wire-api + , wire-subsystems default-language: Haskell2010 diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 6224146fb2..ebf7400639 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -81,8 +81,6 @@ import Spar.Orphans () import Spar.Scim hiding (handle) import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AssIDStore (AssIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode import Spar.Sem.GalleyAccess (GalleyAccess) @@ -114,6 +112,8 @@ import Wire.API.Team.Member (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp)) import Wire.API.User import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) +import qualified Wire.BrigAPIAccess as BrigAccess import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger @@ -142,7 +142,7 @@ app ctx0 req cont = do api :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member AssIDStore r, Member AReqIDStore r, @@ -182,7 +182,7 @@ apiSSO :: ( Member GalleyAccess r, Member (Logger String) r, Member (Input Opts) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -212,7 +212,7 @@ apiIDP :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -239,7 +239,7 @@ apiINTERNAL :: Member (Logger String) r, Member Random r, Member GalleyAccess r, - Member BrigAccess r + Member BrigAPIAccess r ) => ServerT InternalAPI (Sem r) apiINTERNAL = @@ -360,7 +360,7 @@ authresp :: Member (Logger String) r, Member (Input Opts) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, Member AReqIDStore r, @@ -471,7 +471,7 @@ idpGet :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -485,7 +485,7 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do idpGetRaw :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -504,7 +504,7 @@ idpGetAll :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -518,7 +518,7 @@ idpGetAllByTeamId :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -541,7 +541,7 @@ idpDelete :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member SAMLUserStore r, Member IdPConfigStore r, @@ -625,7 +625,7 @@ idpCreate :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -652,7 +652,7 @@ idpCreateV7 :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -753,7 +753,7 @@ idpUpdate :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -769,7 +769,7 @@ idpUpdateXML :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, Member (Error SparError) r @@ -809,7 +809,7 @@ validateIdPUpdate :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -875,7 +875,7 @@ withDebugLog msg showval action = do authorizeIdP :: ( HasCallStack, ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Error SparError) r ) ) => diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 2190cbd51c..f6dfe59605 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -76,8 +76,6 @@ import qualified Spar.Intra.BrigApp as Intra import Spar.Options import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPConfigStore (IdPConfigStore) @@ -99,6 +97,8 @@ import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User import Wire.API.User.IdentityProvider import Wire.API.User.Saml +import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) +import qualified Wire.BrigAPIAccess as BrigAccess import Wire.Error import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger (Logger) @@ -140,7 +140,7 @@ data Env = Env -- -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefUnsafe :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> @@ -150,7 +150,7 @@ getUserByUrefUnsafe uref = do -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r ) => TeamId -> @@ -183,7 +183,7 @@ getUserIdByScimExternalId tid eid = do -- undeletable in the team admin page, and ask admins to go talk to their IdP system. createSamlUserWithId :: ( Member (Error SparError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => TeamId -> @@ -205,7 +205,7 @@ createSamlUserWithId teamid buid suid role = do autoprovisionSamlUser :: forall r. ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -239,7 +239,7 @@ autoprovisionSamlUser idp buid suid = do validateSamlEmailIfExists :: forall r. ( Member GalleyAccess r, - Member BrigAccess r + Member BrigAPIAccess r ) => UserId -> SAML.UserRef -> @@ -253,7 +253,7 @@ validateSamlEmailIfExists uid = \case validateEmail :: forall r. ( Member GalleyAccess r, - Member BrigAccess r + Member BrigAPIAccess r ) => Maybe TeamId -> UserId -> @@ -279,7 +279,7 @@ verdictHandler :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member AReqIDStore r, Member VerdictFormatStore r, Member ScimTokenStore r, @@ -326,7 +326,7 @@ verdictHandlerResult :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, @@ -371,7 +371,7 @@ catchVerdictErrors = (`catch` hndlr) -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefViaOldIssuerUnsafe :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => IdP -> @@ -389,7 +389,7 @@ getUserByUrefViaOldIssuerUnsafe idp (SAML.UserRef _ subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. moveUserToNewIssuer :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r ) => SAML.UserRef -> @@ -406,7 +406,7 @@ verdictHandlerResultCore :: ( Member Random r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member (Error SparError) r, diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index bd3b3d82db..453c6a7ccf 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -33,6 +33,7 @@ import Polysemy.Error import Polysemy.Input (Input, runInputConst) import Polysemy.Internal.Kind import Polysemy.TinyLog hiding (err) +import qualified SAML2.WebSSO as SAML import Servant import Spar.App hiding (sparToServerErrorWithLogging) import Spar.Error @@ -42,8 +43,6 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) -import Spar.Sem.BrigAccess (BrigAccess) -import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) import Spar.Sem.GalleyAccess (GalleyAccess) @@ -107,7 +106,6 @@ type LowerLevelCanonicalEffs = IdPRawMetadataStore, SAMLUserStore, Embed Cas.Client, - BrigAccess, GalleyAccess, Error IdpDbError, Error TTLError, @@ -138,7 +136,6 @@ runSparToIO ctx = . ttlErrorToSparError . idpDbErrorToSparError . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) - . brigAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) . interpretClientToIO (sparCtxCas ctx) . samlUserStoreToCassandra . idpRawMetadataStoreToCassandra @@ -160,8 +157,8 @@ runSparToIO ctx = . interpretBrigAccess ctx.sparCtxOpts.brig . interpretScimSubsystem -iParseException :: (Member (Error SparError) r) => InterpreterFor (Error ParseException) r -iParseException = Polysemy.Error.mapError (httpErrorToSparError . parseExceptionToHttpError) +iParseException :: (Member (Error SparError) r) => Sem (Error ParseException : r) a -> Sem r a +iParseException = mapError (SAML.CustomError . SparSomeHttpError . parseExceptionToHttpError) runSparToHandler :: Env -> Sem CanonicalEffs a -> Handler a runSparToHandler ctx spar = do diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs deleted file mode 100644 index fee2e54616..0000000000 --- a/services/spar/src/Spar/Intra/Brig.hs +++ /dev/null @@ -1,455 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- 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 . - --- | Client functions for interacting with the Brig API. -module Spar.Intra.Brig - ( MonadSparToBrig (..), - getBrigUserAccount, - getBrigUserByHandle, - getBrigUserByEmail, - getBrigUserRichInfo, - setBrigUserName, - setBrigUserHandle, - setBrigUserManagedBy, - setBrigUserSSOId, - setBrigUserRichInfo, - setBrigUserLocale, - checkHandleAvailable, - deleteBrigUserInternal, - createBrigUserSAML, - createBrigUserNoSAML, - updateEmail, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - ) -where - -import Bilge -import Brig.Types.Intra -import Brig.Types.User -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Code as Code -import Data.Handle (Handle (fromHandle)) -import Data.Id (Id (Id), TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import qualified Data.Text.Lazy as Lazy -import Imports -import Network.HTTP.Types.Method -import qualified Network.Wai.Utilities.Error as Wai -import qualified SAML2.WebSSO as SAML -import Spar.Error -import qualified System.Logger.Class as Log -import Web.Cookie -import Wire.API.Locale -import Wire.API.Team.Role (Role) -import Wire.API.User -import Wire.API.User.Auth.ReAuth -import Wire.API.User.Auth.Sso -import Wire.API.User.RichInfo as RichInfo -import Wire.UserSubsystem (HavePendingInvitations (..)) - ----------------------------------------------------------------------- - --- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the --- cookie in the response, and the redirect will make the client negotiate a fresh auth token. --- (This is the easiest way, since the login-request that we are in the middle of responding to here --- is not from the wire client, but from a browser that is still processing a redirect from the --- IdP.) -respToCookie :: (HasCallStack, MonadError SparError m) => ResponseLBS -> m SetCookie -respToCookie resp = do - let crash = throwSpar SparCouldNotRetrieveCookie - unless (statusCode resp == 200) crash - maybe crash (pure . parseSetCookie) $ getHeader "Set-Cookie" resp - ----------------------------------------------------------------------- - -class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where - call :: (Request -> Request) -> m ResponseLBS - -createBrigUserSAML :: - (HasCallStack, MonadSparToBrig m) => - SAML.UserRef -> - UserId -> - TeamId -> - -- | User name - Name -> - -- | Who should have control over the user - ManagedBy -> - Maybe Handle -> - Maybe RichInfo -> - Maybe Locale -> - Role -> - m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do - let newUser = - NewUserSpar - { newUserSparUUID = buid, - newUserSparDisplayName = name, - newUserSparSSOId = UserSSOId uref, - newUserSparTeamId = teamid, - newUserSparManagedBy = managedBy, - newUserSparHandle = handle, - newUserSparRichInfo = richInfo, - newUserSparLocale = mLocale, - newUserSparRole = role - } - resp :: ResponseLBS <- - call $ - method POST - . path "/i/users/spar" - . json newUser - if statusCode resp `elem` [200, 201] - then userId . selfUser <$> parseResponse @SelfProfile "brig" resp - else rethrow "brig" resp - -createBrigUserNoSAML :: - (HasCallStack, MonadSparToBrig m) => - Text -> - EmailAddress -> - UserId -> - TeamId -> - -- | User name - Name -> - Maybe Locale -> - Role -> - m UserId -createBrigUserNoSAML extId email uid teamid uname locale role = do - let newUser = NewUserScimInvitation teamid uid extId locale uname email role - resp :: ResponseLBS <- - call $ - method POST - . paths ["/i/teams", toByteString' teamid, "invitations"] - . json newUser - - if statusCode resp `elem` [200, 201] - then userId <$> parseResponse @User "brig" resp - else rethrow "brig" resp - -updateEmail :: (HasCallStack, MonadSparToBrig m) => UserId -> EmailAddress -> EmailActivation -> m () -updateEmail buid email activation = do - resp <- - call $ - method PUT - . path "/i/self/email" - . header "Z-User" (toByteString' buid) - . query - [ ("activation", Just (toByteString' activation)), - -- FUTUREWORK: the following two are for backwards compatibility during deployment - -- of the release containing https://github.com/wireapp/wire-server/pull/4617, can - -- be removed later (fisx, 2025-06-19) - ("validate", Just (fromBool validate)), - ("activate", Just (fromBool activate)) - ] - . json (EmailUpdate email) - case statusCode resp of - 204 -> pure () - 202 -> pure () - _ -> rethrow "brig" resp - where - (validate, activate) = case activation of - AutoActivate -> (False, True) - SendActivationEmail -> (True, False) - - fromBool :: Bool -> ByteString - fromBool True = "true" - fromBool False = "false" - --- | Get a user; returns 'Nothing' if the user was not found or has been deleted. -getBrigUserAccount :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe User) -getBrigUserAccount havePending buid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["/i/users"] - . query - [ ("ids", Just $ toByteString' buid), - ( "includePendingInvitations", - Just . toByteString' $ - case havePending of - WithPendingInvitations -> True - NoPendingInvitations -> False - ) - ] - - case statusCode resp of - 200 -> - parseResponse @[User] "brig" resp >>= \case - [account] -> - pure $ - if userDeleted account - then Nothing - else Just account - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Get a user; returns 'Nothing' if the user was not found. --- --- TODO: currently this is not used, but it might be useful later when/if --- @hscim@ stops doing checks during user creation. -getBrigUserByHandle :: (HasCallStack, MonadSparToBrig m) => Handle -> m (Maybe User) -getBrigUserByHandle handle = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "handles" (toByteString' handle) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> listToMaybe <$> parseResponse @[User] "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -getBrigUserByEmail :: (HasCallStack, MonadSparToBrig m) => EmailAddress -> m (Maybe User) -getBrigUserByEmail email = do - resp :: ResponseLBS <- - call $ - method GET - . path "/i/users" - . queryItem "email" (toByteString' email) - . queryItem "includePendingInvitations" "true" - case statusCode resp of - 200 -> do - macc <- listToMaybe <$> parseResponse @[User] "brig" resp - case userEmail =<< macc of - Just email' | email' == email -> pure macc - _ -> pure Nothing - 404 -> pure Nothing - _ -> rethrow "brig" resp - --- | Set user' name. Fails with status <500 if brig fails with <500, and with 500 if brig --- fails with >= 500. -setBrigUserName :: (HasCallStack, MonadSparToBrig m) => UserId -> Name -> m () -setBrigUserName buid (Name name) = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "name"] - . json (NameUpdate name) - let sCode = statusCode resp - if sCode < 300 - then pure () - else rethrow "brig" resp - --- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails --- with >= 500. --- --- NB: that this doesn't take a 'HandleUpdate', since we already construct a valid handle in --- 'validateScimUser' to increase the odds that user creation doesn't fail half-way through --- the many database write operations. -setBrigUserHandle :: (HasCallStack, MonadSparToBrig m) => UserId -> Handle {- not 'HandleUpdate'! -} -> m () -setBrigUserHandle buid handle = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "handle"] - . json (HandleUpdate (fromHandle handle)) - case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of - (200, Nothing) -> - pure () - _ -> - rethrow "brig" resp - --- | Set user's managedBy. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserManagedBy :: (HasCallStack, MonadSparToBrig m) => UserId -> ManagedBy -> m () -setBrigUserManagedBy buid managedBy = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' buid, "managed-by"] - . json (ManagedByUpdate managedBy) - unless (statusCode resp == 200) $ - rethrow "brig" resp - --- | Set user's UserSSOId. -setBrigUserSSOId :: (HasCallStack, MonadSparToBrig m) => UserId -> UserSSOId -> m () -setBrigUserSSOId buid ssoId = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "sso-id"] - . json ssoId - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - --- | Set user's richInfo. Fails with status <500 if brig fails with <500, and with 500 if --- brig fails with >= 500. -setBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> RichInfo -> m () -setBrigUserRichInfo buid richInfo = do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "rich-info"] - . json (RichInfoUpdate $ unRichInfo richInfo) - unless (statusCode resp == 200) $ - rethrow "brig" resp - -setBrigUserLocale :: (HasCallStack, MonadSparToBrig m) => UserId -> Maybe Locale -> m () -setBrigUserLocale buid = \case - Just locale -> do - resp <- - call $ - method PUT - . paths ["i", "users", toByteString' buid, "locale"] - . json (LocaleUpdate locale) - unless (statusCode resp == 200) $ - rethrow "brig" resp - Nothing -> do - resp <- - call $ - method DELETE - . paths ["i", "users", toByteString' buid, "locale"] - unless (statusCode resp == 200) $ - rethrow "brig" resp - -getBrigUserRichInfo :: (HasCallStack, MonadSparToBrig m) => UserId -> m RichInfo -getBrigUserRichInfo buid = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' buid, "rich-info"] - case statusCode resp of - 200 -> parseResponse "brig" resp - _ -> rethrow "brig" resp - -checkHandleAvailable :: (HasCallStack, MonadSparToBrig m) => Handle -> m Bool -checkHandleAvailable hnd = do - resp <- - call $ - method HEAD - . paths ["/i/users/handles", toByteString' hnd] - let sCode = statusCode resp - if - | sCode == 200 -> -- handle exists - pure False - | sCode == 404 -> -- handle not found - pure True - | otherwise -> - rethrow "brig" resp - --- | Call brig to delete a user. --- If the user wasn't deleted completely before, another deletion attempt will be made. -deleteBrigUserInternal :: (HasCallStack, MonadSparToBrig m) => UserId -> m DeleteUserResult -deleteBrigUserInternal buid = do - resp <- - call $ - method DELETE - . paths ["/i/users", toByteString' buid] - case statusCode resp of - 200 -> pure AccountAlreadyDeleted - 202 -> pure AccountDeleted - 404 -> pure NoUser - _ -> rethrow "brig" resp - --- | Verify user's password (needed for certain powerful operations). -ensureReAuthorised :: - (HasCallStack, MonadSparToBrig m) => - Maybe UserId -> - Maybe PlainTextPassword6 -> - Maybe Code.Value -> - Maybe VerificationAction -> - m () -ensureReAuthorised Nothing _ _ _ = throwSpar SparMissingZUsr -ensureReAuthorised (Just uid) secret mbCode mbAction = do - resp <- - call $ - method GET - . paths ["/i/users", toByteString' uid, "reauthenticate"] - . json (ReAuthUser secret mbCode mbAction) - case (statusCode resp, errorLabel resp) of - (200, _) -> pure () - (403, Just "code-authentication-required") -> throwSpar SparReAuthCodeAuthRequired - (403, Just "code-authentication-failed") -> throwSpar SparReAuthCodeAuthFailed - (403, _) -> throwSpar SparReAuthRequired - (_, _) -> rethrow "brig" resp - where - errorLabel :: ResponseLBS -> Maybe Lazy.Text - errorLabel = fmap Wai.label . responseJsonMaybe - --- | Get persistent cookie from brig and redirect user past login process. --- --- If brig responds with status >=400;<500, return Nothing. Otherwise, crash (500). -ssoLogin :: - (HasCallStack, MonadSparToBrig m) => - UserId -> - m SetCookie -ssoLogin buid = do - resp :: ResponseLBS <- - call $ - method POST - . path "/i/sso-login" - . json (SsoLogin buid Nothing) - . queryItem "persist" "true" - if statusCode resp == 200 - then respToCookie resp - else rethrow "brig" resp - -getStatus' :: (HasCallStack, MonadSparToBrig m) => UserId -> m ResponseLBS -getStatus' uid = call $ method GET . paths ["/i/users", toByteString' uid, "status"] - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> m AccountStatus -getStatus uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - _ -> rethrow "brig" resp - --- | FUTUREWORK: this is probably unnecessary, and we can get the status info from 'UserAccount'. -getStatusMaybe :: (HasCallStack, MonadSparToBrig m) => UserId -> m (Maybe AccountStatus) -getStatusMaybe uid = do - resp <- getStatus' uid - case statusCode resp of - 200 -> Just . fromAccountStatusResp <$> parseResponse @AccountStatusResp "brig" resp - 404 -> pure Nothing - _ -> rethrow "brig" resp - -setStatus :: (HasCallStack, MonadSparToBrig m) => UserId -> AccountStatus -> m () -setStatus uid status = do - resp <- - call $ - method PUT - . paths ["/i/users", toByteString' uid, "status"] - . json (AccountStatusUpdate status) - case statusCode resp of - 200 -> pure () - _ -> rethrow "brig" resp - -getDefaultUserLocale :: (HasCallStack, MonadSparToBrig m) => m Locale -getDefaultUserLocale = do - resp <- call $ method GET . paths ["/i/users/locale"] - case statusCode resp of - 200 -> luLocale <$> parseResponse @LocaleUpdate "brig" resp - _ -> rethrow "brig" resp - -checkAdminGetTeamId :: (HasCallStack, MonadSparToBrig m) => UserId -> m TeamId -checkAdminGetTeamId uid = do - resp <- call $ method GET . paths ["/i/users", toByteString' uid, "check-admin-get-team-id"] - case statusCode resp of - 200 -> parseResponse @TeamId "brig" resp - _ -> rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index b14a3a60b2..481f9501b3 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -55,13 +55,13 @@ import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember) import Wire.API.User import Wire.API.User.Scim (ValidScimId (..)) +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAccess ---------------------------------------------------------------------- @@ -124,7 +124,7 @@ mkUserName Nothing = -- | Check that an id maps to an user on brig that is 'Active' (or optionally -- 'PendingInvitation') and has a team id. -getBrigUserTeam :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) +getBrigUserTeam :: (HasCallStack, Member BrigAPIAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAccess.getAccount ifpend -- | Pull team id for z-user from brig. Check permission in galley. Return team id. Fail if @@ -132,7 +132,7 @@ getBrigUserTeam ifpend = fmap (userTeam =<<) . BrigAccess.getAccount ifpend getZUsrCheckPerm :: forall r perm. ( HasCallStack, - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member GalleyAccess r, Member (Error SparError) r ), @@ -152,7 +152,7 @@ getZUsrCheckPerm (Just uid) perm = do authorizeScimTokenManagement :: forall r. ( HasCallStack, - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member GalleyAccess r, Member (Error SparError) r ) @@ -180,7 +180,7 @@ authorizeScimTokenManagement (Just uid) = do -- We cannot simply respond with 404 in this case, because the user exists. 404 would suggest -- do the scim peer that it should post the user to create it, but that would create a new -- user instead of finding the old that should be put under scim control. -giveDefaultHandle :: (HasCallStack, Member BrigAccess r) => User -> Sem r Handle +giveDefaultHandle :: (HasCallStack, Member BrigAPIAccess r) => User -> Sem r Handle giveDefaultHandle usr = case userHandle usr of Just handle -> pure handle Nothing -> do diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 18060c4d64..0b1b0988c8 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -82,7 +82,6 @@ import Spar.Options import Spar.Scim.Auth import Spar.Scim.Group () import Spar.Scim.User -import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.IdPConfigStore (IdPConfigStore) import Spar.Sem.Reporter (Reporter) @@ -100,6 +99,7 @@ import qualified Web.Scim.Schema.Schema as Scim.Schema import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar import Wire.API.User.Scim +import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import Wire.Sem.Now (Now) @@ -121,7 +121,7 @@ apiScim :: Member Now r, Member (Error SparError) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimSubsystem r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 09478cfa51..4ead61f640 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -52,8 +52,6 @@ import Spar.App (throwSparSem) import qualified Spar.Error as E import qualified Spar.Intra.BrigApp as Intra.Brig import Spar.Options -import Spar.Sem.BrigAccess (BrigAccess) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.IdPConfigStore (IdPConfigStore) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore @@ -66,6 +64,8 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public.Spar (APIScimToken) import Wire.API.User as User import Wire.API.User.Scim as Api +import Wire.BrigAPIAccess (BrigAPIAccess) +import qualified Wire.BrigAPIAccess as BrigAccess import Wire.Sem.Now (Now) import qualified Wire.Sem.Now as Now import Wire.Sem.Random (Random) @@ -92,7 +92,7 @@ apiScimToken :: ( Member Random r, Member (Input Opts) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member Now r, Member IdPConfigStore r, @@ -108,7 +108,7 @@ apiScimToken = :<|> Named @"auth-tokens-list" listScimTokens updateScimTokenName :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r, Member GalleyAccess r @@ -129,7 +129,7 @@ createScimTokenV7 :: ( Member Random r, Member (Input Opts) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -168,7 +168,7 @@ createScimToken :: ( Member Random r, Member (Input Opts) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, Member Now r, @@ -188,7 +188,7 @@ guardScimTokenCreation :: forall r. ( Member (Input Opts) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -241,7 +241,7 @@ createScimTokenUnchecked teamid mName desc mIdPId = do -- Delete a token belonging to user's team. deleteScimToken :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -256,7 +256,7 @@ deleteScimToken zusr tokenid = do listScimTokensV7 :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => @@ -277,7 +277,7 @@ listScimTokensV7 zusr = toV7 <$> listScimTokens zusr -- metadata about them. listScimTokens :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r ) => diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index c1dcb6ddfe..4f91773a48 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -74,14 +74,11 @@ import Polysemy.Input import qualified SAML2.WebSSO as SAML import Spar.App (getUserByUrefUnsafe, getUserByUrefViaOldIssuerUnsafe, getUserIdByScimExternalId) import qualified Spar.App -import Spar.Intra.BrigApp as Intra import qualified Spar.Intra.BrigApp as Brig import Spar.Options import Spar.Scim.Auth () import Spar.Scim.Types import qualified Spar.Scim.Types as ST -import Spar.Sem.BrigAccess (BrigAccess, getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPConfigStore (IdPConfigStore) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore @@ -114,6 +111,8 @@ import Wire.API.User.IdentityProvider (IdP) import qualified Wire.API.User.RichInfo as RI import Wire.API.User.Scim (ScimTokenInfo (..), ValidScimId (..)) import qualified Wire.API.User.Scim as ST +import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) +import qualified Wire.BrigAPIAccess as BrigAPIAccess import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Now (Now) @@ -131,7 +130,7 @@ instance Member (Input Opts) r, Member Now r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -208,7 +207,7 @@ validateScimUser :: forall r. ( Member (Logger (Msg -> Msg)) r, Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -230,7 +229,7 @@ validateScimUser errloc tokinfo user = validateScimUserNoLogging :: forall r. ( Member SAMLUserStore r, - Member BrigAccess r, + Member BrigAPIAccess r, Member (Input Opts) r, Member IdPConfigStore r ) => @@ -289,7 +288,7 @@ validateHandle txt = case parseHandle txt of validateScimUser' :: forall r. ( Member (Error Scim.ScimError) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member SAMLUserStore r ) => -- | Error location (call site, for debugging) @@ -377,7 +376,7 @@ validateScimUser' errloc midp richInfoLimit user = do -- recover the 'SAML.UserRef' of the scim user before the update from the database. mkValidScimId :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member SAMLUserStore r, Member (Error Scim.ScimError) r ) => @@ -509,7 +508,7 @@ createValidScimUser :: Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -533,7 +532,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- If this is the case we can safely create the user again, AFTER THE -- HALF-CREATED ACCOUNT HAS BEEN GARBAGE-COLLECTED. -- Otherwise we return a conflict error. - lift (BrigAccess.getStatusMaybe buid) >>= \case + lift (BrigAPIAccess.getStatusMaybe buid) >>= \case Just Active -> throwError (externalIdTakenError ("user with status Active exists: " <> Text.pack (show (externalId, buid)))) Just Suspended -> throwError (externalIdTakenError ("user with status Suspended exists" <> Text.pack (show (externalId, buid)))) Just Ephemeral -> throwError (externalIdTakenError ("user with status Ephemeral exists" <> Text.pack (show (externalId, buid)))) @@ -560,14 +559,14 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- FUTUREWORK: outsource this and some other fragments from -- `createValidScimUser` into a function `createValidScimUserBrig` similar -- to `createValidScimUserSpar`? - void $ BrigAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) + void $ BrigAPIAccess.createSAML uref buid stiTeam name ManagedByScim (Just handle) (Just richInfo) locale (fromMaybe defaultRole role) doEmail email = do - void $ BrigAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) - BrigAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? + void $ BrigAPIAccess.createNoSAML externalId.validScimIdExternal email buid stiTeam name locale (fromMaybe defaultRole role) + BrigAPIAccess.setHandle buid handle -- FUTUREWORK: possibly do the same one req as we do for saml? these doEmail doUref (\_ uref -> doUref uref) (validScimIdAuthInfo externalId) Logger.debug ("createValidScimUser: brig says " <> show buid) - BrigAccess.setRichInfo buid richInfo + BrigAPIAccess.setRichInfo buid richInfo -- {If we crash now, a POST retry will fail with 409 user already exists. -- Azure at some point will retry with GET /Users?filter=userName eq handle @@ -579,7 +578,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- to reload the Account from brig. storedUser <- do acc <- - lift (BrigAccess.getAccount Brig.WithPendingInvitations buid) + lift (BrigAPIAccess.getAccount Brig.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc externalId lift $ Logger.debug ("createValidScimUser: spar says " <> show storedUser) @@ -594,10 +593,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser {..} -- TODO: suspension via scim is brittle, and may leave active users behind: if we don't -- reach the following line due to a crash, the user will be active. lift $ do - old <- BrigAccess.getStatus buid + old <- BrigAPIAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active') active' = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ BrigAccess.setStatus buid new + when (new /= old) $ BrigAPIAccess.setStatus buid new lift $ ScimExternalIdStore.insertStatus stiTeam externalId buid ScimUserCreated pure storedUser @@ -643,7 +642,7 @@ updateValidScimUser :: Member (Logger String) r, Member Now r, Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member IdPConfigStore r, @@ -670,7 +669,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = -- if the locale of the new valid SCIM user is not set, -- we set it to default value from brig - defLocale <- lift BrigAccess.getDefaultUserLocale + defLocale <- lift BrigAPIAccess.getDefaultUserLocale let newValidScimUser = nvsu {ST.locale = ST.locale nvsu <|> Just defLocale} -- assertions about new valid scim user that cannot be checked in 'validateScimUser' because @@ -689,33 +688,33 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = updateVsuUref stiTeam uid (oldValidScimUser.externalId) (newValidScimUser.externalId) when (newValidScimUser.name /= oldValidScimUser.name) $ - BrigAccess.setName uid (newValidScimUser.name) + BrigAPIAccess.setName uid (newValidScimUser.name) when (oldValidScimUser.handle /= newValidScimUser.handle) $ - BrigAccess.setHandle uid (newValidScimUser.handle) + BrigAPIAccess.setHandle uid (newValidScimUser.handle) when (oldValidScimUser.richInfo /= newValidScimUser.richInfo) $ - BrigAccess.setRichInfo uid (newValidScimUser.richInfo) + BrigAPIAccess.setRichInfo uid (newValidScimUser.richInfo) when (oldValidScimUser.locale /= newValidScimUser.locale) $ do - BrigAccess.setLocale uid (newValidScimUser.locale) + BrigAPIAccess.setLocale uid (newValidScimUser.locale) forM_ (newValidScimUser.role) $ \newRole -> do when (oldValidScimUser.role /= Just newRole) $ do GalleyAccess.updateTeamMember uid stiTeam newRole - BrigAccess.getStatusMaybe uid >>= \case + BrigAPIAccess.getStatusMaybe uid >>= \case Nothing -> pure () Just old -> do let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser.active) - when (new /= old) $ BrigAccess.setStatus uid new + when (new /= old) $ BrigAPIAccess.setStatus uid new ScimUserTimesStore.write newScimStoredUser Scim.getUser tokinfo uid updateVsuUref :: ( Member GalleyAccess r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -735,7 +734,7 @@ updateVsuUref team uid old new = do ScimExternalIdStore.insert team new.validScimIdExternal uid for_ (justThere new.validScimIdAuthInfo) (`SAMLUserStore.insert` uid) - BrigAccess.setSSOId uid $ veidToUserSSOId new + BrigAPIAccess.setSSOId uid $ Brig.veidToUserSSOId new toScimStoredUser :: (HasCallStack) => @@ -793,7 +792,7 @@ updScimStoredUser' now usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = deleteScimUser :: ( Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, Member SAMLUserStore r, @@ -814,7 +813,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- ("tombstones") would not have the needed values (`userIdentity = -- Nothing`) to delete a user in spar. I.e. `SAML.UserRef` and `Email` -- cannot be figured out when a `User` has status `Deleted`. - mbAccount <- lift $ BrigAccess.getAccount WithPendingInvitations uid + mbAccount <- lift $ BrigAPIAccess.getAccount Brig.WithPendingInvitations uid case mbAccount of Nothing -> -- Ensure there's no left-over of this user in brig. This is safe @@ -823,7 +822,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- be hard as the check relies on the data of `mbBrigUser`): The worst -- thing that could happen is that foreign users cleanup partially -- deleted users. - void . lift $ BrigAccess.deleteUser uid + lift $ BrigAPIAccess.deleteUser uid Just brigUser -> do if userTeam brigUser == Just stiTeam then do @@ -834,7 +833,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = -- (via the TM app) is blocked, though, so there is no legal way to enter -- that situation. deleteUserInSpar brigUser - void . lift $ BrigAccess.deleteUser uid + lift $ BrigAPIAccess.deleteUser uid else do -- if we find the user in another team, we pretend it wasn't even there, to -- avoid leaking data to attackers (very unlikely, but hey). @@ -886,7 +885,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdUnused :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -903,7 +902,7 @@ assertExternalIdUnused = -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdNotUsedElsewhere :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -919,7 +918,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = veid assertExternalIdInAllowedValues :: - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => @@ -937,16 +936,16 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: (Member BrigAccess r) => Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused :: (Member BrigAPIAccess r) => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: (Member BrigAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleUnused' :: (Member BrigAPIAccess r) => Text -> Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused' msg hndl = - lift (BrigAccess.checkHandleAvailable hndl) >>= \case + lift (BrigAPIAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: (Member BrigAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () +assertHandleNotUsedElsewhere :: (Member BrigAPIAccess r) => UserId -> Handle -> Scim.ScimHandler (Sem r) () assertHandleNotUsedElsewhere uid hndl = do musr <- lift $ getAccount Brig.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ @@ -960,7 +959,7 @@ synthesizeStoredUser :: ( Member (Input Opts) r, Member Now r, Member (Logger (Msg -> Msg)) r, - Member BrigAccess r, + Member BrigAPIAccess r, Member GalleyAccess r, Member ScimUserTimesStore r ) => @@ -983,7 +982,7 @@ synthesizeStoredUser acc veid = let readState :: Sem r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI, Role) readState = (,,,) - <$> BrigAccess.getRichInfo uid + <$> BrigAPIAccess.getRichInfo uid <*> ScimUserTimesStore.read uid <*> inputs scimBaseUri <*> getRole @@ -993,10 +992,10 @@ synthesizeStoredUser acc veid = when (isNothing oldAccessTimes) $ ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ - BrigAccess.setManagedBy uid ManagedByScim + BrigAPIAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ - BrigAccess.setRichInfo uid newRichInfo + BrigAPIAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri, role) <- lift readState now <- toUTCTimeMillis <$> lift Now.get @@ -1086,7 +1085,7 @@ synthesizeScimUser info = -- TODO: now write a test, either in /integration or in spar, whichever is easier. (spar) getUserById :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member GalleyAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, @@ -1100,7 +1099,7 @@ getUserById :: UserId -> MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) getUserById midp stiTeam uid = do - brigUser <- MaybeT . lift $ BrigAccess.getAccount Brig.WithPendingInvitations uid + brigUser <- MaybeT . lift $ BrigAPIAccess.getAccount Brig.WithPendingInvitations uid let mbveid = Brig.veidFromBrigUser brigUser @@ -1115,9 +1114,9 @@ getUserById midp stiTeam uid = do createValidScimUserSpar stiTeam uid storedUser veid lift $ do when (veidChanged brigUser veid) $ - BrigAccess.setSSOId uid (veidToUserSSOId veid) + BrigAPIAccess.setSSOId uid (Brig.veidToUserSSOId veid) when (managedByChanged brigUser) $ - BrigAccess.setManagedBy uid ManagedByScim + BrigAPIAccess.setManagedBy uid ManagedByScim pure storedUser _ -> Applicative.empty where @@ -1132,7 +1131,7 @@ getUserById midp stiTeam uid = do scimFindUserByHandle :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member GalleyAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, @@ -1147,7 +1146,7 @@ scimFindUserByHandle :: MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle + brigUser <- MaybeT . lift . BrigAPIAccess.getByHandle $ handle getUserById mIdpConfig stiTeam . userId $ brigUser -- | Construct a 'ValidScimId'. If it is an 'Email', find the non-SAML SCIM user in spar; if @@ -1158,7 +1157,7 @@ scimFindUserByHandle mIdpConfig stiTeam hndl = do -- successful authentication with their SAML credentials. scimFindUserByExternalId :: forall r. - ( Member BrigAccess r, + ( Member BrigAPIAccess r, Member GalleyAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, @@ -1180,11 +1179,11 @@ scimFindUserByExternalId mIdpConfig stiTeam eid = do -- there are a few ways to find a user. this should all be redundant, especially the where -- we lookup a user from brig by email, throw it away and only keep the uid, and then use -- the uid to lookup the account again. but cassandra, and also reasons. - mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAccess.getByEmail)) + mViaEmail :: Maybe UserId <- join <$> (for (justHere veid.validScimIdAuthInfo) ((userId <$$>) . BrigAPIAccess.getByEmail)) mViaUref :: Maybe UserId <- join <$> (for (justThere veid.validScimIdAuthInfo) SAMLUserStore.get) pure $ mViaEmail <|> mViaUref Just uid -> pure uid - acc <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid + acc <- MaybeT . lift . BrigAPIAccess.getAccount Brig.WithPendingInvitations $ uid getUserById mIdpConfig stiTeam (userId acc) logFilter :: Filter -> (Msg -> Msg) diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs deleted file mode 100644 index 8530786359..0000000000 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- 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 Spar.Sem.BrigAccess - ( BrigAccess (..), - createSAML, - createNoSAML, - updateEmail, - getAccount, - getByHandle, - getByEmail, - setName, - setHandle, - setManagedBy, - setSSOId, - setRichInfo, - setLocale, - getRichInfo, - checkHandleAvailable, - deleteUser, - ensureReAuthorised, - ssoLogin, - getStatus, - getStatusMaybe, - setStatus, - getDefaultUserLocale, - checkAdminGetTeamId, - ) -where - -import Brig.Types.Intra -import Data.Code as Code -import Data.Handle (Handle) -import Data.HavePendingInvitations -import Data.Id (TeamId, UserId) -import Data.Misc (PlainTextPassword6) -import Imports -import Polysemy -import qualified SAML2.WebSSO as SAML -import Web.Cookie -import Wire.API.Locale -import Wire.API.Team.Role -import Wire.API.User -import Wire.API.User.RichInfo as RichInfo - -data BrigAccess m a where - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAccess m UserId - CreateNoSAML :: Text -> EmailAddress -> UserId -> TeamId -> Name -> Maybe Locale -> Role -> BrigAccess m UserId - UpdateEmail :: UserId -> EmailAddress -> EmailActivation -> BrigAccess m () - GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe User) - GetByHandle :: Handle -> BrigAccess m (Maybe User) - GetByEmail :: EmailAddress -> BrigAccess m (Maybe User) - SetName :: UserId -> Name -> BrigAccess m () - SetHandle :: UserId -> Handle {- not 'HandleUpdate'! -} -> BrigAccess m () - SetManagedBy :: UserId -> ManagedBy -> BrigAccess m () - SetSSOId :: UserId -> UserSSOId -> BrigAccess m () - SetRichInfo :: UserId -> RichInfo -> BrigAccess m () - SetLocale :: UserId -> Maybe Locale -> BrigAccess m () - GetRichInfo :: UserId -> BrigAccess m RichInfo - CheckHandleAvailable :: Handle -> BrigAccess m Bool - DeleteUser :: UserId -> BrigAccess m DeleteUserResult - EnsureReAuthorised :: Maybe UserId -> Maybe PlainTextPassword6 -> Maybe Code.Value -> Maybe VerificationAction -> BrigAccess m () - SsoLogin :: UserId -> BrigAccess m SetCookie - GetStatus :: UserId -> BrigAccess m AccountStatus - GetStatusMaybe :: UserId -> BrigAccess m (Maybe AccountStatus) - SetStatus :: UserId -> AccountStatus -> BrigAccess m () - GetDefaultUserLocale :: BrigAccess m Locale - CheckAdminGetTeamId :: UserId -> BrigAccess m TeamId - -makeSem ''BrigAccess diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs deleted file mode 100644 index b3623597d3..0000000000 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ /dev/null @@ -1,67 +0,0 @@ --- 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 Spar.Sem.BrigAccess.Http - ( brigAccessToHttp, - ) -where - -import Bilge -import Imports -import Polysemy -import Polysemy.Error (Error) -import Spar.Error (SparError) -import qualified Spar.Intra.Brig as Intra -import Spar.Sem.BrigAccess -import Spar.Sem.Utils (RunHttpEnv (..), viaRunHttp) -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -brigAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (BrigAccess ': r) a -> - Sem r a -brigAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m h ri ml r -> Intra.createBrigUserSAML u itlu itlt n m h ri ml r - CreateNoSAML eid e uid itlt n ml r -> Intra.createBrigUserNoSAML eid e uid itlt n ml r - UpdateEmail itlu e a -> Intra.updateEmail itlu e a - GetAccount h itlu -> Intra.getBrigUserAccount h itlu - GetByHandle h -> Intra.getBrigUserByHandle h - GetByEmail e -> Intra.getBrigUserByEmail e - SetName itlu n -> Intra.setBrigUserName itlu n - SetHandle itlu h -> Intra.setBrigUserHandle itlu h - SetManagedBy itlu m -> Intra.setBrigUserManagedBy itlu m - SetSSOId itlu v -> Intra.setBrigUserSSOId itlu v - SetRichInfo itlu r -> Intra.setBrigUserRichInfo itlu r - SetLocale itlu l -> Intra.setBrigUserLocale itlu l - GetRichInfo itlu -> Intra.getBrigUserRichInfo itlu - CheckHandleAvailable h -> Intra.checkHandleAvailable h - DeleteUser itlu -> Intra.deleteBrigUserInternal itlu - EnsureReAuthorised mitlu mp mc ma -> Intra.ensureReAuthorised mitlu mp mc ma - SsoLogin itlu -> Intra.ssoLogin itlu - GetStatus itlu -> Intra.getStatus itlu - GetStatusMaybe itlu -> Intra.getStatusMaybe itlu - SetStatus itlu a -> Intra.setStatus itlu a - GetDefaultUserLocale -> Intra.getDefaultUserLocale - CheckAdminGetTeamId itlu -> Intra.checkAdminGetTeamId itlu diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 381b288171..277337d42a 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -37,7 +37,6 @@ import Polysemy.Error import Polysemy.Final import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Intra.Brig (MonadSparToBrig (..)) import Spar.Intra.Galley (MonadSparToGalley) import qualified Spar.Intra.Galley as Intra import qualified System.Logger as TinyLog @@ -119,13 +118,3 @@ instance call modreq = do req <- asks rheRequest httpLbs req modreq - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToBrig (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq diff --git a/services/spar/test-integration/Main.hs b/services/spar/test-integration/Main.hs index f1a42c9984..b2c219c614 100644 --- a/services/spar/test-integration/Main.hs +++ b/services/spar/test-integration/Main.hs @@ -47,7 +47,6 @@ import qualified Test.MetricsSpec import qualified Test.Spar.APISpec import qualified Test.Spar.AppSpec import qualified Test.Spar.DataSpec -import qualified Test.Spar.Intra.BrigSpec import qualified Test.Spar.Scim.AuthSpec import qualified Test.Spar.Scim.UserSpec import Util @@ -107,7 +106,6 @@ mkspecSaml = do describe "Spar.API" Test.Spar.APISpec.spec describe "Spar.App" Test.Spar.AppSpec.spec describe "Spar.Data" Test.Spar.DataSpec.spec - describe "Spar.Intra.Brig" Test.Spar.Intra.BrigSpec.spec mkspecScim :: SpecWith TestEnv mkspecScim = do diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 2ee14c69e6..7a2da96c75 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -72,7 +72,6 @@ import SAML2.WebSSO.Test.Util import qualified Spar.Intra.BrigApp as Intra import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore -import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdPConfigStore as IdPEffect import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI @@ -95,6 +94,7 @@ import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.User.IdentityProvider import Wire.API.User.Scim hiding (handle) +import qualified Wire.BrigAPIAccess as BrigAPIAccess spec :: SpecWith TestEnv spec = do @@ -1266,7 +1266,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs deleted file mode 100644 index c97ad084a9..0000000000 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ /dev/null @@ -1,65 +0,0 @@ --- 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.Spar.Intra.BrigSpec - ( spec, - ) -where - -import Control.Lens ((^.)) -import Data.Id (Id (Id), UserId) -import qualified Data.UUID as UUID -import Imports hiding (head) -import qualified Spar.Intra.BrigApp as Intra -import Spar.Sem.BrigAccess (getAccount) -import qualified Spar.Sem.BrigAccess as BrigAccess -import Test.QuickCheck -import Util -import qualified Web.Scim.Schema.User as Scim.User -import Wire.API.User (DeleteUserResult (..), fromEmail) - -spec :: SpecWith TestEnv -spec = do - describe "user deletion between brig and spar" $ do - it "if a user gets deleted on brig, it will be deleted on spar as well." $ do - pending - it "if a user gets deleted on spar, it will be deleted on brig as well." $ do - pendingWith "or deactivated? we should decide what we want here." - - describe "deleteBrigUserInternal" $ do - it "does not throw for non-existing users" $ do - uid :: UserId <- liftIO $ generate arbitrary - r <- runSpar $ BrigAccess.deleteUser uid - liftIO $ r `shouldBe` NoUser - - describe "getAccount" $ do - it "return Nothing if n/a" $ do - musr <- runSpar $ getAccount Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") - liftIO $ musr `shouldSatisfy` isNothing - - it "return Just if /a" $ do - let setup = do - env <- ask - email <- randomEmail - scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} - (_, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - tok <- registerScimToken tid Nothing - scimUserId <$> createUser tok scimUser - - uid <- setup - musr <- runSpar $ getAccount Intra.WithPendingInvitations uid - liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 965a854b60..7ad8d16b2d 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -67,7 +67,6 @@ import Spar.Options import Spar.Scim import Spar.Scim.Types (normalizeLikeStored) import qualified Spar.Scim.User as SU -import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore @@ -95,6 +94,7 @@ import qualified Wire.API.User.IdentityProvider as User import Wire.API.User.RichInfo import qualified Wire.API.User.Scim as Spar.Types import qualified Wire.API.User.Search as Search +import qualified Wire.BrigAPIAccess as BrigAPIAccess -- | Tests for @\/scim\/v2\/Users@. spec :: SpecWith TestEnv @@ -149,7 +149,7 @@ specImportToScimFromSAML = pure (uref, uid) let handle = fromRight undefined . parseHandleEither $ Scim.User.userName usr - runSpar (BrigAccess.setHandle uid handle) + runSpar (BrigAPIAccess.setHandle uid handle) assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Nothing) @@ -350,7 +350,7 @@ assertBrigCassandra :: ManagedBy -> TestSpar () assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do - runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do + runSpar (BrigAPIAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do let handle = fromRight errmsg . parseHandleEither $ Scim.User.userName usr where errmsg = error . show . Scim.User.userName $ usr @@ -385,9 +385,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle <- nextHandle - runSpar $ BrigAccess.setHandle member handle + runSpar $ BrigAPIAccess.setHandle member handle unless isActive $ do - runSpar $ BrigAccess.setStatus member Suspended + runSpar $ BrigAPIAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" (fromHandle handle))) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -406,19 +406,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -457,10 +457,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ BrigAccess.setStatus uid Suspended - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Suspended) + runSpar $ BrigAPIAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ BrigAccess.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ BrigAPIAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -647,10 +647,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser liftIO $ brigUser.userStatus `shouldBe` PendingInvitation @@ -694,7 +694,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ brigUser.userStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -777,7 +777,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ BrigAccess.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ BrigAPIAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -1225,9 +1225,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just usr <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle + runSpar $ BrigAPIAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO externalId = either error id $ veidToText =<< Intra.veidFromBrigUser memberWithSSO Nothing Nothing @@ -1238,7 +1238,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: (MonadError String m) => ValidScimId -> m Text @@ -1260,7 +1260,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -1273,7 +1273,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -1293,8 +1293,8 @@ testFindNonProvisionedUserNoIdP findBy = do email <- randomEmail uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid email) handle <- nextHandle - runSpar $ BrigAccess.setHandle uid handle - Just brigUser <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + runSpar $ BrigAPIAccess.setHandle uid handle + Just brigUser <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid do -- inspect brig user @@ -1308,7 +1308,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ BrigAPIAccess.getAccount Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` scimifyBrigUserHack brigUser email @@ -1323,7 +1323,7 @@ testListNoDeletedUsers = do -- Delete the user _ <- deleteUser tok userid -- Make sure it is deleted in brig before pulling via SCIM (which would recreate it!) - Nothing <- aFewTimes (runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid)) isNothing + Nothing <- aFewTimes (runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid)) isNothing -- Get all users users <- listUsers tok (Just (filterForStoredUser storedUser)) -- Check that the user is absent @@ -1395,7 +1395,7 @@ testGetUser = do shouldBeManagedBy :: (HasCallStack) => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1454,12 +1454,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAccess.getAccount Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1848,7 +1848,7 @@ testBrigSideIsUpdated = do validScimUser <- runSpar . runScimErrorUnsafe $ validateScimUser' "testBrigSideIsUpdated" (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAccess.getAccount Intra.WithPendingInvitations userid) + brigUser <- maybe (error "no brig user") pure =<< runSpar (BrigAPIAccess.getAccount Intra.WithPendingInvitations userid) let scimUserWithDefLocale = validScimUser {Spar.Types.locale = Spar.Types.locale validScimUser <|> Just (Locale (Language EN) Nothing)} brigUser `userShouldMatch` scimUserWithDefLocale @@ -2139,7 +2139,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - mUsr <- runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid + mUsr <- runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid let err = error . ("brig user without UserRef: " <>) . show case (\usr -> Intra.veidFromBrigUser usr Nothing Nothing) <$> mUsr of bad@(Just (Right veid)) -> runValidScimIdEither pure (const $ err bad) veid @@ -2148,7 +2148,7 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ BrigAPIAccess.getAccount Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index b91241aff1..100d8fa6f4 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -185,7 +185,6 @@ import Spar.Error (SparError) import qualified Spar.Intra.BrigApp as Intra import Spar.Options import Spar.Run -import Spar.Sem.BrigAccess (getAccount) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore @@ -218,6 +217,7 @@ import qualified Wire.API.User as User import Wire.API.User.Auth hiding (Cookie) import Wire.API.User.IdentityProvider import Wire.API.User.Scim +import Wire.BrigAPIAccess (getAccount) -- | Call 'mkEnv' with options from config files. mkEnvFromOptions :: IO TestEnv @@ -275,25 +275,9 @@ mkEnv tstOpts opts = do sparCtxHttpManager = mgr sparCtxHttpBrig = brig empty sparCtxHttpGalley = galley empty - sparCtxHttpGalleyEndpoint = undefined - sparCtxHttpGundeckEndpoint = undefined - disabledVersions = undefined sparCtxRequestId = RequestId "" sparCtxScimSubsystemConfig = error "mkEnv: implement sparCtxScimSubsystemConfig when needed" sparCtxLocalUnit = error "mkEnv: implement sparCtxLocalUnit when needed" - sparCtxAuthenticationSubsystemConfig = undefined - sparCtxPasswordHashingOptions = undefined - sparCtxUserTemplates = undefined - sparCtxTeamTemplates = undefined - sparCtxTemplateBranding = undefined - sparCtxRateLimit = undefined - sparCtxFederationAPIAccessConfig = undefined - sparCtxIndexedUserStoreConfig = undefined - sparCtxUserSubsystemConfig = undefined - sparCtxHasqlPool = undefined - sparCtxSmtp = undefined - sparCtxAws = undefined - sparCtxInternalEvents = undefined pure $ TestEnv mgr diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs deleted file mode 100644 index 002a915528..0000000000 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# 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.Spar.Intra.BrigSpec where - -import Arbitrary () -import Data.String.Conversions -import Data.These -import Data.These.Combinators -import Imports -import SAML2.WebSSO as SAML -import Spar.Intra.BrigApp -import Test.Hspec -import Test.QuickCheck -import URI.ByteString (URI, laxURIParserOptions, parseURI) -import Wire.API.User.Identity (UserSSOId (UserSSOId)) -import Wire.API.User.Scim - -mkuri :: Text -> URI -mkuri = either (error . show) id . parseURI laxURIParserOptions . cs - -spec :: Spec -spec = do - describe "veidToUserSSOId, veidFromUserSSOId" $ do - -- example unit tests are mostly for documentation. if they fail, it may be because of some - -- harmless change in the string representation of the xml data, and you can probably just - -- remove them. - - it "example" $ do - let veid = - ValidScimId "V" . That $ - UserRef - (Issuer $ mkuri "http://wire.com/") - ( either (error . show) id $ - mkNameID (mkUNameIDTransient "V") (Just "kati") (Just "rolli") (Just "jaan") - ) - ssoId = UserSSOId (SAML.UserRef iss nam) - iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" - nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "V" - veidToUserSSOId veid `shouldBe` ssoId - veidFromUserSSOId ssoId Nothing `shouldBe` Right veid - - it "another example" $ do - let veid = - ValidScimId "PWkS" . That $ - UserRef - (Issuer $ mkuri "http://wire.com/") - ( either (error . show) id $ - mkNameID (mkUNameIDPersistent "PWkS") (Just "hăendrik") Nothing (Just "marye") - ) - ssoId = UserSSOId (SAML.UserRef iss nam) - iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" - nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "PWkS" - veidToUserSSOId veid `shouldBe` ssoId - veidFromUserSSOId ssoId Nothing `shouldBe` Right veid - - it "roundtrips" . property $ - \(ValidScimIdNoNameIDQualifiers x) -> - veidFromUserSSOId @(Either String) (veidToUserSSOId x) (justHere x.validScimIdAuthInfo) === Right x diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index 09d09eee3a..e676b4be2e 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -10,7 +10,6 @@ import Imports import Polysemy import Polysemy.TinyLog import Spar.Scim.User (deleteScimUser) -import Spar.Sem.BrigAccess import Spar.Sem.IdPConfigStore import Spar.Sem.IdPConfigStore.Mem (idPToMem) import Spar.Sem.SAMLUserStore @@ -23,8 +22,9 @@ import System.Logger (Msg) import Test.Hspec import Test.QuickCheck import Web.Scim.Schema.Error -import Wire.API.User +import Wire.API.User hiding (DeleteUser) import Wire.API.User.Scim +import Wire.BrigAPIAccess (BrigAPIAccess (DeleteUser, GetAccount)) import Wire.Sem.Logger.TinyLog (discardTinyLogs) spec :: Spec @@ -33,32 +33,32 @@ spec = describe "deleteScimUser" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "is idempotent" $ do tokenInfo <- generate arbitrary acc <- someActiveUser tokenInfo r <- - interpretWithBrigAccessMock - (mockBrig (withActiveUser acc) AccountAlreadyDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (withActiveUser acc)) (deleteUserAndAssertDeletionInSpar acc tokenInfo) r `shouldBe` Right () it "works if there never was an account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) NoUser) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () it "returns no error when there was a partially deleted account" $ do uid <- generate arbitrary tokenInfo <- generate arbitrary r <- - interpretWithBrigAccessMock - (mockBrig (const Nothing) AccountDeleted) + interpretWithBrigAPIAccessMock + (mockBrig (const Nothing)) (runExceptT $ deleteScimUser tokenInfo uid) r `shouldBe` Right () @@ -66,7 +66,7 @@ deleteUserAndAssertDeletionInSpar :: forall (r :: EffectRow). ( Members '[ Logger (Msg -> Msg), - BrigAccess, + BrigAPIAccess, ScimExternalIdStore.ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, @@ -98,13 +98,13 @@ type EffsWithoutBrigAccess = Final IO ] -interpretWithBrigAccessMock :: - ( Sem (BrigAccess ': EffsWithoutBrigAccess) a -> +interpretWithBrigAPIAccessMock :: + ( Sem (BrigAPIAccess ': EffsWithoutBrigAccess) a -> Sem EffsWithoutBrigAccess a ) -> - Sem (BrigAccess ': EffsWithoutBrigAccess) a -> + Sem (BrigAPIAccess ': EffsWithoutBrigAccess) a -> IO a -interpretWithBrigAccessMock mock = +interpretWithBrigAPIAccessMock mock = runFinal . embedToFinal @IO . discardTinyLogs @@ -121,12 +121,11 @@ mockBrig :: forall (r :: EffectRow) a. (Member (Embed IO) r) => (UserId -> Maybe User) -> - DeleteUserResult -> - Sem (BrigAccess ': r) a -> + Sem (BrigAPIAccess ': r) a -> Sem r a -mockBrig lookup_user delete_response = interpret $ \case +mockBrig lookup_user = interpret $ \case (GetAccount WithPendingInvitations uid) -> pure $ lookup_user uid - (Spar.Sem.BrigAccess.DeleteUser _) -> pure delete_response + (DeleteUser _) -> pure () _ -> do liftIO $ expectationFailure $ "Unexpected effect (call to brig)" error "Throw error here to avoid implementation of all cases." From 5518a5f9d19b59c27e25afc2090709e52f25b9de Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Wed, 5 Nov 2025 21:31:39 +0100 Subject: [PATCH 29/30] refactor: merge spar GalleyAccess to wire-subsystem GalleyAPIAccess --- .../src/Wire/GalleyAPIAccess.hs | 17 +++ .../src/Wire/GalleyAPIAccess/Rpc.hs | 113 +++++++++++++++ .../Wire/MockInterpreters/GalleyAPIAccess.hs | 4 + services/spar/spar.cabal | 3 - services/spar/src/Spar/API.hs | 36 ++--- services/spar/src/Spar/App.hs | 16 +-- .../spar/src/Spar/CanonicalInterpreter.hs | 13 +- services/spar/src/Spar/Intra/BrigApp.hs | 8 +- services/spar/src/Spar/Intra/Galley.hs | 131 ------------------ services/spar/src/Spar/Scim.hs | 4 +- services/spar/src/Spar/Scim/Auth.hs | 18 +-- services/spar/src/Spar/Scim/User.hs | 20 +-- services/spar/src/Spar/Sem/GalleyAccess.hs | 45 ------ .../spar/src/Spar/Sem/GalleyAccess/Http.hs | 53 ------- services/spar/src/Spar/Sem/Utils.hs | 12 -- 15 files changed, 192 insertions(+), 301 deletions(-) delete mode 100644 services/spar/src/Spar/Intra/Galley.hs delete mode 100644 services/spar/src/Spar/Sem/GalleyAccess.hs delete mode 100644 services/spar/src/Spar/Sem/GalleyAccess/Http.hs diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 771d31f94a..111f674dad 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -148,5 +148,22 @@ data GalleyAPIAccess m a where GetTeamContacts :: UserId -> GalleyAPIAccess m (Maybe Team.TeamMemberList) + AssertHasPermission :: + (Show perm, Team.IsPerm Team.TeamMember perm) => + TeamId -> + perm -> + UserId -> + GalleyAPIAccess m () + AssertSSOEnabled :: + TeamId -> + GalleyAPIAccess m () + IsEmailValidationEnabledTeam :: + TeamId -> + GalleyAPIAccess m Bool + UpdateTeamMember :: + UserId -> + TeamId -> + Role -> + GalleyAPIAccess m () makeSem ''GalleyAPIAccess diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index bcce4a2448..3ac740c92a 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -98,6 +98,10 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamAdmins tid -> getTeamAdmins tid InternalGetConversation id' -> internalGetConversation id' GetTeamContacts uid -> getTeamContacts uid + AssertHasPermission tid perm uid -> assertHasPermission tid perm uid + AssertSSOEnabled tid -> assertSSOEnabled tid + IsEmailValidationEnabledTeam tid -> isEmailValidationEnabledTeam tid + UpdateTeamMember uid tid role -> updateTeamMember uid tid role getUserLegalholdStatus :: ( Member TinyLog r, @@ -728,3 +732,112 @@ getTeamContacts uid = do method GET . paths ["i", "users", toByteString' uid, "team", "members"] . expect [status200, status404] + +assertHasPermission :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r, + Member.IsPerm Member.TeamMember perm, + Show perm + ) => + TeamId -> + perm -> + UserId -> + Sem r () +assertHasPermission tid perm uid = do + debug $ + remote "galley" + . field "team" (toByteString tid) + . field "user" (toByteString uid) + . msg (val "Asserting user has permission") + rs <- galleyRequest req + case Bilge.statusCode rs of + 200 -> do + member <- decodeBodyOrThrow @Member.TeamMember "galley" rs + unless (Member.hasPermission member perm) $ + throw $ + ParseException "galley" $ + "User does not have permission: " <> show perm + _ -> throw $ ParseException "galley" "Failed to check permission" + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] + . expect [status200, status404] + +assertSSOEnabled :: + ( Member (Error ParseException) r, + Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + TeamId -> + Sem r () +assertSSOEnabled tid = do + debug $ + remote "galley" + . field "team" (toByteString tid) + . msg (val "Asserting SSO is enabled") + rs <- galleyRequest req + unless (Bilge.statusCode rs == 200) $ + throw $ + ParseException "galley" "Failed to get SSO feature status" + feature <- decodeBodyOrThrow @(LockableFeature SSOConfig) "galley" rs + unless (feature.status == FeatureStatusEnabled) $ + throw $ + ParseException "galley" "SSO is not enabled for this team" + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "features", "sso"] + . expect2xx + +isEmailValidationEnabledTeam :: + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + TeamId -> + Sem r Bool +isEmailValidationEnabledTeam tid = do + debug $ + remote "galley" + . field "team" (toByteString tid) + . msg (val "Checking if email validation is enabled") + rs <- galleyRequest req + pure $ + Bilge.statusCode rs == 200 + && ( ((.status) <$> responseJsonMaybe @(LockableFeature ValidateSAMLEmailsConfig) rs) + == Just FeatureStatusEnabled + ) + where + req = + method GET + . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] + +updateTeamMember :: + ( Member Rpc r, + Member (Input Endpoint) r, + Member TinyLog r + ) => + UserId -> + TeamId -> + Role -> + Sem r () +updateTeamMember uid tid role = do + debug $ + remote "galley" + . field "team" (toByteString tid) + . field "user" (toByteString uid) + . msg (val "Updating team member") + void $ galleyRequest req + where + prm = Member.rolePermissions role + bdy = Member.mkNewTeamMember uid prm Nothing + req = + method PUT + . paths ["i", "teams", toByteString' tid, "members"] + . header "Content-Type" "application/json" + . expect2xx + . lbytes (encode bdy) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 29ba317262..143cf67231 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -51,6 +51,10 @@ miniGalleyAPIAccess teams configs = interpret $ \case SelectTeamMemberInfos tid uids -> pure $ selectTeamMemberInfosImpl teams tid uids InternalGetConversation _ -> error "GetConv not implemented in InternalGetConversation" GetTeamContacts _ -> pure Nothing + AssertHasPermission {} -> error "AssertHasPermission not implemented in miniGalleyAPIAccess" + AssertSSOEnabled _ -> error "AssertSSOEnabled not implemented in miniGalleyAPIAccess" + IsEmailValidationEnabledTeam _ -> error "IsEmailValidationEnabledTeam not implemented in miniGalleyAPIAccess" + UpdateTeamMember {} -> error "UpdateTeamMember not implemented in miniGalleyAPIAccess" -- this is called but the result is not needed in unit tests selectTeamMemberInfosImpl :: Map TeamId [TeamMember] -> TeamId -> [UserId] -> TeamMemberInfoList diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 833503458a..a1171098b4 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -23,7 +23,6 @@ library Spar.Data.Instances Spar.Error Spar.Intra.BrigApp - Spar.Intra.Galley Spar.Options Spar.Orphans Spar.Run @@ -64,8 +63,6 @@ library Spar.Sem.DefaultSsoCode.Cassandra Spar.Sem.DefaultSsoCode.Mem Spar.Sem.DefaultSsoCode.Spec - Spar.Sem.GalleyAccess - Spar.Sem.GalleyAccess.Http Spar.Sem.IdPConfigStore Spar.Sem.IdPConfigStore.Cassandra Spar.Sem.IdPConfigStore.Mem diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index ebf7400639..e521f9c001 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -83,8 +83,6 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPConfigStore (IdPConfigStore, Replaced (..), Replacing (..)) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) @@ -114,6 +112,8 @@ import Wire.API.User.IdentityProvider import Wire.API.User.Saml import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) import qualified Wire.BrigAPIAccess as BrigAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAccess import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger @@ -141,7 +141,7 @@ app ctx0 req cont = do cont api :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member (Input Opts) r, Member AssIDStore r, @@ -179,7 +179,7 @@ api opts = :<|> apiINTERNAL apiSSO :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member (Logger String) r, Member (Input Opts) r, Member BrigAPIAccess r, @@ -211,7 +211,7 @@ apiSSO opts = apiIDP :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -238,7 +238,7 @@ apiINTERNAL :: Member ScimUserTimesStore r, Member (Logger String) r, Member Random r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r ) => ServerT InternalAPI (Sem r) @@ -359,7 +359,7 @@ authresp :: ( Member Random r, Member (Logger String) r, Member (Input Opts) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member AssIDStore r, Member VerdictFormatStore r, @@ -470,7 +470,7 @@ authContext e = authHandler e :. EmptyContext idpGet :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r @@ -484,7 +484,7 @@ idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do pure idp idpGetRaw :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -503,7 +503,7 @@ idpGetRaw zusr idpid = do idpGetAll :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r @@ -517,7 +517,7 @@ idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do idpGetAllByTeamId :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r @@ -540,7 +540,7 @@ idpDelete :: forall r. ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member SAMLUserStore r, @@ -624,7 +624,7 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co idpCreate :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -651,7 +651,7 @@ idpCreate tid (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe def idpCreateV7 :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -752,7 +752,7 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idHandle = withDebugLog idpUpdate :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -768,7 +768,7 @@ idpUpdate zusr (IdPMetadataValue raw xml) = idpUpdateXML zusr raw xml idpUpdateXML :: ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member IdPRawMetadataStore r, @@ -808,7 +808,7 @@ validateIdPUpdate :: (HasCallStack, m ~ Sem r) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member IdPConfigStore r, Member (Error SparError) r @@ -874,7 +874,7 @@ withDebugLog msg showval action = do authorizeIdP :: ( HasCallStack, - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member (Error SparError) r ) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index f6dfe59605..0c287aa2e9 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -76,8 +76,6 @@ import qualified Spar.Intra.BrigApp as Intra import Spar.Options import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPConfigStore (IdPConfigStore) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.Reporter (Reporter) @@ -100,6 +98,8 @@ import Wire.API.User.Saml import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) import qualified Wire.BrigAPIAccess as BrigAccess import Wire.Error +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAccess import Wire.ScimSubsystem.Interpreter import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger @@ -204,7 +204,7 @@ createSamlUserWithId teamid buid suid role = do -- https://wearezeta.atlassian.net/browse/SQSERVICES-1655) autoprovisionSamlUser :: forall r. - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -238,7 +238,7 @@ autoprovisionSamlUser idp buid suid = do -- make brig initiate the email validate procedure. validateSamlEmailIfExists :: forall r. - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r ) => UserId -> @@ -252,7 +252,7 @@ validateSamlEmailIfExists uid = \case validateEmail :: forall r. - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r ) => Maybe TeamId -> @@ -278,7 +278,7 @@ verdictHandler :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member AReqIDStore r, Member VerdictFormatStore r, @@ -325,7 +325,7 @@ verdictHandlerResult :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -405,7 +405,7 @@ verdictHandlerResultCore :: (HasCallStack) => ( Member Random r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 453c6a7ccf..10c96e3927 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -45,8 +45,6 @@ import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) -import Spar.Sem.GalleyAccess (GalleyAccess) -import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdPConfigStore (IdPConfigStore) import Spar.Sem.IdPConfigStore.Cassandra (idPToCassandra) import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) @@ -69,9 +67,12 @@ import Spar.Sem.Utils (idpDbErrorToSparError, interpretClientToIO, ttlErrorToSpa import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog +import Wire.API.Routes.Version (expandVersionExp) import Wire.API.User.Saml (TTLError) import Wire.BrigAPIAccess (BrigAPIAccess) import Wire.BrigAPIAccess.Rpc (interpretBrigAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess.Rpc (interpretGalleyAPIAccessToRpc) import Wire.ParseException (ParseException, parseExceptionToHttpError) import Wire.Rpc (Rpc, runRpcWithHttp) import Wire.ScimSubsystem @@ -88,6 +89,7 @@ type CanonicalEffs = type LowerLevelCanonicalEffs = '[ BrigAPIAccess, + GalleyAPIAccess, SAML2, SamlProtocolSettings, AssIDStore, @@ -106,7 +108,6 @@ type LowerLevelCanonicalEffs = IdPRawMetadataStore, SAMLUserStore, Embed Cas.Client, - GalleyAccess, Error IdpDbError, Error TTLError, Error SparError, @@ -135,7 +136,6 @@ runSparToIO ctx = . runError @SparError . ttlErrorToSparError . idpDbErrorToSparError - . galleyAccessToHttp (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) . interpretClientToIO (sparCtxCas ctx) . samlUserStoreToCassandra . idpRawMetadataStoreToCassandra @@ -145,8 +145,8 @@ runSparToIO ctx = . scimUserTimesStoreToCassandra . scimExternalIdStoreToCassandra . mapScimSubsystemErrors - . runInputConst (ctx.sparCtxScimSubsystemConfig) - . runInputConst (ctx.sparCtxLocalUnit) + . runInputConst ctx.sparCtxScimSubsystemConfig + . runInputConst ctx.sparCtxLocalUnit . runRpcWithHttp ctx.sparCtxHttpManager ctx.sparCtxRequestId . iParseException . verdictFormatStoreToCassandra @@ -154,6 +154,7 @@ runSparToIO ctx = . assIDStoreToCassandra . sparRouteToServant (saml $ sparCtxOpts ctx) . saml2ToSaml2WebSso + . interpretGalleyAPIAccessToRpc (foldMap expandVersionExp ctx.sparCtxOpts.disabledAPIVersions) ctx.sparCtxOpts.galley . interpretBrigAccess ctx.sparCtxOpts.brig . interpretScimSubsystem diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 481f9501b3..fb5f8c4100 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -55,13 +55,13 @@ import Polysemy import Polysemy.Error import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.GalleyAccess as GalleyAccess import Wire.API.Team.Member (HiddenPerm (CreateReadDeleteScimToken), IsPerm, TeamMember) import Wire.API.User import Wire.API.User.Scim (ValidScimId (..)) import Wire.BrigAPIAccess (BrigAPIAccess) import qualified Wire.BrigAPIAccess as BrigAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import qualified Wire.GalleyAPIAccess as GalleyAccess ---------------------------------------------------------------------- @@ -133,7 +133,7 @@ getZUsrCheckPerm :: forall r perm. ( HasCallStack, ( Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ), IsPerm TeamMember perm, @@ -153,7 +153,7 @@ authorizeScimTokenManagement :: forall r. ( HasCallStack, ( Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member (Error SparError) r ) ) => diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs deleted file mode 100644 index b938931c56..0000000000 --- a/services/spar/src/Spar/Intra/Galley.hs +++ /dev/null @@ -1,131 +0,0 @@ --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - --- 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 . - --- | Client functions for interacting with the Galley API. -module Spar.Intra.Galley where - -import Bilge -import Control.Lens -import Control.Monad.Except -import Data.ByteString.Conversion -import Data.Id (TeamId, UserId) -import qualified Data.Text.Lazy as LText -import Imports -import Network.HTTP.Types.Method -import Spar.Error -import qualified System.Logger.Class as Log -import Wire.API.Team.Feature -import Wire.API.Team.Member -import Wire.API.Team.Role - ----------------------------------------------------------------------- - -class (Monad m, Log.MonadLogger m) => MonadSparToGalley m where - call :: (Request -> Request) -> m ResponseLBS - --- | Get all members of a team. -getTeamMembers :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m [TeamMember] -getTeamMembers tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members"] - if statusCode resp == 200 - then (^. teamMembers) <$> parseResponse @TeamMemberList "galley" resp - else rethrow "galley" resp - --- | Get a single member of a team. -getTeamMember :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - UserId -> - m (Maybe TeamMember) -getTeamMember tid uid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - if statusCode resp == 200 - then Just <$> parseResponse @TeamMember "galley" resp - else - if statusCode resp == 404 - then pure Nothing - else rethrow "galley" resp - --- | user is member of a given team and has a given permission there. -assertHasPermission :: - (HasCallStack, MonadSparToGalley m, MonadError SparError m, IsPerm TeamMember perm, Show perm) => - TeamId -> - perm -> - UserId -> - m () -assertHasPermission tid perm uid = do - resp <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] - case (statusCode resp, parseResponse @TeamMember "galley" resp) of - (200, Right member) | hasPermission member perm -> pure () - _ -> throwSpar (SparNoPermission (LText.pack $ show perm)) - -assertSSOEnabled :: - (HasCallStack, MonadError SparError m, MonadSparToGalley m) => - TeamId -> - m () -assertSSOEnabled tid = do - resp :: ResponseLBS <- - call $ - method GET - . paths ["i", "teams", toByteString' tid, "features", "sso"] - unless (statusCode resp == 200) $ - rethrow "galley" resp - ws :: LockableFeature SSOConfig <- parseResponse "galley" resp - unless (ws.status == FeatureStatusEnabled) $ - throwSpar SparSSODisabled - -isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool -isEmailValidationEnabledTeam tid = do - resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] - pure - ( statusCode resp == 200 - && ( ((.status) <$> responseJsonMaybe @(LockableFeature ValidateSAMLEmailsConfig) resp) - == Just FeatureStatusEnabled - ) - ) - --- | Update a team member. -updateTeamMember :: - (MonadIO m, HasCallStack, MonadSparToGalley m) => - UserId -> - TeamId -> - Role -> - m () -updateTeamMember u tid role = do - let reqBody = mkNewTeamMember u (rolePermissions role) Nothing - rs <- - call $ - method PUT - . paths ["i", "teams", toByteString' tid, "members"] - . contentJson - . json reqBody - print rs diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 0b1b0988c8..cad2d8d204 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -82,7 +82,6 @@ import Spar.Options import Spar.Scim.Auth import Spar.Scim.Group () import Spar.Scim.User -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.IdPConfigStore (IdPConfigStore) import Spar.Sem.Reporter (Reporter) import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -100,6 +99,7 @@ import qualified Web.Scim.Server as Scim import Wire.API.Routes.Public.Spar import Wire.API.User.Scim import Wire.BrigAPIAccess (BrigAPIAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.ScimSubsystem import Wire.Sem.Logger (Logger) import Wire.Sem.Now (Now) @@ -120,7 +120,7 @@ apiScim :: Member (Logger String) r, Member Now r, Member (Error SparError) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimSubsystem r, Member ScimExternalIdStore r, diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 4ead61f640..c4609d371d 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -52,7 +52,6 @@ import Spar.App (throwSparSem) import qualified Spar.Error as E import qualified Spar.Intra.BrigApp as Intra.Brig import Spar.Options -import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.IdPConfigStore (IdPConfigStore) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.ScimTokenStore (ScimTokenStore) @@ -66,6 +65,7 @@ import Wire.API.User as User import Wire.API.User.Scim as Api import Wire.BrigAPIAccess (BrigAPIAccess) import qualified Wire.BrigAPIAccess as BrigAccess +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.Sem.Now (Now) import qualified Wire.Sem.Now as Now import Wire.Sem.Random (Random) @@ -91,7 +91,7 @@ instance (Member ScimTokenStore r) => Scim.Class.Auth.AuthDB SparTag (Sem r) whe apiScimToken :: ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member Now r, @@ -111,7 +111,7 @@ updateScimTokenName :: ( Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r, - Member GalleyAccess r + Member GalleyAPIAccess r ) => UserId -> ScimTokenId -> @@ -128,7 +128,7 @@ createScimTokenV7 :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -167,7 +167,7 @@ createScimToken :: forall r. ( Member Random r, Member (Input Opts) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member IdPConfigStore r, @@ -187,7 +187,7 @@ createScimToken zusr Api.CreateScimToken {..} = do guardScimTokenCreation :: forall r. ( Member (Input Opts) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r @@ -240,7 +240,7 @@ createScimTokenUnchecked teamid mName desc mIdPId = do -- -- Delete a token belonging to user's team. deleteScimToken :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r @@ -255,7 +255,7 @@ deleteScimToken zusr tokenid = do pure NoContent listScimTokensV7 :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r @@ -276,7 +276,7 @@ listScimTokensV7 zusr = toV7 <$> listScimTokens zusr -- List all tokens belonging to user's team. Tokens themselves are not available, only -- metadata about them. listScimTokens :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimTokenStore r, Member (Error E.SparError) r diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 4f91773a48..81ed32c102 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -79,7 +79,6 @@ import Spar.Options import Spar.Scim.Auth () import Spar.Scim.Types import qualified Spar.Scim.Types as ST -import Spar.Sem.GalleyAccess as GalleyAccess import Spar.Sem.IdPConfigStore (IdPConfigStore) import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -113,6 +112,7 @@ import Wire.API.User.Scim (ScimTokenInfo (..), ValidScimId (..)) import qualified Wire.API.User.Scim as ST import Wire.BrigAPIAccess (BrigAPIAccess, getAccount) import qualified Wire.BrigAPIAccess as BrigAPIAccess +import Wire.GalleyAPIAccess as GalleyAccess import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Now (Now) @@ -129,7 +129,7 @@ instance Member Random r, Member (Input Opts) r, Member Now r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, @@ -507,7 +507,7 @@ createValidScimUser :: Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member (Logger String) r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, @@ -641,7 +641,7 @@ updateValidScimUser :: Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member Now r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimExternalIdStore r, Member ScimUserTimesStore r, @@ -713,7 +713,7 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = Scim.getUser tokinfo uid updateVsuUref :: - ( Member GalleyAccess r, + ( Member GalleyAPIAccess r, Member BrigAPIAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r @@ -960,7 +960,7 @@ synthesizeStoredUser :: Member Now r, Member (Logger (Msg -> Msg)) r, Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member ScimUserTimesStore r ) => User -> @@ -1027,7 +1027,7 @@ synthesizeStoredUser acc veid = getRole :: Sem r Role getRole = do let tmRoleOrDefault m = fromMaybe defaultRole $ m >>= \member -> member ^. Member.permissions . to Member.permissionsRole - maybe (pure defaultRole) (\tid -> tmRoleOrDefault <$> GalleyAccess.getTeamMember tid (userId acc)) (userTeam acc) + maybe (pure defaultRole) (\tid -> tmRoleOrDefault <$> GalleyAccess.getTeamMember (userId acc) tid) (userTeam acc) synthesizeStoredUser' :: (MonadError Scim.ScimError m) => @@ -1086,7 +1086,7 @@ synthesizeScimUser info = getUserById :: forall r. ( Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1132,7 +1132,7 @@ getUserById midp stiTeam uid = do scimFindUserByHandle :: forall r. ( Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, @@ -1158,7 +1158,7 @@ scimFindUserByHandle mIdpConfig stiTeam hndl = do scimFindUserByExternalId :: forall r. ( Member BrigAPIAccess r, - Member GalleyAccess r, + Member GalleyAPIAccess r, Member (Input Opts) r, Member (Logger (Msg -> Msg)) r, Member Now r, diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs deleted file mode 100644 index 76936239c7..0000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- 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 Spar.Sem.GalleyAccess -- TODO: use GalleyAPIAccess from wire-subsystems instead. - ( GalleyAccess (..), - getTeamMembers, - getTeamMember, - assertHasPermission, - assertSSOEnabled, - isEmailValidationEnabledTeam, - updateTeamMember, - ) -where - -import Data.Id (TeamId, UserId) -import Imports -import Polysemy -import Wire.API.Team.Member -import Wire.API.Team.Role - -data GalleyAccess m a where - GetTeamMembers :: TeamId -> GalleyAccess m [TeamMember] - GetTeamMember :: TeamId -> UserId -> GalleyAccess m (Maybe TeamMember) - AssertHasPermission :: (Show perm, IsPerm TeamMember perm) => TeamId -> perm -> UserId -> GalleyAccess m () - AssertSSOEnabled :: TeamId -> GalleyAccess m () - IsEmailValidationEnabledTeam :: TeamId -> GalleyAccess m Bool - UpdateTeamMember :: UserId -> TeamId -> Role -> GalleyAccess m () - -makeSem ''GalleyAccess diff --git a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs deleted file mode 100644 index 793bac9c27..0000000000 --- a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs +++ /dev/null @@ -1,53 +0,0 @@ --- 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 Spar.Sem.GalleyAccess.Http - ( RunHttpEnv (..), - viaRunHttp, - galleyAccessToHttp, - ) -where - -import Bilge -import Imports hiding (log) -import Polysemy -import Polysemy.Error -import Spar.Error (SparError) -import qualified Spar.Intra.Galley as Intra -import Spar.Sem.GalleyAccess -import Spar.Sem.Utils -import qualified System.Logger as TinyLog -import Wire.Sem.Logger (Logger) - -galleyAccessToHttp :: - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Error SparError) r, - Member (Embed IO) r - ) => - Bilge.Manager -> - Bilge.Request -> - Sem (GalleyAccess ': r) a -> - Sem r a -galleyAccessToHttp mgr req = - interpret $ - viaRunHttp (RunHttpEnv mgr req) . \case - GetTeamMembers itlt -> Intra.getTeamMembers itlt - GetTeamMember tid uid -> Intra.getTeamMember tid uid - AssertHasPermission itlt perm itlu -> Intra.assertHasPermission itlt perm itlu - AssertSSOEnabled itlt -> Intra.assertSSOEnabled itlt - IsEmailValidationEnabledTeam itlt -> Intra.isEmailValidationEnabledTeam itlt - UpdateTeamMember uid tid role -> Intra.updateTeamMember uid tid role diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs index 277337d42a..c2fb1e76a0 100644 --- a/services/spar/src/Spar/Sem/Utils.hs +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -37,8 +37,6 @@ import Polysemy.Error import Polysemy.Final import qualified SAML2.WebSSO as SAML import Spar.Error -import Spar.Intra.Galley (MonadSparToGalley) -import qualified Spar.Intra.Galley as Intra import qualified System.Logger as TinyLog import qualified System.Logger.Class as TinyLog import Wire.API.User.Saml @@ -108,13 +106,3 @@ viaRunHttp env m = do instance (Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r) => TinyLog.MonadLogger (RunHttp r) where log lvl msg = semToRunHttp $ Logger.log lvl msg - -instance - ( Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r, - Member (Embed IO) r - ) => - MonadSparToGalley (RunHttp r) - where - call modreq = do - req <- asks rheRequest - httpLbs req modreq From 21b5eda36a60dbed6d028f4f5d6e191e0c59b8ef Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 6 Nov 2025 09:30:50 +0100 Subject: [PATCH 30/30] Re-align galley rpc errors between spar and wire-subsystems. --- .../src/Wire/GalleyAPIAccess/Rpc.hs | 69 +++++++++---------- 1 file changed, 34 insertions(+), 35 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index 3ac740c92a..851688c939 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -57,8 +57,13 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess (..), MLSOneToOneEstablished (..), import Wire.ParseException import Wire.Rpc +data GalleyAPIError + = GalleyAPIParseException ParseException -- TODO: where else is ParseException used? can we declare it here, or in ./Error.hs? + | GalleyAPIForbidden + | GalleyAPIInternalError Text + interpretGalleyAPIAccessToRpc :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member TinyLog r ) => @@ -105,7 +110,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = getUserLegalholdStatus :: ( Member TinyLog r, - Member (Error ParseException) r, + Member (Error GalleyAPIError) r, Member Rpc r ) => Local UserId -> @@ -148,7 +153,7 @@ createSelfConv v u = do -- | Calls 'Galley.API.getConversationH'. getConv :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -181,7 +186,7 @@ getConv v usr lcnv = do -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -314,7 +319,7 @@ createTeam u t teamid = do -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. getTeamMember :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -343,7 +348,7 @@ getTeamMember u tid = do -- 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 :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -362,7 +367,7 @@ getTeamMembers tid maxResults = do . expect2xx selectTeamMemberInfos :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -383,7 +388,7 @@ selectTeamMemberInfos tid uids = do . expect2xx getTeamAdmins :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -413,7 +418,7 @@ memberIsTeamOwner tid uid = do -- | Calls 'Galley.API.getBindingTeamIdH'. getTeamId :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -434,7 +439,7 @@ getTeamId u = do -- | Calls 'Galley.API.getTeamInternalH'. getTeam :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -452,7 +457,7 @@ getTeam tid = do -- | Calls 'Galley.API.getTeamInternalH'. getTeamName :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -470,7 +475,7 @@ getTeamName tid = do -- | Calls 'Galley.API.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -488,7 +493,7 @@ getTeamLegalHoldStatus tid = do -- | Calls 'Galley.API.getSearchVisibilityInternalH'. getTeamSearchVisibility :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -511,7 +516,7 @@ getFeatureConfigForTeam :: Typeable feature, Member TinyLog r, Member Rpc r, - Member (Error ParseException) r + Member (Error GalleyAPIError) r ) => TeamId -> Sem (Input Endpoint : r) (LockableFeature feature) @@ -525,7 +530,7 @@ getFeatureConfigForTeam tid = do . expect2xx getVerificationCodeEnabled :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -545,8 +550,8 @@ getVerificationCodeEnabled tid = do . paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] . expect2xx -decodeBodyOrThrow :: forall a r. (Typeable a, FromJSON a, Member (Error ParseException) r) => Text -> Response (Maybe BL.ByteString) -> Sem r a -decodeBodyOrThrow ctx r = either (throw . ParseException ctx) pure (responseJsonEither r) +decodeBodyOrThrow :: forall a r. (Typeable a, FromJSON a, Member (Error GalleyAPIError) r) => Text -> Response (Maybe BL.ByteString) -> Sem r a +decodeBodyOrThrow ctx r = either (throw . GalleyAPIParseException . ParseException ctx) pure (responseJsonEither r) getAllTeamFeaturesForUser :: (Member Rpc r, Member (Input Endpoint) r) => @@ -584,7 +589,7 @@ changeTeamStatus tid s cur = do getTeamExposeInvitationURLsToTeamAdmin :: ( Member Rpc r, Member (Input Endpoint) r, - Member (Error ParseException) r, + Member (Error GalleyAPIError) r, Member TinyLog r ) => TeamId -> @@ -603,7 +608,7 @@ getTeamExposeInvitationURLsToTeamAdmin tid = do . expect2xx checkMLSOne2OneEstablished :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member (Input Endpoint) r, Member Rpc r, Member TinyLog r @@ -634,7 +639,7 @@ checkMLSOne2OneEstablished self (Qualified other otherDomain) = do . zUser (tUnqualified self) unblockConversation :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member (Input Endpoint) r, Member Rpc r, Member TinyLog r @@ -671,7 +676,7 @@ remote = field "remote" getEJPDConvInfo :: forall r. ( Member TinyLog r, - Member (Error ParseException) r, + Member (Error GalleyAPIError) r, Member (Input Endpoint) r, Member Rpc r ) => @@ -688,7 +693,7 @@ getEJPDConvInfo uid = do . paths ["i", "user", toByteString' uid, "all-conversations"] internalGetConversation :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -711,7 +716,7 @@ internalGetConversation convId = do . expect [status200, status404] getTeamContacts :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r @@ -734,12 +739,11 @@ getTeamContacts uid = do . expect [status200, status404] assertHasPermission :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r, - Member.IsPerm Member.TeamMember perm, - Show perm + Member.IsPerm Member.TeamMember perm ) => TeamId -> perm -> @@ -752,14 +756,9 @@ assertHasPermission tid perm uid = do . field "user" (toByteString uid) . msg (val "Asserting user has permission") rs <- galleyRequest req - case Bilge.statusCode rs of - 200 -> do - member <- decodeBodyOrThrow @Member.TeamMember "galley" rs - unless (Member.hasPermission member perm) $ - throw $ - ParseException "galley" $ - "User does not have permission: " <> show perm - _ -> throw $ ParseException "galley" "Failed to check permission" + case (Bilge.statusCode rs, responseJsonEither @Member.TeamMember rs) of + (200, Right member) | hasPermission member perm -> pure () + _ -> throw GalleyAPIForbidden where req = method GET @@ -767,7 +766,7 @@ assertHasPermission tid perm uid = do . expect [status200, status404] assertSSOEnabled :: - ( Member (Error ParseException) r, + ( Member (Error GalleyAPIError) r, Member Rpc r, Member (Input Endpoint) r, Member TinyLog r