From 20e4f5ed437b5a149d810c59ade0e1a6c3228edc Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 11:04:28 +0200 Subject: [PATCH 01/96] [wip] initial impl for GetBy* account queries as Effect and interpreter - new Effect operation GetAccountBy in UserSubsystem - new record GetBy - new stores ActivationCodeStore and InvitationCodeStore - new sql quasiquoter in cassandra-util - some more Ord instances derived - new function tSplit for the use with ViewPatterns --- libs/cassandra-util/cassandra-util.cabal | 2 + libs/cassandra-util/default.nix | 2 + libs/cassandra-util/src/Cassandra.hs | 1 + libs/cassandra-util/src/Cassandra/QQ.hs | 18 +++++ libs/types-common/src/Data/Qualified.hs | 5 ++ libs/wire-api/src/Wire/API/User.hs | 4 +- libs/wire-api/src/Wire/API/User/Identity.hs | 2 +- libs/wire-subsystems/default.nix | 2 + .../src/Wire/ActivationCodeStore.hs | 30 ++++++++ .../src/Wire/ActivationCodeStore/Cassandra.hs | 39 ++++++++++ .../src/Wire/InvitationCodeStore.hs | 68 +++++++++++++++++ .../src/Wire/InvitationCodeStore/Cassandra.hs | 55 ++++++++++++++ .../src/Wire/PasswordResetCodeStore.hs | 7 +- libs/wire-subsystems/src/Wire/StoredUser.hs | 1 + libs/wire-subsystems/src/Wire/UserStore.hs | 3 + .../src/Wire/UserStore/Cassandra.hs | 15 ++++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 20 +++++ .../src/Wire/UserSubsystem/Interpreter.hs | 76 ++++++++++++++++++- .../unit/Wire/MockInterpreters/UserStore.hs | 3 + libs/wire-subsystems/wire-subsystems.cabal | 5 ++ tools/stern/stern.cabal | 2 - 21 files changed, 349 insertions(+), 11 deletions(-) create mode 100644 libs/cassandra-util/src/Cassandra/QQ.hs create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeStore.hs create mode 100644 libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs create mode 100644 libs/wire-subsystems/src/Wire/InvitationCodeStore.hs create mode 100644 libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index af2e0094209..23a664b5606 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -13,6 +13,7 @@ build-type: Simple library exposed-modules: Cassandra + Cassandra.QQ Cassandra.CQL Cassandra.Exec Cassandra.Helpers @@ -84,6 +85,7 @@ library , imports , lens >=4.4 , lens-aeson >=1.0 + , template-haskell , optparse-applicative >=0.10 , retry , split >=0.2 diff --git a/libs/cassandra-util/default.nix b/libs/cassandra-util/default.nix index c7b1451a36e..e02d098a9b7 100644 --- a/libs/cassandra-util/default.nix +++ b/libs/cassandra-util/default.nix @@ -19,6 +19,7 @@ , optparse-applicative , retry , split +, template-haskell , text , time , tinylog @@ -44,6 +45,7 @@ mkDerivation { optparse-applicative retry split + template-haskell text time tinylog diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 6774abbeb56..74dcdfc45f4 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -91,3 +91,4 @@ import Cassandra.Exec as C x1, x5, ) +import Cassandra.QQ as C (sql) diff --git a/libs/cassandra-util/src/Cassandra/QQ.hs b/libs/cassandra-util/src/Cassandra/QQ.hs new file mode 100644 index 00000000000..b37b4a34740 --- /dev/null +++ b/libs/cassandra-util/src/Cassandra/QQ.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Cassandra.QQ (sql) where + +import Imports +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter (..)) + +-- | a simple quasi quoter to allow for tree-sitter syntax highlight injection. +-- This uses the name sql because that is known to tree-sitter, in contras to the name cql +sql :: QuasiQuoter +sql = + QuasiQuoter + { quotePat = error "Cassandra.QQ: sql quasiquoter cannot be used as pattern", + quoteType = error "Cassandra.QQ: sql quasiquoter cannot be used as type", + quoteDec = error "Cassandra.QQ: sql quasiquoter cannot be used as declaration", + quoteExp = appE [|fromString|] . stringE + } diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index d6367a1f851..8b06c4ea58f 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -28,6 +28,7 @@ module Data.Qualified tUnqualified, tDomain, tUntagged, + tSplit, qTagUnsafe, Remote, toRemoteUnsafe, @@ -92,6 +93,10 @@ tUnqualified = qUnqualified . tUntagged tDomain :: QualifiedWithTag t a -> Domain tDomain = qDomain . tUntagged +-- | perform 'qUnqualified' and 'tDomain' at once. Useful in ViewPatterns. +tSplit :: QualifiedWithTag t a -> (Domain, a) +tSplit (tUntagged -> q) = (q.qDomain, q.qUnqualified) + -- | A type representing a 'Qualified' value where the domain is guaranteed to -- be remote. type Remote = QualifiedWithTag 'QRemote diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 4875538165b..454902c9699 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -585,7 +585,7 @@ data User = User userManagedBy :: ManagedBy, userSupportedProtocols :: Set BaseProtocolTag } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform User) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema User) @@ -1790,7 +1790,7 @@ data UserAccount = UserAccount { accountUser :: !User, accountStatus :: !AccountStatus } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform UserAccount) deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema UserAccount diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 2929efa269b..644256c0ad7 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -93,7 +93,7 @@ import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) data UserIdentity = EmailIdentity EmailAddress | SSOIdentity UserSSOId (Maybe EmailAddress) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) isSSOIdentity :: UserIdentity -> Bool diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 890275b857d..080a271d46e 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -77,6 +77,7 @@ , wai-utilities , wire-api , wire-api-federation +, witherable }: mkDerivation { pname = "wire-subsystems"; @@ -147,6 +148,7 @@ mkDerivation { wai-utilities wire-api wire-api-federation + witherable ]; testHaskellDepends = [ aeson diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs new file mode 100644 index 00000000000..9473bd16f58 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -0,0 +1,30 @@ +-- 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 . +{-# LANGUAGE TemplateHaskell #-} + +module Wire.ActivationCodeStore where + +import Data.Id +import Imports +import Polysemy +import Wire.API.User.Activation +import Wire.UserKeyStore + +data ActivationCodeStore :: Effect where + LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode)) + +makeSem ''ActivationCodeStore diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs new file mode 100644 index 00000000000..34c8903d79f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -0,0 +1,39 @@ +module Wire.ActivationCodeStore.Cassandra where + +import Cassandra +import Data.Id +import Data.Text.Ascii qualified as Ascii +import Data.Text.Encoding qualified as T +import Imports +import OpenSSL.EVP.Digest +import Polysemy +import Polysemy.Embed +import Wire.API.User.Activation +import Wire.ActivationCodeStore +import Wire.UserKeyStore (EmailKey, emailKeyUniq) + +interpretActivationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor ActivationCodeStore r +interpretActivationCodeStoreToCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + LookupActivationCode ek -> embed do + liftIO (mkActivationKey ek) + >>= retry x1 . query1 cql . params LocalQuorum . Identity + where + cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) + cql = + [sql| + SELECT user, code FROM activation_keys WHERE key = ?" + |] + +mkActivationKey :: EmailKey -> IO ActivationKey +mkActivationKey k = do + d <- + maybe (fail "mkActivationKey: SHA256 not found") pure + =<< getDigestByName "SHA256" + pure do + ActivationKey + . Ascii.encodeBase64Url + . digestBS d + . T.encodeUtf8 + $ emailKeyUniq k diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs new file mode 100644 index 00000000000..aa761bfec7f --- /dev/null +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -0,0 +1,68 @@ +-- 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 . +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Wire.InvitationCodeStore where + +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.Id +import Data.Json.Util +import Database.CQL.Protocol (Record (..), TupleType, recordInstance) +import Imports +import Polysemy +import Wire.API.Team.Role +import Wire.API.User +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) + +data StoredInvitation = MkStoredInvitation + { teamId :: TeamId, + mrole :: Maybe Role, + invId :: InvitationId, + createdAt :: UTCTimeMillis, + mcreatedBy :: Maybe UserId, + email :: Email, + mname :: Maybe Name, + code :: InvitationCode + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform StoredInvitation) + +recordInstance ''StoredInvitation + +data StoredInvitationByTeam = MkStoredInvitationByTeam + { teamId :: TeamId, + invId :: InvitationId, + code :: InvitationCode + -- TODO(mangoiv): maybe we can drop this last element + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform StoredInvitationByTeam) + +recordInstance ''StoredInvitationByTeam + +data InvitationCodeStore :: Effect where + LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) + LookupInvitationCodesByEmail :: Email -> InvitationCodeStore m [StoredInvitationByTeam] + LookupSingleInvitationCodeByEmail :: Email -> InvitationCodeStore m (Maybe StoredInvitationByTeam) + +makeSem ''InvitationCodeStore + +lookupInvitationByEmail :: (Member InvitationCodeStore r) => Email -> Sem r (Maybe StoredInvitation) +lookupInvitationByEmail email = runMaybeT do + MkStoredInvitationByTeam {teamId, invId} <- MaybeT $ lookupSingleInvitationCodeByEmail email + MaybeT $ lookupInvitation teamId invId diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs new file mode 100644 index 00000000000..7504f1db369 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -0,0 +1,55 @@ +module Wire.InvitationCodeStore.Cassandra where + +import Cassandra +import Data.Id +import Database.CQL.Protocol (TupleType, asRecord) +import Imports +import Polysemy +import Polysemy.Embed +import Polysemy.TinyLog (TinyLog) +import System.Logger.Message qualified as Log +import Wire.API.User +import Wire.InvitationCodeStore +import Wire.Sem.Logger qualified as Log + +interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r, Member TinyLog r) => ClientState -> InterpreterFor InvitationCodeStore r +interpretInvitationCodeStoreToCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid + LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email + LookupSingleInvitationCodeByEmail email -> lookupSingleInvitationCodeByEmailImpl email + +lookupSingleInvitationCodeByEmailImpl :: (Member TinyLog r) => Email -> Sem (Embed Client : r) (Maybe StoredInvitationByTeam) +lookupSingleInvitationCodeByEmailImpl email = do + invs <- embed $ lookupInvitationCodesByEmailImpl email + case invs of + [] -> pure Nothing + [inv] -> pure $ Just inv + (_ : _ : _) -> do + -- edge case: more than one pending invite from different teams + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + + pure Nothing + +lookupInvitationCodesByEmailImpl :: Email -> Client [StoredInvitationByTeam] +lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (params LocalQuorum (Identity email))) + where + cql :: PrepQuery R (Identity Email) (TeamId, InvitationId, InvitationCode) + cql = + [sql| + SELECT team, invitation, code FROM team_invitation_email WHERE email = ? + |] + +lookupInvitationImpl :: TeamId -> InvitationId -> Client (Maybe StoredInvitation) +lookupInvitationImpl tid iid = + fmap asRecord + <$> retry x1 (query1 cql (params LocalQuorum (tid, iid))) + where + cql :: PrepQuery R (TeamId, InvitationId) (TupleType StoredInvitation) + cql = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? + |] diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs index dbf5502fc4a..b1db6098841 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuantifiedConstraints #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -33,11 +34,9 @@ data PRQueryData f = PRQueryData prqdTimeout :: f UTCTime } -deriving instance Show (PRQueryData Identity) +deriving instance (forall a. (Show a) => Show (f a)) => Show (PRQueryData f) -deriving instance Eq (PRQueryData Maybe) - -deriving instance Show (PRQueryData Maybe) +deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (PRQueryData f) mapPRQueryData :: (forall a. (f1 a -> f2 a)) -> PRQueryData f1 -> PRQueryData f2 mapPRQueryData f prqd = prqd {prqdRetries = f prqd.prqdRetries, prqdTimeout = f prqd.prqdTimeout} diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs index 38bb072401d..2d4c4581de5 100644 --- a/libs/wire-subsystems/src/Wire/StoredUser.hs +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} module Wire.StoredUser where diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 3544ec5b35b..39f822666ca 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -63,6 +63,9 @@ data UserStore m a where -- an email address or phone number. IsActivated :: UserId -> UserStore m Bool LookupLocale :: UserId -> UserStore m (Maybe (Maybe Language, Maybe Country)) + -- | Look up accounts given user ids. For the purpose of the DB, Users and accounts are identical, so this + -- returns a @['StoredUser']@ + LookupAccounts :: [UserId] -> UserStore m [StoredUser] makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index b62e615220e..a54a02126b2 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -26,6 +26,12 @@ interpretUserStoreCassandra casClient = LookupStatus uid -> embed $ lookupStatusImpl uid IsActivated uid -> embed $ isActivatedImpl uid LookupLocale uid -> embed $ lookupLocaleImpl uid + LookupAccounts uids -> embed $ lookupAccountsImpl uids + +lookupAccountsImpl :: [UserId] -> Client [StoredUser] +lookupAccountsImpl usrs = + map asRecord + <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) getUserImpl :: (Member (Embed Client) r) => UserId -> Sem r (Maybe StoredUser) getUserImpl uid = embed $ do @@ -180,3 +186,12 @@ activatedSelect = "SELECT activated FROM user WHERE id = ?" localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) localeSelect = "SELECT language, country FROM user WHERE id = ?" + +accountsSelect :: PrepQuery R (Identity [UserId]) (TupleType StoredUser) +accountsSelect = + [sql| + SELECT id, name, text_status, picture, email, sso_id, accent_id, assets, + activated, status, expires, language, country, provider, + service, handle, team, managed_by, supported_protocols + FROM user WHERE id IN ? + |] diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 3a0cab37a6a..60646a00888 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -53,11 +53,30 @@ instance Default UserProfileUpdate where supportedProtocols = Nothing } +-- | how to get an account for a user +data GetBy = MkGetBy + { -- | whether or not to include ending invitations in the lookups } + includePendingInvitations :: !Bool, + -- | get accounds by 'UserId's + getByUserIds :: ![UserId], + -- | get accounds by 'Email's + getByEmail :: ![Email], + -- | get accounds by their 'Handle' + getByHandle :: ![Handle] + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform GetBy + +instance Default GetBy where + def = MkGetBy False [] [] [] + data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] + -- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria + GetAccountsBy :: Local GetBy -> UserSubsystem m [UserAccount] -- | Self profile contains things not present in Profile. GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) -- | These give us partial success and hide concurrency in the interpreter. @@ -71,6 +90,7 @@ data UserSubsystem m a where CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] -- | parses a handle, this may fail so it's effectful UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m () + -- TODO(mangoiv): this can probably go in favour of 'GetAccountsBy' GetLocalUserAccountByUserKey :: Local EmailKey -> UserSubsystem m (Maybe UserAccount) -- | returns the user's locale or the default locale if the users exists LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 39dd0e179af..be2df9a047f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -13,6 +13,7 @@ import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold +import Data.List.Extra (nubOrd) import Data.Qualified import Data.Time.Clock import Imports hiding (local) @@ -26,12 +27,14 @@ import Wire.API.Team.Feature import Wire.API.Team.Member hiding (userId) import Wire.API.User import Wire.API.UserEvent +import Wire.ActivationCodeStore (ActivationCodeStore, lookupActivationCode) import Wire.Arbitrary import Wire.BlockListStore as BlockList import Wire.DeleteQueue import Wire.Events import Wire.FederationAPIAccess import Wire.GalleyAPIAccess +import Wire.InvitationCodeStore (InvitationCodeStore, lookupInvitationByEmail) import Wire.Sem.Concurrency import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -41,6 +44,7 @@ import Wire.UserStore as UserStore import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.HandleBlacklist +import Witherable (wither) data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, @@ -65,7 +69,9 @@ runUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member InvitationCodeStore r, + Member ActivationCodeStore r ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r @@ -86,12 +92,15 @@ interpretUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member InvitationCodeStore r, + Member ActivationCodeStore r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others + GetAccountsBy criteria -> getAccountsByImpl criteria GetSelfProfile self -> getSelfProfileImpl self GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update @@ -495,3 +504,66 @@ checkHandlesImpl check num = reverse <$> collectFree [] check num case owner of Nothing -> collectFree (h : free) hs (n - 1) Just _ -> collectFree free hs n + +-------------------------------------------------------------------------------- +-- getting user accounts by different criteria + +getAccountsByImpl :: + forall r. + ( Member UserStore r, + Member DeleteQueue r, + Member (Input UserSubsystemConfig) r, + Member InvitationCodeStore r, + Member UserKeyStore r, + Member ActivationCodeStore r + ) => + Local GetBy -> + Sem r [UserAccount] +getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do + config <- input + + handleUserIds <- wither lookupHandle getByHandle + + let storedToAcc = mkAccountFromStored domain config.defaultLocale + + accountValid :: StoredUser -> Sem r (Maybe UserAccount) + accountValid storedUser = + let account = storedToAcc storedUser + notValid = pure Nothing + valid = pure $ Just account + in case userIdentity . accountUser $ account of + Nothing -> notValid + Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of + (PendingInvitation, False, _) -> notValid + (PendingInvitation, True, Just email) -> + lookupInvitationByEmail email >>= \case + Nothing -> notValid + Just _ -> do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + -- job akin to 'pendingUserActivationCleanup' + enqueueUserDeletion (userId account.accountUser) + valid + (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email + (Active, _, _) -> valid + (Suspended, _, _) -> valid + (Deleted, _, _) -> valid + (Ephemeral, _, _) -> valid + + accsByIds :: [UserAccount] <- + wither accountValid + =<< lookupAccounts (nubOrd $ handleUserIds <> getByUserIds) + + accsByEmail <- flip foldMap getByEmail \email -> do + let ek = mkEmailKey email + mactiveUid <- lookupKey ek + ac <- lookupActivationCode ek + let muidFromActivationKey = ac >>= fst + res <- lookupAccounts (nubOrd $ catMaybes [mactiveUid, muidFromActivationKey]) + pure $ + map + storedToAcc + if includePendingInvitations + then res + else filter (\acc -> acc.status /= Just PendingInvitation) res + pure (nubOrd $ accsByIds <> accsByEmail) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 563b91f4bd1..296f980a667 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + module Wire.MockInterpreters.UserStore where import Data.Handle @@ -57,6 +59,7 @@ inMemoryUserStoreInterpreter = interpret $ \case LookupStatus uid -> lookupStatusImpl uid IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid + LookupAccounts TODO -> TODO lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country))) lookupLocaleImpl uid = do diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index e2763335c9f..b1c10383949 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -97,6 +97,10 @@ library Wire.ParseException Wire.PasswordResetCodeStore Wire.PasswordResetCodeStore.Cassandra + Wire.InvitationCodeStore + Wire.InvitationCodeStore.Cassandra + Wire.ActivationCodeStore + Wire.ActivationCodeStore.Cassandra Wire.PasswordStore Wire.PasswordStore.Cassandra Wire.PropertyStore @@ -188,6 +192,7 @@ library , uuid , wai-utilities , wire-api + , witherable , wire-api-federation default-language: GHC2021 diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index ba50b7edb6b..0f4f8b2c0c3 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -187,10 +187,8 @@ test-suite stern-tests executable stern-integration main-is: Main.hs - -- cabal-fmt: expand test/integration other-modules: API - Main TestSetup Util From 59f1995c03fd0478dbb445c2fb7324a087734ab3 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 20 Aug 2024 16:25:44 +0200 Subject: [PATCH 02/96] [feat] implement mock interpreters --- .../src/Wire/ActivationCodeStore/Cassandra.hs | 2 +- .../src/Wire/InvitationCodeStore.hs | 28 ++++++++++--- .../src/Wire/InvitationCodeStore/Cassandra.hs | 20 +--------- .../src/Wire/UserSubsystem/Interpreter.hs | 8 +++- .../test/unit/Wire/MiniBackend.hs | 40 +++++++++++++++---- .../MockInterpreters/ActivationCodeStore.hs | 13 ++++++ .../MockInterpreters/InvitationCodeStore.hs | 20 ++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 3 ++ 8 files changed, 98 insertions(+), 36 deletions(-) create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 34c8903d79f..9259c1fca91 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -23,7 +23,7 @@ interpretActivationCodeStoreToCassandra casClient = cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) cql = [sql| - SELECT user, code FROM activation_keys WHERE key = ?" + SELECT user, code FROM activation_keys WHERE key = ? |] mkActivationKey :: EmailKey -> IO ActivationKey diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index aa761bfec7f..afc1740686b 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -20,14 +20,17 @@ module Wire.InvitationCodeStore where import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import Data.Id -import Data.Json.Util +import Data.Id (InvitationId, TeamId, UserId) +import Data.Json.Util (UTCTimeMillis) import Database.CQL.Protocol (Record (..), TupleType, recordInstance) import Imports import Polysemy -import Wire.API.Team.Role -import Wire.API.User +import Polysemy.TinyLog (TinyLog) +import System.Logger.Message qualified as Log +import Wire.API.Team.Role (Role) +import Wire.API.User (Email, InvitationCode, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) +import Wire.Sem.Logger qualified as Log data StoredInvitation = MkStoredInvitation { teamId :: TeamId, @@ -58,11 +61,24 @@ recordInstance ''StoredInvitationByTeam data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationCodesByEmail :: Email -> InvitationCodeStore m [StoredInvitationByTeam] - LookupSingleInvitationCodeByEmail :: Email -> InvitationCodeStore m (Maybe StoredInvitationByTeam) makeSem ''InvitationCodeStore -lookupInvitationByEmail :: (Member InvitationCodeStore r) => Email -> Sem r (Maybe StoredInvitation) +lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => Email -> Sem r (Maybe StoredInvitation) lookupInvitationByEmail email = runMaybeT do MkStoredInvitationByTeam {teamId, invId} <- MaybeT $ lookupSingleInvitationCodeByEmail email MaybeT $ lookupInvitation teamId invId + +lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => Email -> Sem r (Maybe StoredInvitationByTeam) +lookupSingleInvitationCodeByEmail email = do + invs <- lookupInvitationCodesByEmail email + case invs of + [] -> pure Nothing + [inv] -> pure $ Just inv + (_ : _ : _) -> do + -- edge case: more than one pending invite from different teams + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + + pure Nothing diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 7504f1db369..74833d0eec1 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -6,33 +6,15 @@ import Database.CQL.Protocol (TupleType, asRecord) import Imports import Polysemy import Polysemy.Embed -import Polysemy.TinyLog (TinyLog) -import System.Logger.Message qualified as Log import Wire.API.User import Wire.InvitationCodeStore -import Wire.Sem.Logger qualified as Log -interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r, Member TinyLog r) => ClientState -> InterpreterFor InvitationCodeStore r +interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor InvitationCodeStore r interpretInvitationCodeStoreToCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email - LookupSingleInvitationCodeByEmail email -> lookupSingleInvitationCodeByEmailImpl email - -lookupSingleInvitationCodeByEmailImpl :: (Member TinyLog r) => Email -> Sem (Embed Client : r) (Maybe StoredInvitationByTeam) -lookupSingleInvitationCodeByEmailImpl email = do - invs <- embed $ lookupInvitationCodesByEmailImpl email - case invs of - [] -> pure Nothing - [inv] -> pure $ Just inv - (_ : _ : _) -> do - -- edge case: more than one pending invite from different teams - Log.info $ - Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") - . Log.field "email" (show email) - - pure Nothing lookupInvitationCodesByEmailImpl :: Email -> Client [StoredInvitationByTeam] lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (params LocalQuorum (Identity email))) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index be2df9a047f..be01bd446fc 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -20,6 +20,7 @@ import Imports hiding (local) import Polysemy import Polysemy.Error hiding (try) import Polysemy.Input +import Polysemy.TinyLog (TinyLog) import Servant.Client.Core import Wire.API.Federation.API import Wire.API.Federation.Error @@ -70,6 +71,7 @@ runUserSubsystem :: RunClient (fedM 'Brig), FederationMonad fedM, Typeable fedM, + Member (TinyLog) r, Member InvitationCodeStore r, Member ActivationCodeStore r ) => @@ -94,7 +96,8 @@ interpretUserSubsystem :: FederationMonad fedM, Typeable fedM, Member InvitationCodeStore r, - Member ActivationCodeStore r + Member ActivationCodeStore r, + Member TinyLog r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case @@ -515,7 +518,8 @@ getAccountsByImpl :: Member (Input UserSubsystemConfig) r, Member InvitationCodeStore r, Member UserKeyStore r, - Member ActivationCodeStore r + Member ActivationCodeStore r, + Member TinyLog r ) => Local GetBy -> Sem r [UserAccount] diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index bd712dfe489..88b3a128338 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.MiniBackend @@ -34,6 +35,8 @@ import Data.Proxy import Data.Qualified import Data.Time import Data.Type.Equality +import GHC.Generics +import Generics.SOP qualified as SOP import Imports import Polysemy import Polysemy.Error @@ -51,7 +54,9 @@ import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.API.Team.Member hiding (userId) import Wire.API.User as User hiding (DeleteUser) +import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Password +import Wire.ActivationCodeStore import Wire.BlockListStore import Wire.DeleteQueue import Wire.DeleteQueue.InMemory @@ -60,7 +65,10 @@ import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter as FI import Wire.GalleyAPIAccess import Wire.InternalEvent hiding (DeleteUser) +import Wire.InvitationCodeStore import Wire.MockInterpreters +import Wire.MockInterpreters.ActivationCodeStore (inMemoryActivationCodeStoreInterpreter) +import Wire.MockInterpreters.InvitationCodeStore (inMemoryInvitationCodeStoreInterpreter) import Wire.PasswordResetCodeStore import Wire.Sem.Concurrency import Wire.Sem.Concurrency.Sequential @@ -97,6 +105,10 @@ type AllErrors = type MiniBackendEffects = [ UserSubsystem, GalleyAPIAccess, + InvitationCodeStore, + State (Map (TeamId, InvitationId) StoredInvitation), + ActivationCodeStore, + State (Map EmailKey (Maybe UserId, ActivationCode)), BlockListStore, State [EmailKey], UserStore, @@ -123,17 +135,15 @@ data MiniBackend = MkMiniBackend users :: [StoredUser], userKeys :: Map EmailKey UserId, passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity), - blockList :: [EmailKey] + blockList :: [EmailKey], + activationCodes :: Map EmailKey (Maybe UserId, ActivationCode), + invitations :: Map (TeamId, InvitationId) StoredInvitation } + deriving stock (Eq, Show, Generic) + deriving anyclass (SOP.Generic) instance Default MiniBackend where - def = - MkMiniBackend - { users = mempty, - userKeys = mempty, - passwordResetCodes = mempty, - blockList = mempty - } + def = SOP.productTypeTo $ SOP.hcpure (Proxy @Monoid) mempty -- | represents an entire federated, stateful world of backends newtype MiniFederation = MkMiniFederation @@ -352,9 +362,23 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . inMemoryUserStoreInterpreter . liftBlockListStoreState . inMemoryBlockListStoreInterpreter + . liftActivationCodeStoreState + . inMemoryActivationCodeStoreInterpreter + . liftInvitationCodeStoreState + . inMemoryInvitationCodeStoreInterpreter . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg +liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a +liftActivationCodeStoreState = interpret \case + Polysemy.State.Get -> gets (.activationCodes) + Put newAcs -> modify $ \b -> b {activationCodes = newAcs} + +liftInvitationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map (TeamId, InvitationId) StoredInvitation) : r) a -> Sem r a +liftInvitationCodeStoreState = interpret \case + Polysemy.State.Get -> gets (.invitations) + Put newInvs -> modify $ \b -> b {invitations = newInvs} + liftBlockListStoreState :: (Member (State MiniBackend) r) => Sem (State [EmailKey] : r) a -> Sem r a liftBlockListStoreState = interpret $ \case Polysemy.State.Get -> gets (.blockList) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs new file mode 100644 index 00000000000..0265c8d07fe --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs @@ -0,0 +1,13 @@ +module Wire.MockInterpreters.ActivationCodeStore where + +import Data.Id +import Data.Map +import Imports +import Polysemy +import Polysemy.State +import Wire.API.User.Activation +import Wire.ActivationCodeStore (ActivationCodeStore (..)) +import Wire.UserKeyStore + +inMemoryActivationCodeStoreInterpreter :: (Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r) => InterpreterFor ActivationCodeStore r +inMemoryActivationCodeStoreInterpreter = interpret \case LookupActivationCode ek -> gets (!? ek) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs new file mode 100644 index 00000000000..98817530d7a --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.MockInterpreters.InvitationCodeStore where + +import Data.Id (InvitationId, TeamId) +import Data.Map (elems, (!?)) +import Imports +import Polysemy +import Polysemy.State (State, get, gets) +import Wire.InvitationCodeStore + +-- TODO(mangoiv): I start to feel like we want a proper (in memory) DB here +inMemoryInvitationCodeStoreInterpreter :: forall r. (Member (State (Map (TeamId, InvitationId) StoredInvitation)) r) => InterpreterFor InvitationCodeStore r +inMemoryInvitationCodeStoreInterpreter = interpret \case + LookupInvitation tid iid -> gets (!? (tid, iid)) + LookupInvitationCodesByEmail em -> + let c MkStoredInvitation {..} + | email == em = Just MkStoredInvitationByTeam {..} + | otherwise = Nothing + in mapMaybe c . elems <$> get diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index b1c10383949..ea3dd31b677 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -211,6 +211,8 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters + Wire.MockInterpreters.InvitationCodeStore + Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.Error @@ -245,6 +247,7 @@ test-suite wire-subsystems-tests , data-default , errors , extended + , generics-sop , gundeck-types , hspec , imports From 1bf730eb140ca6c5c761a99ed5300a51f6a79144 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 20 Aug 2024 17:17:44 +0200 Subject: [PATCH 03/96] [chore] format --- libs/cassandra-util/cassandra-util.cabal | 4 ++-- libs/wire-subsystems/default.nix | 2 ++ libs/wire-subsystems/wire-subsystems.cabal | 12 ++++++------ tools/stern/stern.cabal | 1 - 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index 23a664b5606..927498c24f5 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -13,12 +13,12 @@ build-type: Simple library exposed-modules: Cassandra - Cassandra.QQ Cassandra.CQL Cassandra.Exec Cassandra.Helpers Cassandra.MigrateSchema Cassandra.Options + Cassandra.QQ Cassandra.Schema Cassandra.Settings Cassandra.Util @@ -85,10 +85,10 @@ library , imports , lens >=4.4 , lens-aeson >=1.0 - , template-haskell , optparse-applicative >=0.10 , retry , split >=0.2 + , template-haskell , text >=0.11 , time >=1.4 , tinylog >=0.7 diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 080a271d46e..c147bdfe1fc 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -24,6 +24,7 @@ , exceptions , extended , extra +, generics-sop , gitignoreSource , gundeck-types , HaskellNet @@ -161,6 +162,7 @@ mkDerivation { data-default errors extended + generics-sop gundeck-types hspec imports diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index ea3dd31b677..5cb29061a08 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -69,6 +69,8 @@ library -- cabal-fmt: expand src exposed-modules: + Wire.ActivationCodeStore + Wire.ActivationCodeStore.Cassandra Wire.AuthenticationSubsystem Wire.AuthenticationSubsystem.Error Wire.AuthenticationSubsystem.Interpreter @@ -92,15 +94,13 @@ library Wire.GundeckAPIAccess Wire.HashPassword Wire.InternalEvent + Wire.InvitationCodeStore + Wire.InvitationCodeStore.Cassandra Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.ParseException Wire.PasswordResetCodeStore Wire.PasswordResetCodeStore.Cassandra - Wire.InvitationCodeStore - Wire.InvitationCodeStore.Cassandra - Wire.ActivationCodeStore - Wire.ActivationCodeStore.Cassandra Wire.PasswordStore Wire.PasswordStore.Cassandra Wire.PropertyStore @@ -192,8 +192,8 @@ library , uuid , wai-utilities , wire-api - , witherable , wire-api-federation + , witherable default-language: GHC2021 @@ -211,7 +211,6 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters - Wire.MockInterpreters.InvitationCodeStore Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.EmailSubsystem @@ -219,6 +218,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.Events Wire.MockInterpreters.GalleyAPIAccess Wire.MockInterpreters.HashPassword + Wire.MockInterpreters.InvitationCodeStore Wire.MockInterpreters.Now Wire.MockInterpreters.PasswordResetCodeStore Wire.MockInterpreters.PasswordStore diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 0f4f8b2c0c3..b7e04c9de2b 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -186,7 +186,6 @@ test-suite stern-tests executable stern-integration main-is: Main.hs - other-modules: API TestSetup From 87ffbb63fb58e5eeef5a26e6511b7e620d4837e3 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 14:25:26 +0200 Subject: [PATCH 04/96] [wip] wrap up the invitationcodestore - port more functions to the store effect - remove functions that are not needed anymore TODO: - actually swap out DB module functions with new functions from store - move all remaining functions that are needed to make it work - leave FUTUREWORK in DB module to make invitationcode store complete - apply the same things for activationcode store i.e. (remove the old functions, move needed ones into subsystem, leave futurework for unneeded ones) --- libs/hscim/test/Test/Schema/UserSpec.hs | 2 +- libs/wire-api/src/Wire/API/Team/Invitation.hs | 43 +- .../Golden/Generated/InvitationList_team.hs | 876 +++++++++--------- .../API/Golden/Generated/Invitation_team.hs | 320 +++---- .../src/Wire/GalleyAPIAccess.hs | 3 +- .../src/Wire/GalleyAPIAccess/Rpc.hs | 7 +- .../src/Wire/InvitationCodeStore.hs | 52 +- .../src/Wire/InvitationCodeStore/Cassandra.hs | 14 +- .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 +- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- .../MockInterpreters/InvitationCodeStore.hs | 2 + services/brig/src/Brig/API/Internal.hs | 72 +- services/brig/src/Brig/API/Public.hs | 5 +- services/brig/src/Brig/API/User.hs | 48 +- .../brig/src/Brig/CanonicalInterpreter.hs | 8 + services/brig/src/Brig/Team/API.hs | 72 +- services/brig/src/Brig/Team/DB.hs | 66 -- services/brig/test/integration/API/Team.hs | 90 +- .../brig/test/integration/API/Team/Util.hs | 8 +- .../brig/test/integration/API/User/Account.hs | 6 +- .../integration/API/UserPendingActivation.hs | 2 +- services/galley/test/integration/API/Util.hs | 4 +- .../Test/Spar/Scim/UserSpec.hs | 18 +- services/spar/test-integration/Util/Core.hs | 4 +- tools/stern/test/integration/Util.hs | 4 +- 25 files changed, 858 insertions(+), 872 deletions(-) diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 8dcaa9d50ed..9971f339471 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -98,7 +98,7 @@ spec = do ("preferredLanguage", toJSON @Text mempty), ("locale", toJSON @Text mempty), ("password", toJSON @Text mempty), - ("emails", toJSON @[Email] mempty), + ("emails", toJSON @[EmailAddress] mempty), ("phoneNumbers", toJSON @[Phone] mempty), ("ims", toJSON @[IM] mempty), ("photos", toJSON @[Photo] mempty), diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index b5c0d1a8096..b785ad7fb21 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} -- This file is part of the Wire Server implementation. -- @@ -36,6 +38,7 @@ import Data.OpenApi qualified as S import Data.SOP import Data.Schema import Data.Text.Encoding qualified as TE +import GHC.Records import Imports import Servant (FromHttpApiData (..), ToHttpApiData (..)) import URI.ByteString @@ -67,27 +70,27 @@ instance ToSchema InvitationRequest where InvitationRequest <$> locale .= optFieldWithDocModifier "locale" (description ?~ "Locale to use for the invitation.") (maybeWithDefault A.Null schema) - <*> role + <*> (getField @"role") .= optFieldWithDocModifier "role" (description ?~ "Role of the invitee (invited user).") (maybeWithDefault A.Null schema) - <*> inviteeName + <*> (getField @"inviteeName") .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters).") (maybeWithDefault A.Null schema) - <*> inviteeEmail + <*> (getField @"inviteeEmail") .= fieldWithDocModifier "email" (description ?~ "Email of the invitee.") schema -------------------------------------------------------------------------------- -- Invitation data Invitation = Invitation - { inTeam :: TeamId, - inRole :: Role, - inInvitation :: InvitationId, - inCreatedAt :: UTCTimeMillis, - -- | this is always 'Just' for new invitations, but for + { team :: TeamId, + role :: Role, + invitationId :: InvitationId, + createdAt :: UTCTimeMillis, + -- | this is always 'Just' for newvitations, but for -- migration it is allowed to be 'Nothing'. - inCreatedBy :: Maybe UserId, - inInviteeEmail :: EmailAddress, - inInviteeName :: Maybe Name, - inInviteeUrl :: Maybe (URIRef Absolute) + createdBy :: Maybe UserId, + inviteeEmail :: EmailAddress, + inviteeName :: Maybe Name, + inviteeUrl :: Maybe (URIRef Absolute) } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Invitation) @@ -99,22 +102,22 @@ instance ToSchema Invitation where "Invitation" (description ?~ "An invitation to join a team on Wire") $ Invitation - <$> inTeam + <$> (getField @"team") .= fieldWithDocModifier "team" (description ?~ "Team ID of the inviting team") schema - <*> inRole + <*> (getField @"role") -- clients, when leaving "role" empty, can leave the default role choice to us .= (fromMaybe defaultRole <$> optFieldWithDocModifier "role" (description ?~ "Role of the invited user") schema) - <*> inInvitation + <*> (getField @"invitationId") .= fieldWithDocModifier "id" (description ?~ "UUID used to refer the invitation") schema - <*> inCreatedAt + <*> (getField @"createdAt") .= fieldWithDocModifier "created_at" (description ?~ "Timestamp of invitation creation") schema - <*> inCreatedBy + <*> (getField @"createdBy") .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user") (maybeWithDefault A.Null schema) - <*> inInviteeEmail + <*> (getField @"inviteeEmail") .= fieldWithDocModifier "email" (description ?~ "Email of the invitee") schema - <*> inInviteeName + <*> (getField @"inviteeName") .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters)") (maybeWithDefault A.Null schema) - <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inInviteeUrl) + <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inviteeUrl) .= optFieldWithDocModifier "url" (description ?~ "URL of the invitation link to be sent to the invitee") (maybeWithDefault A.Null urlSchema) where urlSchema = parsedText "URIRef Absolute" (runParser (uriParser strictURIParserOptions) . TE.encodeUtf8) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs index 7ad5845c320..1463b0d1136 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs @@ -37,20 +37,20 @@ testObject_InvitationList_team_2 = InvitationList { ilInvitations = [ Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T09:28:36.729Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T09:28:36.729Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "fuC9p\1098501A\163554\f\ENQ\SO\21027N\47326_?oCX.U\r\163744W\33096\58996\1038685\DC3\t[\37667\SYN/\8408A\145025\173325\DC4H\135001\STX\166880\EOT\165028o\DC3" } ), - inInviteeUrl = Just (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14")) + inviteeUrl = Just (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14")) } ], ilHasMore = True @@ -64,126 +64,126 @@ testObject_InvitationList_team_4 = InvitationList { ilInvitations = [ Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T19:46:50.121Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T19:46:50.121Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "R6\133444\134053VQ\187682\SUB\SOH\180538\&0C\1088909\ESCR\185800\125002@\38857Z?\STX\169387\1067878e}\SOH\ETB\EOTm\184898\US]\986782\189015\1059374\986508\b\DC1zfw-5\120662\CAN\1064450 \EMe\DC4|\14426Vo{\1076439\DC3#\USS\45051&zz\160719\&9\142411,\SI\f\SOHp\1025840\DLE\163178\1060369.&\997544kZ\50431u\b\50764\1109279n:\1103691D$.Q" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T09:00:02.901Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T09:00:02.901Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\DC2}q\CAN=SA\ETXx\t\ETX\\\v[\b)(\ESC]\135875Y\v@p\41515l\45065\157388\NUL\t\1100066\SOH1\DC1\ENQ\1021763\"i\29460\EM\b\ACK\SI\DC2v\ACK" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T11:10:31.203Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T11:10:31.203Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\58076&\1059325Ec\NUL\16147}k\1036184l\172911\USJ\EM0^.+F\DEL\NUL\f$'`!\ETB[p\1041609}>E0y\96440#4I\a\66593jc\ESCgt\22473\1093208P\DC4!\1095909E93'Y$YL\46886b\r:,\181790\SO\153247y\ETX;\1064633\1099478z4z-D\1096755a\139100\&6\164829r\1033640\987906J\DLE\48134" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T23:41:34.529Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T23:41:34.529Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Ft*O1\b&\SO\CAN<\72219\1092619m\n\DC4\DC2; \ETX\988837\DC1\1059627\"k.T\1023249[[\FS\EOT{j`\GS\997342c\1066411{\SUB\GSQY\182805\t\NAKy\t\132339j\1036225W " } ), - inInviteeUrl = Nothing - }, - Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T00:29:17.658Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing - }, - Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T13:34:37.117Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + inviteeUrl = Nothing + }, + Invitation + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T00:29:17.658Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing + }, + Invitation + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T13:34:37.117Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Lo\r\1107113\1111565\1042998\1027480g\"\1055088\SUB\SUB\180703\43419\EOTv\188258,\171408(\GSQT\150160;\1063450\ENQ\ETBB\1106414H\170195\\\1040638,Y" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_6 :: Invitation testObject_Invitation_team_6 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T08:56:40.919Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T08:56:40.919Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "O~\DC4U\RS?V3_\191280Slh\1072236Q1\1011443j|~M7\1092762\1097596\94632\DC1K\1078140Afs\178951lGV\1113159]`o\EMf\34020InvfDDy\\DI\163761\1091945\ETBB\159212F*X\SOH\SUB\50580\ETX\DLE<\ETX\SYNc\DEL\DLE,p\v*\1005720Vn\fI\70201xS\STXV\ESC$\EMu\1002390xl>\aZ\DC44e\DC4aZ" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_7 :: Invitation testObject_Invitation_team_7 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000001")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-07T18:46:22.786Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000001")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-07T18:46:22.786Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\CAN.\110967\1085214\DLE\f\DLE\CAN\150564o;Yay:yY $\ETX<\879%@\USre>5L'R\DC3\178035oy#]c4!\99741U\54858\26279\1042232\1062242p_>f\SO\DEL\175240\1077738\995735_Vm\US}\STXPz\r\ENQK\SO+>\991648\NUL\153467?pu?r\ESC\SUB!?\168405;\6533S\18757\a\1071148\b\1023581\996567\17385\120022\b\SUB\FS\SIF%<\125113\SIh\ESC\ETX\SI\994739\USO\NULg_\151272\47274\1026399\EOT\1058084\1089771z~%IA'R\b\1011572Hv^\1043633wrjb\t\166747\ETX" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_12 :: Invitation testObject_Invitation_team_12 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T22:47:35.829Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T22:47:35.829Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\DLEZ+wd^\67082\1073384\&1\STXYdXt>\1081020LSB7F9\\\135148\ENQ\n\987295\"\127009|\a\61724\157754\DEL'\ESCTygU\1106772R\52822\1071584O4\1035713E9\"\1016016\DC2Re\ENQD}\1051112\161959\1104733\bV\176894%98'\RS9\ACK4yP\83405\14400\345\aw\t\1098022\v\1078003xv/Yl\1005740\158703" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_13 :: Invitation testObject_Invitation_team_13 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000200000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T01:18:31.982Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000002"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Just (Name {fromName = "U"}), - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000200000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T01:18:31.982Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000002"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just (Name {fromName = "U"}), + inviteeUrl = Nothing } testObject_Invitation_team_14 :: Invitation testObject_Invitation_team_14 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000100000000")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000200000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T23:54:25.090Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000200000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000100000000")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000200000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T23:54:25.090Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000200000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing } testObject_Invitation_team_15 :: Invitation testObject_Invitation_team_15 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T22:22:28.568Z"), - inCreatedBy = Nothing, - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T22:22:28.568Z"), + createdBy = Nothing, + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\71448\US&KIL\DC3\1086159![\n6\1111661HEj4E\12136UL\US>2\1070931_\nJ\53410Pv\SO\SIR\30897\&8\bmS\45510mE\ag\SYN\ENQ%\14545\f!\v\US\119306\ENQ\184817\1044744\SO83!j\73854\GS\1071331,\RS\CANF\1062795\1110535U\EMJb\DC1j\EMY\92304O\1007855" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_16 :: Invitation testObject_Invitation_team_16 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000200000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T09:56:33.113Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Just (Name {fromName = "\GS\DC4Q;6/_f*7\1093966\SI+\1092810\41698\&9"}), - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000200000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T09:56:33.113Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just (Name {fromName = "\GS\DC4Q;6/_f*7\1093966\SI+\1092810\41698\&9"}), + inviteeUrl = Nothing } testObject_Invitation_team_17 :: Invitation testObject_Invitation_team_17 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000002")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T06:30:23.239Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000002")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T06:30:23.239Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Z\ESC9E\DEL\NAK\37708\83413}(3m\97177\97764'\1072786.WY;\RS8?v-\1100720\DC2\1015859" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_19 :: Invitation testObject_Invitation_team_19 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000000")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-07T15:08:06.796Z"), - inCreatedBy = Nothing, - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000000")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-07T15:08:06.796Z"), + createdBy = Nothing, + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\38776r\111317\ETXQi\1000087\1097943\EM\170747\74323+\1067948Q?H=G-\RS;\1103719\SOq^K;a\1052250W\EM X\83384\1073320>M\980\26387jjbU-&\1040136v\NULy\181884\a|\SYNUfJCHjP\SO\1111555\27981DNA:~s" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_20 :: Invitation testObject_Invitation_team_20 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T08:07:17.747Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T08:07:17.747Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing } diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 63075543d4a..e129fb5bc2c 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -67,7 +67,8 @@ data GalleyAPIAccess m a where AddTeamMember :: UserId -> TeamId -> - (Maybe (UserId, UTCTimeMillis), Role) -> + Maybe (UserId, UTCTimeMillis) -> + Role -> GalleyAPIAccess m Bool CreateTeam :: UserId -> diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index e226d09bcdd..aa9dcb4dc9e 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -71,7 +71,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamConv id' id'' id'2 -> getTeamConv v id' id'' id'2 NewClient id' ci -> newClient id' ci CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' - AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 + AddTeamMember id' id'' a b -> addTeamMember id' id'' a b CreateTeam id' bnt id'' -> createTeam id' bnt id'' GetTeamMember id' id'' -> getTeamMember id' id'' GetTeamMembers id' -> getTeamMembers id' @@ -234,9 +234,10 @@ addTeamMember :: ) => UserId -> TeamId -> - (Maybe (UserId, UTCTimeMillis), Role) -> + Maybe (UserId, UTCTimeMillis) -> + Role -> Sem r Bool -addTeamMember u tid (minvmeta, role) = do +addTeamMember u tid minvmeta role = do debug $ remote "galley" . msg (val "Adding member to team") diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index afc1740686b..e60691d6817 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,19 +28,22 @@ import Imports import Polysemy import Polysemy.TinyLog (TinyLog) import System.Logger.Message qualified as Log -import Wire.API.Team.Role (Role) -import Wire.API.User (Email, InvitationCode, Name) +import Wire.API.Team.Invitation (Invitation (inviteeEmail)) +import Wire.API.Team.Invitation qualified as Public +import Wire.API.Team.Role (Role, defaultRole) +import Wire.API.User (EmailAddress, InvitationCode, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) +import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl) import Wire.Sem.Logger qualified as Log data StoredInvitation = MkStoredInvitation { teamId :: TeamId, - mrole :: Maybe Role, - invId :: InvitationId, + role :: Maybe Role, + invitationId :: InvitationId, createdAt :: UTCTimeMillis, - mcreatedBy :: Maybe UserId, - email :: Email, - mname :: Maybe Name, + createdBy :: Maybe UserId, + email :: EmailAddress, + name :: Maybe Name, code :: InvitationCode } deriving (Show, Eq, Generic) @@ -49,7 +53,7 @@ recordInstance ''StoredInvitation data StoredInvitationByTeam = MkStoredInvitationByTeam { teamId :: TeamId, - invId :: InvitationId, + invitationId :: InvitationId, code :: InvitationCode -- TODO(mangoiv): maybe we can drop this last element } @@ -60,16 +64,23 @@ recordInstance ''StoredInvitationByTeam data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) - LookupInvitationCodesByEmail :: Email -> InvitationCodeStore m [StoredInvitationByTeam] + LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe (TeamId, InvitationId)) + LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationByTeam] makeSem ''InvitationCodeStore -lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => Email -> Sem r (Maybe StoredInvitation) -lookupInvitationByEmail email = runMaybeT do - MkStoredInvitationByTeam {teamId, invId} <- MaybeT $ lookupSingleInvitationCodeByEmail email - MaybeT $ lookupInvitation teamId invId +-- TODO: account for show/hide? +lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => ShowOrHideInvitationUrl -> EmailAddress -> Sem r (Maybe StoredInvitation) +lookupInvitationByEmail _ email = runMaybeT do + MkStoredInvitationByTeam {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email + MaybeT $ lookupInvitation teamId invitationId -lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => Email -> Sem r (Maybe StoredInvitationByTeam) +lookupInvitationByCode :: (Member InvitationCodeStore r) => ShowOrHideInvitationUrl -> InvitationCode -> Sem r (Maybe StoredInvitation) +lookupInvitationByCode _ code = runMaybeT do + (tid, iid) <- MaybeT $ lookupInvitationInfo code + MaybeT $ lookupInvitation tid iid + +lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => EmailAddress -> Sem r (Maybe StoredInvitationByTeam) lookupSingleInvitationCodeByEmail email = do invs <- lookupInvitationCodesByEmail email case invs of @@ -82,3 +93,16 @@ lookupSingleInvitationCodeByEmail email = do . Log.field "email" (show email) pure Nothing + +invitationFromStored :: StoredInvitation -> Public.Invitation +invitationFromStored MkStoredInvitation {..} = + Public.Invitation + { team = teamId, + role = fromMaybe defaultRole role, + invitationId = invitationId, + createdAt = createdAt, + createdBy = createdBy, + inviteeEmail = email, + inviteeName = name, + inviteeUrl = Nothing -- TODO: Huh? + } diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 74833d0eec1..29b12d438a0 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -15,11 +15,21 @@ interpretInvitationCodeStoreToCassandra casClient = runEmbedded (runClient casClient) . \case LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email + LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code -lookupInvitationCodesByEmailImpl :: Email -> Client [StoredInvitationByTeam] +lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe (TeamId, InvitationId)) +lookupInvitationInfoImpl code = retry x1 (query1 cql (params LocalQuorum (Identity code))) + where + cql :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) + cql = + [sql| + SELECT team, id FROM team_invitation_info WHERE code = ? + |] + +lookupInvitationCodesByEmailImpl :: EmailAddress -> Client [StoredInvitationByTeam] lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (params LocalQuorum (Identity email))) where - cql :: PrepQuery R (Identity Email) (TeamId, InvitationId, InvitationCode) + cql :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) cql = [sql| SELECT team, invitation, code FROM team_invitation_email WHERE email = ? diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 60646a00888..c3924a8266d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -60,7 +60,7 @@ data GetBy = MkGetBy -- | get accounds by 'UserId's getByUserIds :: ![UserId], -- | get accounds by 'Email's - getByEmail :: ![Email], + getByEmail :: ![EmailAddress], -- | get accounds by their 'Handle' getByHandle :: ![Handle] } diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index be01bd446fc..eb9471f85b7 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -540,7 +540,7 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByE Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of (PendingInvitation, False, _) -> notValid (PendingInvitation, True, Just email) -> - lookupInvitationByEmail email >>= \case + lookupInvitationByEmail HideInvitationUrl email >>= \case Nothing -> notValid Just _ -> do -- user invited via scim should expire together with its invitation diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 98817530d7a..de55be9311e 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Wire.MockInterpreters.InvitationCodeStore where @@ -13,6 +14,7 @@ import Wire.InvitationCodeStore inMemoryInvitationCodeStoreInterpreter :: forall r. (Member (State (Map (TeamId, InvitationId) StoredInvitation)) r) => InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case LookupInvitation tid iid -> gets (!? (tid, iid)) + LookupInvitationInfo _iid -> todo LookupInvitationCodesByEmail em -> let c MkStoredInvitation {..} | email == em = Just MkStoredInvitationByTeam {..} diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 500510dc9bf..5b61c803233 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -50,7 +50,6 @@ import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team -import Brig.Team.DB (lookupInvitationByEmail) import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -76,7 +75,7 @@ import Data.Time.Clock.System import Imports hiding (head) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Input (Input) +import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () @@ -100,10 +99,11 @@ import Wire.API.User.RichInfo import Wire.API.UserEvent import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.BlockListStore (BlockListStore) -import Wire.DeleteQueue +import Wire.DeleteQueue (DeleteQueue) import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) -import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.InvitationCodeStore import Wire.NotificationSubsystem import Wire.PropertySubsystem import Wire.Rpc @@ -132,6 +132,7 @@ servantSitemap :: Member NotificationSubsystem r, Member UserSubsystem r, Member UserStore r, + Member InvitationCodeStore r, Member UserKeyStore r, Member Rpc r, Member TinyLog r, @@ -190,7 +191,8 @@ accountAPI :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member InvitationCodeStore r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -240,6 +242,7 @@ teamsAPI :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member InvitationCodeStore r, Member (ConnectionStore InternalPaging) r, Member EmailSending r, Member UserSubsystem r @@ -465,6 +468,7 @@ createUserNoVerify :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member InvitationCodeStore r, Member UserKeyStore r, Member (Input (Local ())) r, Member (Input UTCTime) r, @@ -549,9 +553,8 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do -- handler allows up to 4 lists of various user keys, and returns the union of the lookups. -- Empty list is forbidden for backwards compatibility. listActivatedAccountsH :: - ( Member DeleteQueue r, - Member UserKeyStore r, - Member UserStore r + ( Member (Input (Local ())) r, + Member UserSubsystem r ) => Maybe (CommaSeparatedList UserId) -> Maybe (CommaSeparatedList Handle) -> @@ -562,50 +565,19 @@ listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) (maybe [] fromCommaSeparatedList -> emails) - (fromMaybe False -> includePendingInvitations) = do + (fromMaybe False -> include) = do when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") - lift $ do - u1 <- listActivatedAccounts (Left uids) includePendingInvitations - u2 <- listActivatedAccounts (Right handles) includePendingInvitations - u3 <- (\email -> API.lookupAccountsByIdentity email includePendingInvitations) `mapM` emails - pure $ u1 <> u2 <> join u3 - --- FUTUREWORK: this should use UserStore only through UserSubsystem. -listActivatedAccounts :: - (Member DeleteQueue r, Member UserStore r) => - Either [UserId] [Handle] -> - Bool -> - AppT r [UserAccount] -listActivatedAccounts elh includePendingInvitations = do - Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) - case elh of - Left us -> byIds us - Right hs -> do - us <- liftSem $ mapM API.lookupHandle hs - byIds (catMaybes us) - where - byIds :: (Member DeleteQueue r) => [UserId] -> (AppT r) [UserAccount] - byIds uids = wrapClient (API.lookupAccounts uids) >>= filterM accountValid - - accountValid :: (Member DeleteQueue r) => UserAccount -> (AppT r) Bool - accountValid account = case userIdentity . accountUser $ account of - Nothing -> pure False - Just ident -> - case (accountStatus account, includePendingInvitations, emailIdentity ident) of - (PendingInvitation, False, _) -> pure False - (PendingInvitation, True, Just email) -> do - hasInvitation <- isJust <$> wrapClient (lookupInvitationByEmail HideInvitationUrl email) - unless hasInvitation $ do - -- user invited via scim should expire together with its invitation - liftSem $ API.deleteUserNoVerify (userId . accountUser $ account) - pure hasInvitation - (PendingInvitation, True, Nothing) -> - pure True -- cannot happen, user invited via scim always has an email - (Active, _, _) -> pure True - (Suspended, _, _) -> pure True - (Deleted, _, _) -> pure True - (Ephemeral, _, _) -> pure True + lift $ liftSem do + dom <- input + getAccountsBy $ + dom + $> MkGetBy + { includePendingInvitations = include, + getByUserIds = uids, + getByEmail = emails, + getByHandle = handles + } getActivationCode :: EmailAddress -> Handler r GetActivationCodeResp getActivationCode email = do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index dc58cb86e28..606ed55b5bb 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -152,6 +152,7 @@ import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.PropertySubsystem @@ -285,7 +286,8 @@ servantSitemap :: Member EmailSubsystem r, Member EmailSending r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member InvitationCodeStore r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -681,6 +683,7 @@ createAccessToken method luid cid proof = do createUser :: ( Member BlockListStore r, Member GalleyAPIAccess r, + Member InvitationCodeStore r, Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index fd9787edcd3..0cb08c1ed92 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -127,8 +127,6 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Password import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) -import Wire.API.Team.Invitation -import Wire.API.Team.Invitation qualified as Team import Wire.API.Team.Member (legalHoldStatus) import Wire.API.Team.Role import Wire.API.Team.Size @@ -143,6 +141,7 @@ import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess +import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem @@ -244,7 +243,7 @@ createUserSpar new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, role) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -270,7 +269,8 @@ createUser :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member Store.InvitationCodeStore r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -293,7 +293,7 @@ createUser new = do pure (Nothing, Nothing, Just tid) Nothing -> pure (Nothing, Nothing, Nothing) - let mbInv = Team.inInvitation . fst <$> teamInvitation + let mbInv = (.invitationId) . fst <$> teamInvitation mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> wrapClient $ Data.lookupAccount (Id uuid)) let (new', mbHandle) = case mbExistingAccount of @@ -349,10 +349,9 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do - let em = Team.inInviteeEmail inv - acceptTeamInvitation account inv invInfo (mkEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName (Team.inTeam inv) - pure (Just $ CreateUserTeam (Team.inTeam inv) nm) + acceptTeamInvitation account inv invInfo (mkEmailKey inv.email) (EmailIdentity inv.email) + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.teamId + pure (Just $ CreateUserTeam inv.teamId nm) Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of @@ -380,17 +379,18 @@ createUser new = do pure email - findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Store.StoredInvitation, Team.InvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case - Just ii -> do - inv <- lift . wrapClient $ Team.lookupInvitation HideInvitationUrl (Team.iiTeam ii) (Team.iiInvId ii) - case (inv, Team.inInviteeEmail <$> inv) of + Just invitationInfo -> do + -- TODO(elland): rework this + inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.iiTeam invitationInfo.iiInvId + case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - _ <- ensureMemberCanJoin (Team.iiTeam ii) - pure $ Just (invite, ii, Team.iiTeam ii) + _ <- ensureMemberCanJoin invitationInfo.iiTeam + pure $ Just (invite, invitationInfo, invitationInfo.iiTeam) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -409,19 +409,21 @@ createUser new = do acceptTeamInvitation :: UserAccount -> - Team.Invitation -> + Store.StoredInvitation -> Team.InvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () - acceptTeamInvitation account inv ii uk ident = do + acceptTeamInvitation account inv invitationInfo uk ident = do let uid = userId (accountUser account) ok <- lift $ liftSem $ claimKey uk uid unless ok $ throwE RegisterErrorUserKeyExists - let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) - minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid (Team.iiTeam ii) minvmeta + let minvmeta :: Maybe (UserId, UTCTimeMillis) + minvmeta = (,inv.createdAt) <$> inv.createdBy + role :: Role + role = fromMaybe defaultRole inv.role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.iiTeam minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -430,16 +432,16 @@ createUser new = do liftSem $ Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ Team.iiTeam ii) + . field "team" (toByteString $ invitationInfo.iiTeam) . msg (val "Accepting invitation") liftSem $ UserPendingActivationStore.remove uid wrapClient $ do - Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) + Team.deleteInvitation inv.teamId inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing defaultRole unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index ca597c1063a..88cbc80b02a 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -32,6 +32,8 @@ import Polysemy.TinyLog (TinyLog) import Wire.API.Allowlists (AllowlistEmailDomains) import Wire.API.Federation.Client qualified import Wire.API.Federation.Error +import Wire.ActivationCodeStore (ActivationCodeStore) +import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Interpreter import Wire.BlockListStore @@ -50,6 +52,8 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess import Wire.HashPassword +import Wire.InvitationCodeStore (InvitationCodeStore) +import Wire.InvitationCodeStore.Cassandra (interpretInvitationCodeStoreToCassandra) import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException @@ -107,6 +111,8 @@ type BrigCanonicalEffects = SessionStore, PasswordStore, VerificationCodeStore, + ActivationCodeStore, + InvitationCodeStore, PropertyStore, SFT, ConnectionStore InternalPaging, @@ -196,6 +202,8 @@ runBrigToIO e (AppT ma) = do . connectionStoreToCassandra . interpretSFT (e ^. httpManager) . interpretPropertyStoreCassandra (e ^. casClient) + . interpretInvitationCodeStoreToCassandra (e ^. casClient) + . interpretActivationCodeStoreToCassandra (e ^. casClient) . interpretVerificationCodeStoreCassandra (e ^. casClient) . interpretPasswordStore (e ^. casClient) . interpretSessionStoreCassandra (e ^. casClient) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index c208ceb34cd..4f8ac6baca2 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-deprecations #-} module Brig.Team.API ( servantAPI, @@ -80,6 +81,7 @@ import Wire.EmailSending (EmailSending) import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) @@ -90,7 +92,8 @@ servantAPI :: ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, - Member EmailSending r + Member EmailSending r, + Member Store.InvitationCodeStore r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -110,10 +113,14 @@ teamSizePublic uid tid = do teamSize :: TeamId -> (Handler r) TeamSize teamSize t = lift $ TeamSize.teamSize t -getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode +getInvitationCode :: + (Member Store.InvitationCodeStore r) => + TeamId -> + InvitationId -> + (Handler r) FoundInvitationCode getInvitationCode t r = do - code <- lift . wrapClient $ DB.lookupInvitationCode t r - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode) code + inv <- lift . liftSem $ Store.lookupInvitation t r + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode . (.code)) inv data CreateInvitationInviter = CreateInvitationInviter { inviterUid :: UserId, @@ -152,7 +159,7 @@ createInvitation uid tid body = do where loc :: Invitation -> InvitationLocation loc inv = - InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' (inInvitation inv) + InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId createInvitationViaScim :: ( Member BlockListStore r, @@ -220,7 +227,7 @@ createInvitation' :: Public.InvitationRequest -> Handler r (Public.Invitation, Public.InvitationCode) createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do - let email = (inviteeEmail body) + let email = body.inviteeEmail let uke = mkEmailKey email blacklistedEm <- lift $ liftSem $ isBlocked email when blacklistedEm $ @@ -259,40 +266,59 @@ deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] lift $ wrapClient $ DB.deleteInvitation tid iid -listInvitations :: (Member GalleyAPIAccess r) => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList +listInvitations :: + (Member GalleyAPIAccess r) => + UserId -> + TeamId -> + Maybe InvitationId -> + Maybe (Range 1 500 Int32) -> + (Handler r) Public.InvitationList listInvitations uid tid start mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start (fromMaybe (unsafeRange 100) mSize) pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) -getInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) +getInvitation :: + (Member GalleyAPIAccess r, Member Store.InvitationCodeStore r) => + UserId -> + TeamId -> + InvitationId -> + (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - lift $ wrapClient $ DB.lookupInvitation showInvitationUrl tid iid + _showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + (lift . liftSem) (Store.invitationFromStored <$$> Store.lookupInvitation tid iid) -getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation +getInvitationByCode :: + (Member Store.InvitationCodeStore r) => + Public.InvitationCode -> + (Handler r) Public.Invitation getInvitationByCode c = do - inv <- lift . wrapClient $ DB.lookupInvitationByCode HideInvitationUrl c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) pure inv + inv <- lift . liftSem $ Store.lookupInvitationByCode HideInvitationUrl c + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored) inv +-- FIXME(mangoiv): This should not be in terms of store headInvitationByEmail :: EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult -headInvitationByEmail e = do - lift $ - wrapClient $ - DB.lookupInvitationInfoByEmail e <&> \case - DB.InvitationByEmail _ -> Public.InvitationByEmail - DB.InvitationByEmailNotFound -> Public.InvitationByEmailNotFound - DB.InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne +headInvitationByEmail _e = todo + +-- lift $ +-- liftSem $ +-- Store.lookupInvitationInfo e <&> \case +-- InvitationByEmail -> Public.InvitationByEmail +-- InvitationByEmailNotFound -> Public.InvitationByEmailNotFound +-- InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and -- 'getInvitationByEmailH' are almost the same thing. -getInvitationByEmail :: EmailAddress -> (Handler r) Public.Invitation +getInvitationByEmail :: + (Member Store.InvitationCodeStore r, Member TinyLog r) => + EmailAddress -> + (Handler r) Public.Invitation getInvitationByEmail email = do - inv <- lift $ wrapClient $ DB.lookupInvitationByEmail HideInvitationUrl email - maybe (throwStd (notFound "Invitation not found")) pure inv + inv <- lift . liftSem $ Store.lookupInvitationByEmail HideInvitationUrl email + maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored) inv suspendTeam :: ( Member (Embed HttpClientIO) r, diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index e6e19e7609d..c8f80de615f 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -23,13 +21,9 @@ module Brig.Team.DB insertInvitation, deleteInvitation, deleteInvitations, - lookupInvitation, lookupInvitationCode, lookupInvitations, - lookupInvitationByCode, lookupInvitationInfo, - lookupInvitationInfoByEmail, - lookupInvitationByEmail, mkInvitationCode, mkInvitationId, InvitationByEmail (..), @@ -118,35 +112,6 @@ insertInvitation showUrl iid t role (toUTCTimeMillis -> now) minviter email invi cqlInvitationByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () cqlInvitationByEmail = "INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ?" -lookupInvitation :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - InvitationId -> - m (Maybe Invitation) -lookupInvitation showUrl t r = do - inv <- retry x1 (query1 cqlInvitation (params LocalQuorum (t, r))) - traverse (toInvitation showUrl) inv - where - cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlInvitation = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ?" - -lookupInvitationByCode :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - InvitationCode -> - m (Maybe Invitation) -lookupInvitationByCode showUrl i = - lookupInvitationInfo i >>= \case - Just InvitationInfo {..} -> lookupInvitation showUrl iiTeam iiInvId - _ -> pure Nothing - lookupInvitationCode :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe InvitationCode) lookupInvitationCode t r = fmap runIdentity @@ -230,37 +195,6 @@ lookupInvitationInfo ic@(InvitationCode c) cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) cqlInvitationInfo = "SELECT team, id FROM team_invitation_info WHERE code = ?" -lookupInvitationByEmail :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - EmailAddress -> - m (Maybe Invitation) -lookupInvitationByEmail showUrl e = - lookupInvitationInfoByEmail e >>= \case - InvitationByEmail InvitationInfo {..} -> lookupInvitation showUrl iiTeam iiInvId - _ -> pure Nothing - -lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => EmailAddress -> m InvitationByEmail -lookupInvitationInfoByEmail email = do - res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) - case res of - [] -> pure InvitationByEmailNotFound - [(tid, invId, code)] -> - -- one invite pending - pure $ InvitationByEmail (InvitationInfo code tid invId) - _ : _ : _ -> do - -- edge case: more than one pending invite from different teams - Log.info $ - Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") - Log.~~ Log.field "email" (show email) - pure InvitationByEmailMoreThanOne - where - cqlInvitationEmail :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) - cqlInvitationEmail = "SELECT team, invitation, code FROM team_invitation_email WHERE email = ?" - countInvitations :: (MonadClient m) => TeamId -> m Int64 countInvitations t = maybe 0 runIdentity diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 769efcd6a00..0b2e55e8d17 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -168,8 +168,8 @@ testUpdateEvents brig cannon = do inviteeEmail <- randomEmail -- invite and register Bob let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid alice invite - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid alice invite + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp2 <- post ( brig @@ -204,34 +204,34 @@ testInvitationEmail brig = do const 201 === statusCode inv <- responseJsonError res let actualHeader = getHeader "Location" res - let expectedHeader = "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' (inInvitation inv) + let expectedHeader = "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId liftIO $ do - Just inviter @=? inCreatedBy inv - tid @=? inTeam inv + Just inviter @=? inv.createdBy + tid @=? inv.team assertInvitationResponseInvariants invite inv - (isNothing . inInviteeUrl) inv @? "No invitation url expected" + (isNothing . (.inviteeUrl)) inv @? "No invitation url expected" actualHeader @?= Just expectedHeader assertInvitationResponseInvariants :: InvitationRequest -> Invitation -> Assertion assertInvitationResponseInvariants invReq inv = do - inviteeName invReq @=? inInviteeName inv - inviteeEmail invReq @=? inInviteeEmail inv + invReq.inviteeName @=? inv.inviteeName + invReq.inviteeEmail @=? inv.inviteeEmail testGetInvitation :: Brig -> Http () testGetInvitation brig = do (inviter, tid) <- createUserWithTeam brig invite <- stdInvitationRequest <$> randomEmail inv1 <- responseJsonError =<< postInvitation brig tid inviter invite Http () testDeleteInvitation brig = do (inviter, tid) <- createUserWithTeam brig invite <- stdInvitationRequest <$> randomEmail - iid <- inInvitation <$> (responseJsonError =<< postInvitation brig tid inviter invite (toStrict . toByteString)) getQueryParam "team" resp @=? (pure . encodeUtf8 . idToText) tid getQueryParam :: ByteString -> ResponseLBS -> Maybe ByteString getQueryParam name r = do - inv <- (eitherToMaybe . responseJsonEither) r - url <- inInviteeUrl inv + inv :: Invitation <- (eitherToMaybe . responseJsonEither) r + url <- inv.inviteeUrl (lookup name . queryPairs . uriQuery) url -- | Mock the feature API because exposeInvitationURLsToTeamAdmin depends on @@ -309,13 +309,13 @@ testNoInvitationUrl opts brig = do Http () testInvitationEmailLookup brig = do @@ -379,7 +379,7 @@ testInvitationTooManyPending opts brig (TeamSizeLimit limit) = do registerInvite :: Brig -> TeamId -> Invitation -> EmailAddress -> Http UserId registerInvite brig tid inv invemail = do - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp <- post ( brig @@ -483,9 +483,9 @@ createAndVerifyInvitation' replacementBrigApp acceptFn invite brig galley = do ) => m' (Maybe (UserId, UTCTimeMillis), Invitation, UserId, ResponseLBS) invitationHandshake = do - inv <- responseJsonError =<< postInvitation brig tid inviter invite - let invmeta = Just (inviter, inCreatedAt inv) - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite + let invmeta = Just (inviter, inv.createdAt) + Just inviteeCode <- getInvitationCode brig tid inv.invitationId Just invitation <- getInvitationInfo brig inviteeCode rsp2 <- post @@ -613,9 +613,8 @@ testInvitationCodeExists brig = do (uid, tid) <- createUserWithTeam brig let invite email = stdInvitationRequest email email <- randomEmail - rsp <- postInvitation brig tid uid (invite email) responseJsonMaybe rsp - Just invCode <- getInvitationCode brig tid invId + inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid (invite email) responseJsonError r if more - then (invs :) <$> getPages (count + step) (fmap inInvitation . listToMaybe . reverse $ invs) step + then -- TODO: improve + (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step else pure [invs] let checkSize :: (HasCallStack) => Int -> [Int] -> Http () checkSize pageSize expectedSizes = @@ -740,13 +740,13 @@ testInvitationPaging opts brig = do mapM_ validateInv $ concat invss validateInv :: Invitation -> Assertion validateInv inv = do - assertEqual "tid" tid (inTeam inv) - assertBool "email" (inInviteeEmail inv `elem` emails) + assertEqual "tid" tid (inv.team) + assertBool "email" (inv.inviteeEmail `elem` emails) -- (the output list is not ordered chronologically and emails are unique, so we just -- check whether the email is one of the valid ones.) - assertBool "timestamp" (inCreatedAt inv > before && inCreatedAt inv < after1ms) - assertEqual "uid" (Just uid) (inCreatedBy inv) - -- not checked: @inInvitation inv :: InvitationId@ + assertBool "timestamp" (inv.createdAt > before && inv.createdAt < after1ms) + assertEqual "uid" (Just uid) (inv.createdBy) + -- not checked: @invitation inv :: InvitationId@ checkSize 2 [2, 2, 1] checkSize total [total] @@ -758,7 +758,7 @@ testInvitationInfo brig = do (uid, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email inv <- responseJsonError =<< postInvitation brig tid uid invite - Just invCode <- getInvitationCode brig tid (inInvitation inv) + Just invCode <- getInvitationCode brig tid inv.invitationId Just invitation <- getInvitationInfo brig invCode liftIO $ assertEqual "Invitations differ" inv invitation @@ -774,10 +774,10 @@ testInvitationInfoExpired brig timeout = do email <- randomEmail (uid, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email - inv <- responseJsonError =<< postInvitation brig tid uid invite + inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid invite -- Note: This value must be larger than the option passed as `team-invitation-timeout` - awaitExpiry (round timeout + 5) tid (inInvitation inv) - getCode tid (inInvitation inv) !!! const 400 === statusCode + awaitExpiry (round timeout + 5) tid inv.invitationId + getCode tid inv.invitationId !!! const 400 === statusCode headInvitationByEmail brig email 404 where getCode t i = @@ -801,8 +801,8 @@ testSuspendTeam brig = do (inviter, tid) <- createUserWithTeam brig -- invite and register invitee let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid inviter invite - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp2 <- post ( brig @@ -815,8 +815,8 @@ testSuspendTeam brig = do -- invite invitee2 (don't register) let invite2 = stdInvitationRequest inviteeEmail2 - inv2 <- responseJsonError =<< postInvitation brig tid inviter invite2 - Just _ <- getInvitationCode brig tid (inInvitation inv2) + inv2 :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite2 + Just _ <- getInvitationCode brig tid inv2.invitationId -- suspend team suspendTeam brig tid !!! const 200 === statusCode -- login fails @@ -826,7 +826,7 @@ testSuspendTeam brig = do -- check status chkStatus brig inviter Suspended chkStatus brig invitee Suspended - assertNoInvitationCode brig tid (inInvitation inv2) + assertNoInvitationCode brig tid inv2.invitationId -- unsuspend unsuspendTeam brig tid !!! const 200 === statusCode chkStatus brig inviter Active diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 097616cdb57..defa0f8e5b3 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -90,11 +90,11 @@ createPopulatedBindingTeamWithNames brig names = do invitees <- forM names $ \name -> do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail - inv <- + inv :: Invitation <- responseJsonError =<< postInvitation brig tid (userId inviter) invite Brig -> ScimToken -> TeamId -> Scim.User.User SparTag createUserStep spar' brig' tok tid scimUser email = do scimStoredUser <- createUser spar' tok scimUser inv <- getInvitationByEmail brig' email - Just inviteeCode <- getInvitationCode brig' tid (inInvitation inv) + Just inviteeCode <- getInvitationCode brig' tid inv.invitationId pure (scimStoredUser, inv, inviteeCode) assertUserExist :: (HasCallStack) => String -> ClientState -> UserId -> Bool -> HttpT IO () diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 0783fce56e7..2765947845d 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -426,7 +426,7 @@ addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 inviteeId = User.userId invitee - let invmeta = Just (inviter, inCreatedAt inv) + let invmeta = Just (inviter, inv.createdAt) mem <- getTeamMember inviter tid inviteeId liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2 @@ -440,7 +440,7 @@ addUserToTeamWithRole' role inviter tid = do let invite = InvitationRequest Nothing role Nothing inviteeEmail invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse - inviteeCode <- getInvitationCode tid (inInvitation inv) + inviteeCode <- getInvitationCode tid inv.invitationId r <- post ( brig diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 57184a319d3..e8014b905c6 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -623,7 +623,7 @@ testCreateUserNoIdPWithRole brig tid owner tok role = do -- user follows invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True -- check for correct role do @@ -681,7 +681,7 @@ testCreateUserNoIdP = do -- user should be able to follow old team invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True call $ headInvitation404 brig email @@ -1129,7 +1129,7 @@ testCreateUserTimeout = do scimStoredUser <- aFewTimesRecover (createUser tok scimUser) inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId pure (scimStoredUser, inv, inviteeCode) searchUser :: (HasCallStack) => Spar.Types.ScimToken -> Scim.User.User tag -> EmailAddress -> Bool -> TestSpar () @@ -1796,8 +1796,8 @@ lookupByValidExternalId tid = registerUser :: BrigReq -> TeamId -> EmailAddress -> TestSpar () registerUser brig tid email = do let r = call $ get (brig . path "/i/teams/invitations/by-email" . queryItem "email" (toByteString' email)) - inv <- responseJsonError =<< r maybeToList mUpdatedRole}) @@ -2082,7 +2082,7 @@ createScimUserWithRole brig tid owner tok initialRole = do -- user follows invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True checkTeamMembersRole tid owner userid initialRole pure userid @@ -2203,7 +2203,7 @@ specDeleteUser = do do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email (Name "Alice") inviteeCode True call $ headInvitation404 brig email @@ -2315,7 +2315,7 @@ testDeletedUsersFreeExternalIdNoIdp = do -- accept invitation do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True call $ headInvitation404 brig email diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index f6affbfa514..4d2aba3af10 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -398,8 +398,8 @@ inviteAndRegisterUser :: m User inviteAndRegisterUser brig u tid inviteeEmail = do let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation tid u invite - Just inviteeCode <- getInvitationCode tid (TeamInvitation.inInvitation inv) + inv :: TeamInvitation.Invitation <- responseJsonError =<< postInvitation tid u invite + Just inviteeCode <- getInvitationCode tid inv.invitationId rspInvitee <- post ( brig diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs index ba5ff5c7b49..0e533484b96 100644 --- a/tools/stern/test/integration/Util.hs +++ b/tools/stern/test/integration/Util.hs @@ -139,7 +139,7 @@ addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 inviteeId = User.userId invitee - let invmeta = Just (inviter, inCreatedAt inv) + let invmeta = Just (inviter, inv.createdAt) mem <- getTeamMember inviter tid inviteeId liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2 @@ -153,7 +153,7 @@ addUserToTeamWithRole' role inviter tid = do let invite = InvitationRequest Nothing role Nothing email invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse - inviteeCode <- getInvitationCode tid (inInvitation inv) + inviteeCode <- getInvitationCode tid inv.invitationId r <- post ( brig From 136418a3747c55945c5ba6c4cd3785fc790ed14c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 14:31:30 +0200 Subject: [PATCH 05/96] Typo --- libs/cassandra-util/src/Cassandra/QQ.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/cassandra-util/src/Cassandra/QQ.hs b/libs/cassandra-util/src/Cassandra/QQ.hs index b37b4a34740..c15df3f3dca 100644 --- a/libs/cassandra-util/src/Cassandra/QQ.hs +++ b/libs/cassandra-util/src/Cassandra/QQ.hs @@ -7,7 +7,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) -- | a simple quasi quoter to allow for tree-sitter syntax highlight injection. --- This uses the name sql because that is known to tree-sitter, in contras to the name cql +-- This uses the name sql because that is known to tree-sitter, unlike cql sql :: QuasiQuoter sql = QuasiQuoter From 2027fed7e9fe4c9d281810c5be201f3519c8d826 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 14:32:14 +0200 Subject: [PATCH 06/96] Fixed overcorrection. --- libs/hscim/test/Test/Schema/UserSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 9971f339471..8dcaa9d50ed 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -98,7 +98,7 @@ spec = do ("preferredLanguage", toJSON @Text mempty), ("locale", toJSON @Text mempty), ("password", toJSON @Text mempty), - ("emails", toJSON @[EmailAddress] mempty), + ("emails", toJSON @[Email] mempty), ("phoneNumbers", toJSON @[Phone] mempty), ("ims", toJSON @[IM] mempty), ("photos", toJSON @[Photo] mempty), From 28f5665db8bae97b3327f5216bb0f386a516c9ea Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 14:41:49 +0200 Subject: [PATCH 07/96] Cleaning. --- libs/wire-subsystems/default.nix | 2 -- libs/wire-subsystems/src/Wire/StoredUser.hs | 1 - libs/wire-subsystems/test/unit/Wire/MiniBackend.hs | 13 +++++++++---- .../Wire/MockInterpreters/InvitationCodeStore.hs | 2 +- libs/wire-subsystems/wire-subsystems.cabal | 1 - services/brig/src/Brig/Team/API.hs | 2 +- 6 files changed, 11 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index c147bdfe1fc..080a271d46e 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -24,7 +24,6 @@ , exceptions , extended , extra -, generics-sop , gitignoreSource , gundeck-types , HaskellNet @@ -162,7 +161,6 @@ mkDerivation { data-default errors extended - generics-sop gundeck-types hspec imports diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs index 2d4c4581de5..38bb072401d 100644 --- a/libs/wire-subsystems/src/Wire/StoredUser.hs +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} module Wire.StoredUser where diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 88b3a128338..e180ccda18c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} module Wire.MiniBackend @@ -36,7 +35,6 @@ import Data.Qualified import Data.Time import Data.Type.Equality import GHC.Generics -import Generics.SOP qualified as SOP import Imports import Polysemy import Polysemy.Error @@ -140,10 +138,17 @@ data MiniBackend = MkMiniBackend invitations :: Map (TeamId, InvitationId) StoredInvitation } deriving stock (Eq, Show, Generic) - deriving anyclass (SOP.Generic) instance Default MiniBackend where - def = SOP.productTypeTo $ SOP.hcpure (Proxy @Monoid) mempty + def = + MkMiniBackend + { users = mempty, + userKeys = mempty, + passwordResetCodes = mempty, + blockList = mempty, + activationCodes = mempty, + invitations = mempty + } -- | represents an entire federated, stateful world of backends newtype MiniFederation = MkMiniFederation diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index de55be9311e..3e9dc46742a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wwarn #-} module Wire.MockInterpreters.InvitationCodeStore where diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 5cb29061a08..10454e3311a 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -247,7 +247,6 @@ test-suite wire-subsystems-tests , data-default , errors , extended - , generics-sop , gundeck-types , hspec , imports diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 4f8ac6baca2..59119e91d03 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -14,7 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wwarn #-} module Brig.Team.API ( servantAPI, From 81eb543db300442814b30c25b69d43add8c4e13c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 15:06:28 +0200 Subject: [PATCH 08/96] Clean getFields. --- libs/wire-api/src/Wire/API/Team/Invitation.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index b785ad7fb21..e5c07ab7a41 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -70,11 +70,11 @@ instance ToSchema InvitationRequest where InvitationRequest <$> locale .= optFieldWithDocModifier "locale" (description ?~ "Locale to use for the invitation.") (maybeWithDefault A.Null schema) - <*> (getField @"role") + <*> (.role) .= optFieldWithDocModifier "role" (description ?~ "Role of the invitee (invited user).") (maybeWithDefault A.Null schema) - <*> (getField @"inviteeName") + <*> (.inviteeName) .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters).") (maybeWithDefault A.Null schema) - <*> (getField @"inviteeEmail") + <*> (.inviteeEmail) .= fieldWithDocModifier "email" (description ?~ "Email of the invitee.") schema -------------------------------------------------------------------------------- @@ -102,20 +102,20 @@ instance ToSchema Invitation where "Invitation" (description ?~ "An invitation to join a team on Wire") $ Invitation - <$> (getField @"team") + <$> (.team) .= fieldWithDocModifier "team" (description ?~ "Team ID of the inviting team") schema - <*> (getField @"role") + <*> (.role) -- clients, when leaving "role" empty, can leave the default role choice to us .= (fromMaybe defaultRole <$> optFieldWithDocModifier "role" (description ?~ "Role of the invited user") schema) - <*> (getField @"invitationId") + <*> (.invitationId) .= fieldWithDocModifier "id" (description ?~ "UUID used to refer the invitation") schema - <*> (getField @"createdAt") + <*> (.createdAt) .= fieldWithDocModifier "created_at" (description ?~ "Timestamp of invitation creation") schema - <*> (getField @"createdBy") + <*> (.createdBy) .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user") (maybeWithDefault A.Null schema) - <*> (getField @"inviteeEmail") + <*> (.inviteeEmail) .= fieldWithDocModifier "email" (description ?~ "Email of the invitee") schema - <*> (getField @"inviteeName") + <*> (.inviteeName) .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters)") (maybeWithDefault A.Null schema) <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inviteeUrl) .= optFieldWithDocModifier "url" (description ?~ "URL of the invitation link to be sent to the invitee") (maybeWithDefault A.Null urlSchema) From 0eb772e208d256f10876b048146166724ef5344d Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 16:04:04 +0200 Subject: [PATCH 09/96] Moved invitation info to Store --- .../src/Wire/InvitationCodeStore.hs | 31 +++++++++++++------ .../src/Wire/InvitationCodeStore/Cassandra.hs | 28 ++++++++++++++--- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- services/brig/src/Brig/API/User.hs | 25 +++++++++------ services/brig/src/Brig/Team/API.hs | 24 +++++++------- services/brig/src/Brig/Team/DB.hs | 26 ---------------- 6 files changed, 75 insertions(+), 61 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index e60691d6817..4de936b8aa9 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -33,7 +33,6 @@ import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User (EmailAddress, InvitationCode, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl) import Wire.Sem.Logger qualified as Log data StoredInvitation = MkStoredInvitation @@ -62,23 +61,37 @@ data StoredInvitationByTeam = MkStoredInvitationByTeam recordInstance ''StoredInvitationByTeam +data InvitationByEmail + = InvitationByEmail InvitationInfo + | InvitationByEmailNotFound + | InvitationByEmailMoreThanOne + +data InvitationInfo = InvitationInfo + { code :: InvitationCode, + team :: TeamId, + invitationId :: InvitationId + } + deriving (Eq, Show, Generic) + +recordInstance ''InvitationInfo + data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) - LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe (TeamId, InvitationId)) + LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe InvitationInfo) + LookupInvitationInfoByEmail :: EmailAddress -> InvitationCodeStore m InvitationByEmail LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationByTeam] makeSem ''InvitationCodeStore --- TODO: account for show/hide? -lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => ShowOrHideInvitationUrl -> EmailAddress -> Sem r (Maybe StoredInvitation) -lookupInvitationByEmail _ email = runMaybeT do +lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> Sem r (Maybe StoredInvitation) +lookupInvitationByEmail email = runMaybeT do MkStoredInvitationByTeam {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email MaybeT $ lookupInvitation teamId invitationId -lookupInvitationByCode :: (Member InvitationCodeStore r) => ShowOrHideInvitationUrl -> InvitationCode -> Sem r (Maybe StoredInvitation) -lookupInvitationByCode _ code = runMaybeT do - (tid, iid) <- MaybeT $ lookupInvitationInfo code - MaybeT $ lookupInvitation tid iid +lookupInvitationByCode :: (Member InvitationCodeStore r) => InvitationCode -> Sem r (Maybe StoredInvitation) +lookupInvitationByCode code = runMaybeT do + info <- MaybeT $ lookupInvitationInfo code + MaybeT $ lookupInvitation info.team info.invitationId lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => EmailAddress -> Sem r (Maybe StoredInvitationByTeam) lookupSingleInvitationCodeByEmail email = do diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 29b12d438a0..719ca1bc3b9 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -15,15 +15,17 @@ interpretInvitationCodeStoreToCassandra casClient = runEmbedded (runClient casClient) . \case LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email + LookupInvitationInfoByEmail email -> embed $ lookupInvitationInfoByEmailImp email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code -lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe (TeamId, InvitationId)) -lookupInvitationInfoImpl code = retry x1 (query1 cql (params LocalQuorum (Identity code))) +lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe InvitationInfo) +lookupInvitationInfoImpl code = + fmap asRecord <$> retry x1 (query1 cql (params LocalQuorum (Identity code))) where - cql :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) + cql :: PrepQuery R (Identity InvitationCode) (TupleType InvitationInfo) cql = [sql| - SELECT team, id FROM team_invitation_info WHERE code = ? + SELECT code, team, id FROM team_invitation_info WHERE code = ? |] lookupInvitationCodesByEmailImpl :: EmailAddress -> Client [StoredInvitationByTeam] @@ -45,3 +47,21 @@ lookupInvitationImpl tid iid = [sql| SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? |] + +lookupInvitationInfoByEmailImp :: EmailAddress -> Client InvitationByEmail +lookupInvitationInfoByEmailImp email = do + res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) + case res of + [] -> pure InvitationByEmailNotFound + [(tid, invId, code)] -> + -- one invite pending + pure $ InvitationByEmail (InvitationInfo code tid invId) + _ : _ : _ -> do + -- TODO: log the edge case: more than one pending invite from different teams + -- Log.info $ + -- Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + -- Log.~~ Log.field "email" (show email) + pure InvitationByEmailMoreThanOne + where + cqlInvitationEmail :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) + cqlInvitationEmail = "SELECT team, invitation, code FROM team_invitation_email WHERE email = ?" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index eb9471f85b7..be01bd446fc 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -540,7 +540,7 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByE Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of (PendingInvitation, False, _) -> notValid (PendingInvitation, True, Just email) -> - lookupInvitationByEmail HideInvitationUrl email >>= \case + lookupInvitationByEmail email >>= \case Nothing -> notValid Just _ -> do -- user invited via scim should expire together with its invitation diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 0cb08c1ed92..a1ea3c01a6d 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -379,18 +379,25 @@ createUser new = do pure email - findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Store.StoredInvitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: + Maybe EmailKey -> + InvitationCode -> + ExceptT + RegisterError + (AppT r) + ( Maybe + (Store.StoredInvitation, Store.InvitationInfo, TeamId) + ) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = - lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case + lift (liftSem $ Store.lookupInvitationInfo c) >>= \case Just invitationInfo -> do - -- TODO(elland): rework this - inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.iiTeam invitationInfo.iiInvId + inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.team invitationInfo.invitationId case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - _ <- ensureMemberCanJoin invitationInfo.iiTeam - pure $ Just (invite, invitationInfo, invitationInfo.iiTeam) + ensureMemberCanJoin invitationInfo.team + pure $ Just (invite, invitationInfo, invitationInfo.team) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -410,7 +417,7 @@ createUser new = do acceptTeamInvitation :: UserAccount -> Store.StoredInvitation -> - Team.InvitationInfo -> + Store.InvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () @@ -423,7 +430,7 @@ createUser new = do minvmeta = (,inv.createdAt) <$> inv.createdBy role :: Role role = fromMaybe defaultRole inv.role - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.iiTeam minvmeta role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.team minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -432,7 +439,7 @@ createUser new = do liftSem $ Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ invitationInfo.iiTeam) + . field "team" (toByteString $ invitationInfo.team) . msg (val "Accepting invitation") liftSem $ UserPendingActivationStore.remove uid wrapClient $ do diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 59119e91d03..a4e3ac70e13 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -79,8 +79,9 @@ import Wire.API.User qualified as Public import Wire.BlockListStore import Wire.EmailSending (EmailSending) import Wire.Error -import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) +import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore (InvitationCodeStore) import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency @@ -295,19 +296,18 @@ getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation getInvitationByCode c = do - inv <- lift . liftSem $ Store.lookupInvitationByCode HideInvitationUrl c + inv <- lift . liftSem $ Store.lookupInvitationByCode c maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored) inv -- FIXME(mangoiv): This should not be in terms of store -headInvitationByEmail :: EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult -headInvitationByEmail _e = todo - --- lift $ --- liftSem $ --- Store.lookupInvitationInfo e <&> \case --- InvitationByEmail -> Public.InvitationByEmail --- InvitationByEmailNotFound -> Public.InvitationByEmailNotFound --- InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne +headInvitationByEmail :: (Member InvitationCodeStore r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult +headInvitationByEmail e = + lift $ + liftSem $ + Store.lookupInvitationInfoByEmail e <&> \case + Store.InvitationByEmail _ -> Public.InvitationByEmail + Store.InvitationByEmailNotFound -> Public.InvitationByEmailNotFound + Store.InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and @@ -317,7 +317,7 @@ getInvitationByEmail :: EmailAddress -> (Handler r) Public.Invitation getInvitationByEmail email = do - inv <- lift . liftSem $ Store.lookupInvitationByEmail HideInvitationUrl email + inv <- lift . liftSem $ Store.lookupInvitationByEmail email maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored) inv suspendTeam :: diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index c8f80de615f..361f9eeeae5 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -23,11 +23,8 @@ module Brig.Team.DB deleteInvitations, lookupInvitationCode, lookupInvitations, - lookupInvitationInfo, mkInvitationCode, mkInvitationId, - InvitationByEmail (..), - InvitationInfo (..), ) where @@ -64,18 +61,6 @@ mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 mkInvitationId :: IO InvitationId mkInvitationId = Id <$> nextRandom -data InvitationInfo = InvitationInfo - { iiCode :: InvitationCode, - iiTeam :: TeamId, - iiInvId :: InvitationId - } - deriving (Eq, Show) - -data InvitationByEmail - = InvitationByEmail InvitationInfo - | InvitationByEmailNotFound - | InvitationByEmailMoreThanOne - insertInvitation :: ( Log.MonadLogger m, MonadReader Env m, @@ -184,17 +169,6 @@ deleteInvitations t = cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" -lookupInvitationInfo :: (MonadClient m) => InvitationCode -> m (Maybe InvitationInfo) -lookupInvitationInfo ic@(InvitationCode c) - | c == mempty = pure Nothing - | otherwise = - fmap (toInvitationInfo ic) - <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) - where - toInvitationInfo i (t, r) = InvitationInfo i t r - cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) - cqlInvitationInfo = "SELECT team, id FROM team_invitation_info WHERE code = ?" - countInvitations :: (MonadClient m) => TeamId -> m Int64 countInvitations t = maybe 0 runIdentity From fdad7acf9f038ac4f450386941d61dc9d097710e Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 22 Aug 2024 16:28:14 +0200 Subject: [PATCH 10/96] In-memory store for invitation info. --- libs/wire-api/src/Wire/API/User.hs | 2 +- libs/wire-subsystems/test/unit/Wire/MiniBackend.hs | 9 +++++++++ .../unit/Wire/MockInterpreters/InvitationCodeStore.hs | 10 ++++++++-- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 454902c9699..911c93e857e 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -1225,7 +1225,7 @@ maybeNewUserOriginFromComponents hasPassword hasSSO (invcode, teamcode, team, te -- | A random invitation code for use during registration newtype InvitationCode = InvitationCode {fromInvitationCode :: AsciiBase64Url} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving newtype (ToSchema, ToByteString, FromByteString, Arbitrary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema InvitationCode diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index e180ccda18c..a3534c68efb 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -105,6 +105,7 @@ type MiniBackendEffects = GalleyAPIAccess, InvitationCodeStore, State (Map (TeamId, InvitationId) StoredInvitation), + State (Map InvitationCode InvitationInfo), ActivationCodeStore, State (Map EmailKey (Maybe UserId, ActivationCode)), BlockListStore, @@ -135,6 +136,7 @@ data MiniBackend = MkMiniBackend passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity), blockList :: [EmailKey], activationCodes :: Map EmailKey (Maybe UserId, ActivationCode), + invitationInfos :: Map InvitationCode InvitationInfo, invitations :: Map (TeamId, InvitationId) StoredInvitation } deriving stock (Eq, Show, Generic) @@ -147,6 +149,7 @@ instance Default MiniBackend where passwordResetCodes = mempty, blockList = mempty, activationCodes = mempty, + invitationInfos = mempty, invitations = mempty } @@ -369,11 +372,17 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . inMemoryBlockListStoreInterpreter . liftActivationCodeStoreState . inMemoryActivationCodeStoreInterpreter + . liftInvitationInfoStoreState . liftInvitationCodeStoreState . inMemoryInvitationCodeStoreInterpreter . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg +liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode InvitationInfo) : r) a -> Sem r a +liftInvitationInfoStoreState = interpret \case + Polysemy.State.Get -> gets (.invitationInfos) + Put newAcs -> modify $ \b -> b {invitationInfos = newAcs} + liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a liftActivationCodeStoreState = interpret \case Polysemy.State.Get -> gets (.activationCodes) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 3e9dc46742a..d40e1241a87 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -8,13 +8,19 @@ import Data.Map (elems, (!?)) import Imports import Polysemy import Polysemy.State (State, get, gets) +import Wire.API.User (InvitationCode) import Wire.InvitationCodeStore -- TODO(mangoiv): I start to feel like we want a proper (in memory) DB here -inMemoryInvitationCodeStoreInterpreter :: forall r. (Member (State (Map (TeamId, InvitationId) StoredInvitation)) r) => InterpreterFor InvitationCodeStore r +inMemoryInvitationCodeStoreInterpreter :: + forall r. + ( Member (State (Map (TeamId, InvitationId) StoredInvitation)) r, + Member (State (Map (InvitationCode) InvitationInfo)) r + ) => + InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case LookupInvitation tid iid -> gets (!? (tid, iid)) - LookupInvitationInfo _iid -> todo + LookupInvitationInfo iid -> gets (!? iid) LookupInvitationCodesByEmail em -> let c MkStoredInvitation {..} | email == em = Just MkStoredInvitationByTeam {..} From 96c0b01c025b39c12b3de785a553d1b4412d89c2 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 26 Aug 2024 10:35:41 +0200 Subject: [PATCH 11/96] Account for inviteeUrl visibility. --- .../src/Wire/InvitationCodeStore.hs | 7 ++++--- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/Team/API.hs | 17 +++++++++++------ services/brig/src/Brig/Team/DB.hs | 1 + 4 files changed, 17 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 4de936b8aa9..09f4c0579aa 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -28,6 +28,7 @@ import Imports import Polysemy import Polysemy.TinyLog (TinyLog) import System.Logger.Message qualified as Log +import URI.ByteString import Wire.API.Team.Invitation (Invitation (inviteeEmail)) import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Role (Role, defaultRole) @@ -107,8 +108,8 @@ lookupSingleInvitationCodeByEmail email = do pure Nothing -invitationFromStored :: StoredInvitation -> Public.Invitation -invitationFromStored MkStoredInvitation {..} = +invitationFromStored :: Maybe (URIRef Absolute) -> StoredInvitation -> Public.Invitation +invitationFromStored maybeUrl MkStoredInvitation {..} = Public.Invitation { team = teamId, role = fromMaybe defaultRole role, @@ -117,5 +118,5 @@ invitationFromStored MkStoredInvitation {..} = createdBy = createdBy, inviteeEmail = email, inviteeName = name, - inviteeUrl = Nothing -- TODO: Huh? + inviteeUrl = maybeUrl } diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 10454e3311a..d74d94201c4 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -189,6 +189,7 @@ library , types-common , unliftio , unordered-containers + , uri-bytestring , uuid , wai-utilities , wire-api diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index a4e3ac70e13..8cf171f5fe7 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -81,7 +81,7 @@ import Wire.EmailSending (EmailSending) import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.InvitationCodeStore (InvitationCodeStore) +import Wire.InvitationCodeStore import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency @@ -287,9 +287,14 @@ getInvitation :: InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do - ensurePermissions uid tid [AddTeamMember] - _showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - (lift . liftSem) (Store.invitationFromStored <$$> Store.lookupInvitation tid iid) + invitationM <- lift . liftSem $ Store.lookupInvitation tid iid + case invitationM of + Nothing -> pure Nothing + Just invitation -> do + ensurePermissions uid tid [AddTeamMember] + showInvitationUrl <- lift . liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + maybeUrl <- DB.mkInviteUrl showInvitationUrl tid invitation.code + pure $ Just (Store.invitationFromStored maybeUrl invitation) getInvitationByCode :: (Member Store.InvitationCodeStore r) => @@ -297,7 +302,7 @@ getInvitationByCode :: (Handler r) Public.Invitation getInvitationByCode c = do inv <- lift . liftSem $ Store.lookupInvitationByCode c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored) inv + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv -- FIXME(mangoiv): This should not be in terms of store headInvitationByEmail :: (Member InvitationCodeStore r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult @@ -318,7 +323,7 @@ getInvitationByEmail :: (Handler r) Public.Invitation getInvitationByEmail email = do inv <- lift . liftSem $ Store.lookupInvitationByEmail email - maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored) inv + maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored Nothing) inv suspendTeam :: ( Member (Embed HttpClientIO) r, diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 361f9eeeae5..469419973e6 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -17,6 +17,7 @@ module Brig.Team.DB ( module T, + mkInviteUrl, countInvitations, insertInvitation, deleteInvitation, From 64660b319e1905c72579110060f2ad33697aef93 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 26 Aug 2024 11:01:03 +0200 Subject: [PATCH 12/96] Cleaned extensions. --- libs/wire-api/src/Wire/API/Team/Invitation.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index e5c07ab7a41..8fa3bde91c0 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} -- This file is part of the Wire Server implementation. -- @@ -38,7 +37,6 @@ import Data.OpenApi qualified as S import Data.SOP import Data.Schema import Data.Text.Encoding qualified as TE -import GHC.Records import Imports import Servant (FromHttpApiData (..), ToHttpApiData (..)) import URI.ByteString From 402056872b2db7a8a586899828500cf4804c6518 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 26 Aug 2024 11:05:38 +0200 Subject: [PATCH 13/96] Fix ad-hoc deletion logic for invited users. --- libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index be01bd446fc..cfcea76329b 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -541,13 +541,13 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByE (PendingInvitation, False, _) -> notValid (PendingInvitation, True, Just email) -> lookupInvitationByEmail email >>= \case - Nothing -> notValid - Just _ -> do + Nothing -> do -- user invited via scim should expire together with its invitation -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring -- job akin to 'pendingUserActivationCleanup' enqueueUserDeletion (userId account.accountUser) - valid + notValid + Just _ -> valid (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email (Active, _, _) -> valid (Suspended, _, _) -> valid From 243ad3244501d6a8ab26ed9d1f3c8aaa2df33c64 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 26 Aug 2024 11:08:37 +0200 Subject: [PATCH 14/96] Updated wire-subsystem nix. --- libs/wire-subsystems/default.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 080a271d46e..7b12c9be4ac 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -73,6 +73,7 @@ , types-common , unliftio , unordered-containers +, uri-bytestring , uuid , wai-utilities , wire-api @@ -144,6 +145,7 @@ mkDerivation { types-common unliftio unordered-containers + uri-bytestring uuid wai-utilities wire-api From 08e15acbff737b1daff08f0736a78693a557d8d6 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 26 Aug 2024 15:50:36 +0200 Subject: [PATCH 15/96] [chore] remove some unnecessary types --- .../src/Wire/InvitationCodeStore.hs | 31 ++++--------- .../src/Wire/InvitationCodeStore/Cassandra.hs | 30 +++---------- .../test/unit/Wire/MiniBackend.hs | 6 +-- .../MockInterpreters/InvitationCodeStore.hs | 4 +- services/brig/src/Brig/API/User.hs | 14 +++--- services/brig/src/Brig/Team/API.hs | 45 +++++++++++-------- 6 files changed, 54 insertions(+), 76 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 09f4c0579aa..17f8d3490e6 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -51,50 +51,35 @@ data StoredInvitation = MkStoredInvitation recordInstance ''StoredInvitation -data StoredInvitationByTeam = MkStoredInvitationByTeam +data StoredInvitationInfo = MkStoredInvitationInfo { teamId :: TeamId, invitationId :: InvitationId, code :: InvitationCode -- TODO(mangoiv): maybe we can drop this last element } deriving (Show, Eq, Generic) - deriving (Arbitrary) via (GenericUniform StoredInvitationByTeam) + deriving (Arbitrary) via (GenericUniform StoredInvitationInfo) -recordInstance ''StoredInvitationByTeam - -data InvitationByEmail - = InvitationByEmail InvitationInfo - | InvitationByEmailNotFound - | InvitationByEmailMoreThanOne - -data InvitationInfo = InvitationInfo - { code :: InvitationCode, - team :: TeamId, - invitationId :: InvitationId - } - deriving (Eq, Show, Generic) - -recordInstance ''InvitationInfo +recordInstance ''StoredInvitationInfo data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) - LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe InvitationInfo) - LookupInvitationInfoByEmail :: EmailAddress -> InvitationCodeStore m InvitationByEmail - LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationByTeam] + LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) + LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] makeSem ''InvitationCodeStore lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> Sem r (Maybe StoredInvitation) lookupInvitationByEmail email = runMaybeT do - MkStoredInvitationByTeam {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email + MkStoredInvitationInfo {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email MaybeT $ lookupInvitation teamId invitationId lookupInvitationByCode :: (Member InvitationCodeStore r) => InvitationCode -> Sem r (Maybe StoredInvitation) lookupInvitationByCode code = runMaybeT do info <- MaybeT $ lookupInvitationInfo code - MaybeT $ lookupInvitation info.team info.invitationId + MaybeT $ lookupInvitation info.teamId info.invitationId -lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => EmailAddress -> Sem r (Maybe StoredInvitationByTeam) +lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => EmailAddress -> Sem r (Maybe StoredInvitationInfo) lookupSingleInvitationCodeByEmail email = do invs <- lookupInvitationCodesByEmail email case invs of diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 719ca1bc3b9..c62dd54f593 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -6,6 +6,9 @@ import Database.CQL.Protocol (TupleType, asRecord) import Imports import Polysemy import Polysemy.Embed +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log +import System.Logger.Message qualified as Log import Wire.API.User import Wire.InvitationCodeStore @@ -15,20 +18,19 @@ interpretInvitationCodeStoreToCassandra casClient = runEmbedded (runClient casClient) . \case LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email - LookupInvitationInfoByEmail email -> embed $ lookupInvitationInfoByEmailImp email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code -lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe InvitationInfo) +lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe StoredInvitationInfo) lookupInvitationInfoImpl code = fmap asRecord <$> retry x1 (query1 cql (params LocalQuorum (Identity code))) where - cql :: PrepQuery R (Identity InvitationCode) (TupleType InvitationInfo) + cql :: PrepQuery R (Identity InvitationCode) (TupleType StoredInvitationInfo) cql = [sql| - SELECT code, team, id FROM team_invitation_info WHERE code = ? + SELECT team, id, code FROM team_invitation_info WHERE code = ? |] -lookupInvitationCodesByEmailImpl :: EmailAddress -> Client [StoredInvitationByTeam] +lookupInvitationCodesByEmailImpl :: EmailAddress -> Client [StoredInvitationInfo] lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (params LocalQuorum (Identity email))) where cql :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) @@ -47,21 +49,3 @@ lookupInvitationImpl tid iid = [sql| SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? |] - -lookupInvitationInfoByEmailImp :: EmailAddress -> Client InvitationByEmail -lookupInvitationInfoByEmailImp email = do - res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) - case res of - [] -> pure InvitationByEmailNotFound - [(tid, invId, code)] -> - -- one invite pending - pure $ InvitationByEmail (InvitationInfo code tid invId) - _ : _ : _ -> do - -- TODO: log the edge case: more than one pending invite from different teams - -- Log.info $ - -- Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") - -- Log.~~ Log.field "email" (show email) - pure InvitationByEmailMoreThanOne - where - cqlInvitationEmail :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) - cqlInvitationEmail = "SELECT team, invitation, code FROM team_invitation_email WHERE email = ?" diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index a3534c68efb..a730dd08b17 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -105,7 +105,7 @@ type MiniBackendEffects = GalleyAPIAccess, InvitationCodeStore, State (Map (TeamId, InvitationId) StoredInvitation), - State (Map InvitationCode InvitationInfo), + State (Map InvitationCode StoredInvitationInfo), ActivationCodeStore, State (Map EmailKey (Maybe UserId, ActivationCode)), BlockListStore, @@ -136,7 +136,7 @@ data MiniBackend = MkMiniBackend passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity), blockList :: [EmailKey], activationCodes :: Map EmailKey (Maybe UserId, ActivationCode), - invitationInfos :: Map InvitationCode InvitationInfo, + invitationInfos :: Map InvitationCode StoredInvitationInfo, invitations :: Map (TeamId, InvitationId) StoredInvitation } deriving stock (Eq, Show, Generic) @@ -378,7 +378,7 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg -liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode InvitationInfo) : r) a -> Sem r a +liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode StoredInvitationInfo) : r) a -> Sem r a liftInvitationInfoStoreState = interpret \case Polysemy.State.Get -> gets (.invitationInfos) Put newAcs -> modify $ \b -> b {invitationInfos = newAcs} diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index d40e1241a87..0b3c3b0ac22 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -15,7 +15,7 @@ import Wire.InvitationCodeStore inMemoryInvitationCodeStoreInterpreter :: forall r. ( Member (State (Map (TeamId, InvitationId) StoredInvitation)) r, - Member (State (Map (InvitationCode) InvitationInfo)) r + Member (State (Map (InvitationCode) StoredInvitationInfo)) r ) => InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case @@ -23,6 +23,6 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case LookupInvitationInfo iid -> gets (!? iid) LookupInvitationCodesByEmail em -> let c MkStoredInvitation {..} - | email == em = Just MkStoredInvitationByTeam {..} + | email == em = Just MkStoredInvitationInfo {..} | otherwise = Nothing in mapMaybe c . elems <$> get diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index a1ea3c01a6d..26a6444939c 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -386,18 +386,18 @@ createUser new = do RegisterError (AppT r) ( Maybe - (Store.StoredInvitation, Store.InvitationInfo, TeamId) + (Store.StoredInvitation, Store.StoredInvitationInfo, TeamId) ) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = lift (liftSem $ Store.lookupInvitationInfo c) >>= \case Just invitationInfo -> do - inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.team invitationInfo.invitationId + inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.teamId invitationInfo.invitationId case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - ensureMemberCanJoin invitationInfo.team - pure $ Just (invite, invitationInfo, invitationInfo.team) + ensureMemberCanJoin invitationInfo.teamId + pure $ Just (invite, invitationInfo, invitationInfo.teamId) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -417,7 +417,7 @@ createUser new = do acceptTeamInvitation :: UserAccount -> Store.StoredInvitation -> - Store.InvitationInfo -> + Store.StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () @@ -430,7 +430,7 @@ createUser new = do minvmeta = (,inv.createdAt) <$> inv.createdBy role :: Role role = fromMaybe defaultRole inv.role - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.team minvmeta role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.teamId minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -439,7 +439,7 @@ createUser new = do liftSem $ Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ invitationInfo.team) + . field "team" (toByteString $ invitationInfo.teamId) . msg (val "Accepting invitation") liftSem $ UserPendingActivationStore.remove uid wrapClient $ do diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 8cf171f5fe7..11d5a3e5989 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -56,8 +56,8 @@ import Network.Wai.Utilities hiding (code, message) import Polysemy import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log import Servant hiding (Handler, JSON, addHeader) -import System.Logger.Class qualified as Log import System.Logger.Message as Log import Util.Logging (logFunction, logTeam) import Wire.API.Error @@ -94,6 +94,7 @@ servantAPI :: Member UserKeyStore r, Member UserSubsystem r, Member EmailSending r, + Member TinyLog r, Member Store.InvitationCodeStore r ) => ServerT TeamsAPI (Handler r) @@ -133,7 +134,8 @@ createInvitation :: ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, - Member EmailSending r + Member EmailSending r, + Member TinyLog r ) => UserId -> TeamId -> @@ -197,20 +199,21 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid loc name ema createUserInviteViaScim newUser -logInvitationRequest :: (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> (Handler r) (Invitation, InvitationCode) +logInvitationRequest :: (Member TinyLog r) => (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> Handler r (Invitation, InvitationCode) logInvitationRequest context action = - flip mapExceptT action $ \action' -> do + flip mapExceptT action \action' -> do eith <- action' case eith of Left err' -> do - Log.warn $ - context - . Log.msg @Text - ( "Failed to create invitation, label: " - <> (LT.toStrict . errorLabel) err' - ) + liftSem $ + Log.warn $ + context + . Log.msg @Text + ( "Failed to create invitation, label: " + <> (LT.toStrict . errorLabel) err' + ) pure (Left err') - Right result@(_, code) -> do + Right result@(_, code) -> liftSem do Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) @@ -305,14 +308,20 @@ getInvitationByCode c = do maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv -- FIXME(mangoiv): This should not be in terms of store -headInvitationByEmail :: (Member InvitationCodeStore r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult -headInvitationByEmail e = +headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult +headInvitationByEmail email = lift $ liftSem $ - Store.lookupInvitationInfoByEmail e <&> \case - Store.InvitationByEmail _ -> Public.InvitationByEmail - Store.InvitationByEmailNotFound -> Public.InvitationByEmailNotFound - Store.InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne + Store.lookupInvitationCodesByEmail email >>= \case + [] -> pure Public.InvitationByEmailNotFound + [_code] -> pure Public.InvitationByEmail + (_ : _ : _) -> do + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + pure Public.InvitationByEmailMoreThanOne + +-- Store.InvitationByEmail _ -> Public.InvitationByEmail -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and @@ -338,7 +347,7 @@ suspendTeam :: TeamId -> (Handler r) NoContent suspendTeam tid = do - Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) + lift $ liftSem $ Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) changeTeamAccountStatuses tid Suspended lift $ wrapClient $ DB.deleteInvitations tid lift $ liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing From 1fd3321926afb0595fc4c039de3e6698c2c61a6b Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 26 Aug 2024 16:06:57 +0200 Subject: [PATCH 16/96] [chore] move count invitations to InvitationCodeStore --- libs/wire-subsystems/src/Wire/InvitationCodeStore.hs | 1 + .../src/Wire/InvitationCodeStore/Cassandra.hs | 12 +++++++++--- .../Wire/MockInterpreters/InvitationCodeStore.hs | 2 ++ services/brig/src/Brig/Team/API.hs | 11 +++++++---- services/brig/src/Brig/Team/DB.hs | 9 --------- 5 files changed, 19 insertions(+), 16 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 17f8d3490e6..cd0a9a892c3 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -66,6 +66,7 @@ data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] + CountInvitations :: TeamId -> InvitationCodeStore m Int64 makeSem ''InvitationCodeStore diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index c62dd54f593..e954d941daa 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -6,9 +6,6 @@ import Database.CQL.Protocol (TupleType, asRecord) import Imports import Polysemy import Polysemy.Embed -import Polysemy.TinyLog (TinyLog) -import Polysemy.TinyLog qualified as Log -import System.Logger.Message qualified as Log import Wire.API.User import Wire.InvitationCodeStore @@ -19,6 +16,15 @@ interpretInvitationCodeStoreToCassandra casClient = LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code + CountInvitations tid -> embed $ countInvitationsImpl tid + +countInvitationsImpl :: TeamId -> Client (Int64) +countInvitationsImpl t = + maybe 0 runIdentity + <$> retry x1 (query1 cql (params LocalQuorum (Identity t))) + where + cql :: PrepQuery R (Identity TeamId) (Identity Int64) + cql = [sql| count(*) FROM team_invitation WHERE team = ?|] lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe StoredInvitationInfo) lookupInvitationInfoImpl code = diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 0b3c3b0ac22..c7580c5c94a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -5,6 +5,7 @@ module Wire.MockInterpreters.InvitationCodeStore where import Data.Id (InvitationId, TeamId) import Data.Map (elems, (!?)) +import Data.Map qualified as M import Imports import Polysemy import Polysemy.State (State, get, gets) @@ -26,3 +27,4 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case | email == em = Just MkStoredInvitationInfo {..} | otherwise = Nothing in mapMaybe c . elems <$> get + CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 11d5a3e5989..65a6e10bf3c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -135,7 +135,8 @@ createInvitation :: Member UserKeyStore r, Member UserSubsystem r, Member EmailSending r, - Member TinyLog r + Member TinyLog r, + Member InvitationCodeStore r ) => UserId -> TeamId -> @@ -171,7 +172,8 @@ createInvitationViaScim :: Member (UserPendingActivationStore p) r, Member TinyLog r, Member EmailSending r, - Member UserSubsystem r + Member UserSubsystem r, + Member InvitationCodeStore r ) => TeamId -> NewUserScimInvitation -> @@ -221,7 +223,8 @@ createInvitation' :: ( Member UserSubsystem r, Member GalleyAPIAccess r, Member UserKeyStore r, - Member EmailSending r + Member EmailSending r, + Member InvitationCodeStore r ) => TeamId -> Maybe UserId -> @@ -241,7 +244,7 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do throwStd emailExists maxSize <- setMaxTeamSize <$> view settings - pending <- lift $ wrapClient $ DB.countInvitations tid + pending <- lift $ liftSem $ countInvitations tid when (fromIntegral pending >= maxSize) $ throwStd (errorToWai @'E.TooManyTeamInvitations) diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 469419973e6..bf999b7719a 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -18,7 +18,6 @@ module Brig.Team.DB ( module T, mkInviteUrl, - countInvitations, insertInvitation, deleteInvitation, deleteInvitations, @@ -170,14 +169,6 @@ deleteInvitations t = cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" -countInvitations :: (MonadClient m) => TeamId -> m Int64 -countInvitations t = - maybe 0 runIdentity - <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) - where - cqlSelect :: PrepQuery R (Identity TeamId) (Identity Int64) - cqlSelect = "SELECT count(*) FROM team_invitation WHERE team = ?" - -- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. toInvitation :: From c56f7c76de41eee49254569e6499654eb03f5dec Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 26 Aug 2024 16:52:20 +0200 Subject: [PATCH 17/96] [wip] move lookupInvitations paginaged to InvitationCodeStore --- .../src/Wire/InvitationCodeStore.hs | 8 ++++ .../src/Wire/InvitationCodeStore/Cassandra.hs | 30 +++++++++++++++ services/brig/src/Brig/Team/API.hs | 9 ++++- services/brig/src/Brig/Team/DB.hs | 38 ------------------- 4 files changed, 45 insertions(+), 40 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index cd0a9a892c3..35675793691 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -23,6 +23,7 @@ module Wire.InvitationCodeStore where import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) import Data.Id (InvitationId, TeamId, UserId) import Data.Json.Util (UTCTimeMillis) +import Data.Range (Range) import Database.CQL.Protocol (Record (..), TupleType, recordInstance) import Imports import Polysemy @@ -62,11 +63,18 @@ data StoredInvitationInfo = MkStoredInvitationInfo recordInstance ''StoredInvitationInfo +data PaginatedResult a + = PaginatedResultHasMore a + | PaginatedResult a + deriving stock (Eq, Ord, Show, Functor, Foldable) + data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] CountInvitations :: TeamId -> InvitationCodeStore m Int64 + -- | invariant: page size is 100 + LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) makeSem ''InvitationCodeStore diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index e954d941daa..7b9b04f03b4 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -2,10 +2,13 @@ module Wire.InvitationCodeStore.Cassandra where import Cassandra import Data.Id +import Data.Json.Util (UTCTimeMillis) +import Data.Range (Range, fromRange) import Database.CQL.Protocol (TupleType, asRecord) import Imports import Polysemy import Polysemy.Embed +import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore @@ -17,6 +20,33 @@ interpretInvitationCodeStoreToCassandra casClient = LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code CountInvitations tid -> embed $ countInvitationsImpl tid + LookupInvitationsPaginated mSize tid miid -> embed $ lookupInvitationsPaginatedImpl mSize tid miid + +lookupInvitationsPaginatedImpl :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> Client (PaginatedResult [StoredInvitation]) +lookupInvitationsPaginatedImpl mSize tid miid = do + page <- retry x1 case miid of + Just ref -> paginate cqlSelectFrom (paramsP LocalQuorum (tid, ref) (pageSize + 1)) + Nothing -> paginate cqlSelect (paramsP LocalQuorum (Identity tid) (pageSize + 1)) + pure $ mkPage (hasMore page) $ map asRecord $ trim page + where + pageSize :: Int32 + pageSize = maybe 100 fromRange mSize + + trim :: Page a -> [a] + trim p = take (fromIntegral pageSize) (result p) + + mkPage more invs = if more then PaginatedResultHasMore invs else PaginatedResult invs + + cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) + cqlSelect = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC + |] + cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) + cqlSelectFrom = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC + |] countInvitationsImpl :: TeamId -> Client (Int64) countInvitationsImpl t = diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 65a6e10bf3c..0b758d48113 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -283,8 +283,13 @@ listInvitations :: listInvitations uid tid start mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start (fromMaybe (unsafeRange 100) mSize) - pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) + rs <- lift $ liftSem $ Store.lookupInvitationsPaginated mSize showInvitationUrl tid start + pure $! todo + +-- TODO(mangoiv): +-- traverse with toInvitation showInvitationUrl +-- and no Bool +-- Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) getInvitation :: (Member GalleyAPIAccess r, Member Store.InvitationCodeStore r) => diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index bf999b7719a..67bcee6bcec 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -21,8 +21,6 @@ module Brig.Team.DB insertInvitation, deleteInvitation, deleteInvitations, - lookupInvitationCode, - lookupInvitations, mkInvitationCode, mkInvitationId, ) @@ -97,48 +95,12 @@ insertInvitation showUrl iid t role (toUTCTimeMillis -> now) minviter email invi cqlInvitationByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () cqlInvitationByEmail = "INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ?" -lookupInvitationCode :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe InvitationCode) -lookupInvitationCode t r = - fmap runIdentity - <$> retry x1 (query1 cqlInvitationCode (params LocalQuorum (t, r))) - where - cqlInvitationCode :: PrepQuery R (TeamId, InvitationId) (Identity InvitationCode) - cqlInvitationCode = "SELECT code FROM team_invitation WHERE team = ? AND id = ?" - lookupInvitationCodeEmail :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe (InvitationCode, EmailAddress)) lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) where cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" -lookupInvitations :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - Maybe InvitationId -> - Range 1 500 Int32 -> - m (ResultPage Invitation) -lookupInvitations showUrl team start (fromRange -> size) = do - page <- case start of - Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP LocalQuorum (team, ref) (size + 1)) - Nothing -> retry x1 $ paginate cqlSelect (paramsP LocalQuorum (Identity team) (size + 1)) - toResult (hasMore page) <$> traverse (toInvitation showUrl) (trim page) - where - trim p = take (fromIntegral size) (result p) - toResult more invs = - cassandraResultPage $ - emptyPage - { result = invs, - hasMore = more - } - cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlSelect = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC" - cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlSelectFrom = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC" - deleteInvitation :: (MonadClient m) => TeamId -> InvitationId -> m () deleteInvitation t i = do codeEmail <- lookupInvitationCodeEmail t i From 13eddee9b884559ae5f63ef21e7fd68e59d0c5b6 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 27 Aug 2024 12:07:23 +0200 Subject: [PATCH 18/96] Moved InsertInvitation to InvitationCodeStore, moved Timeout. --- libs/types-common/src/Wire/Timeout.hs | 32 +++++ libs/types-common/types-common.cabal | 2 + .../src/Wire/InvitationCodeStore.hs | 8 +- .../src/Wire/InvitationCodeStore/Cassandra.hs | 50 +++++++- .../MockInterpreters/InvitationCodeStore.hs | 16 ++- services/brig/brig.cabal | 1 - services/brig/src/Brig/API/User.hs | 2 +- services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/Data/MLS/KeyPackage.hs | 2 +- services/brig/src/Brig/Options.hs | 24 +--- services/brig/src/Brig/Run.hs | 1 + services/brig/src/Brig/Team/API.hs | 119 +++++++++++++----- services/brig/src/Brig/Team/DB.hs | 108 +--------------- services/brig/src/Brig/User/Auth.hs | 4 +- services/brig/src/Brig/User/Auth/Cookie.hs | 1 + services/brig/test/integration/API/Team.hs | 4 +- .../brig/test/integration/API/User/Account.hs | 9 +- .../brig/test/integration/API/User/Auth.hs | 7 +- .../brig/test/integration/API/User/Client.hs | 6 +- .../test/integration/API/User/Connection.hs | 5 +- .../brig/test/integration/API/User/Handles.hs | 5 +- .../integration/API/User/PasswordReset.hs | 3 +- .../test/integration/API/User/RichInfo.hs | 3 +- 23 files changed, 223 insertions(+), 191 deletions(-) create mode 100644 libs/types-common/src/Wire/Timeout.hs diff --git a/libs/types-common/src/Wire/Timeout.hs b/libs/types-common/src/Wire/Timeout.hs new file mode 100644 index 00000000000..016c377eb23 --- /dev/null +++ b/libs/types-common/src/Wire/Timeout.hs @@ -0,0 +1,32 @@ +module Wire.Timeout + ( Timeout (..), + module Data.Time.Clock, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Scientific +import Data.Time.Clock +import Imports + +newtype Timeout = Timeout + { timeoutDiff :: NominalDiffTime + } + deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) + +instance Read Timeout where + readsPrec i s = + case readsPrec i s of + [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] + _ -> [] + +instance FromJSON Timeout where + parseJSON (Number n) = + let defaultV = 3600 + bounded = toBoundedInteger n :: Maybe Int64 + in pure $ + Timeout $ + fromIntegral @Int $ + maybe defaultV fromIntegral bounded + parseJSON v = typeMismatch "activationTimeout" v diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 5fb1c0ca72c..d1371245a96 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -39,6 +39,7 @@ library Util.Options.Common Util.Test Wire.Arbitrary + Wire.Timeout other-modules: Paths_types_common hs-source-dirs: src @@ -125,6 +126,7 @@ library , quickcheck-instances >=0.3.16 , random >=1.1 , schema-profunctor + , scientific , servant-server , tagged >=0.8 , tasty >=0.11 diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 35675793691..335f4fa9303 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -36,6 +36,7 @@ import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User (EmailAddress, InvitationCode, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.Sem.Logger qualified as Log +import Wire.Timeout data StoredInvitation = MkStoredInvitation { teamId :: TeamId, @@ -68,16 +69,21 @@ data PaginatedResult a | PaginatedResult a deriving stock (Eq, Ord, Show, Functor, Foldable) +---------------------------- + data InvitationCodeStore :: Effect where + InsertInvitation :: InvitationId -> TeamId -> Role -> UTCTime -> Maybe UserId -> EmailAddress -> Maybe Name -> Timeout -> InvitationCodeStore m StoredInvitation LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] - CountInvitations :: TeamId -> InvitationCodeStore m Int64 -- | invariant: page size is 100 LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) + CountInvitations :: TeamId -> InvitationCodeStore m Int64 makeSem ''InvitationCodeStore +---------------------------- + lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> Sem r (Maybe StoredInvitation) lookupInvitationByEmail email = runMaybeT do MkStoredInvitationInfo {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 7b9b04f03b4..4527ca46475 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -2,25 +2,66 @@ module Wire.InvitationCodeStore.Cassandra where import Cassandra import Data.Id -import Data.Json.Util (UTCTimeMillis) +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Range (Range, fromRange) -import Database.CQL.Protocol (TupleType, asRecord) +import Data.Text.Ascii (encodeBase64Url) +import Database.CQL.Protocol (TupleType, asRecord, asTuple) import Imports +import OpenSSL.Random (randBytes) import Polysemy import Polysemy.Embed import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore +import Wire.Timeout interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor InvitationCodeStore r interpretInvitationCodeStoreToCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case + InsertInvitation iid tid role time muid mail mname timeout -> embed $ insertInvitationImpl iid tid role time muid mail mname timeout LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code - CountInvitations tid -> embed $ countInvitationsImpl tid LookupInvitationsPaginated mSize tid miid -> embed $ lookupInvitationsPaginatedImpl mSize tid miid + CountInvitations tid -> embed $ countInvitationsImpl tid + +insertInvitationImpl :: + -- ( Log.MonadLogger m, + -- MonadClient m + -- ) => + -- ShowOrHideInvitationUrl -> + InvitationId -> + TeamId -> + Role -> + UTCTime -> + Maybe UserId -> + EmailAddress -> + Maybe Name -> + -- | The timeout for the invitation code. + Timeout -> + Client StoredInvitation +insertInvitationImpl invId teamId role (toUTCTimeMillis -> now) uid email name timeout = do + code <- liftIO mkInvitationCode + let inv = + MkStoredInvitation + { teamId = teamId, + role = Just role, + invitationId = invId, + createdAt = now, + createdBy = uid, + email = email, + name = name, + code = code + } + retry x5 $ write cqlInsert (params LocalQuorum (asTuple inv, round timeout)) + pure inv + where + cqlInsert :: PrepQuery W (TupleType StoredInvitation, Int32) () + cqlInsert = + [sql| + INSERT INTO team_invitation (team, role, id, created_at, created_by, email, name, code) VALUES (?, ?, ?, ?, ?, ?, ?, ?) USING TTL ? + |] lookupInvitationsPaginatedImpl :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> Client (PaginatedResult [StoredInvitation]) lookupInvitationsPaginatedImpl mSize tid miid = do @@ -85,3 +126,6 @@ lookupInvitationImpl tid iid = [sql| SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? |] + +mkInvitationCode :: IO InvitationCode +mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index c7580c5c94a..1106dc6c886 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -4,15 +4,17 @@ module Wire.MockInterpreters.InvitationCodeStore where import Data.Id (InvitationId, TeamId) +import Data.Json.Util (toUTCTimeMillis) import Data.Map (elems, (!?)) import Data.Map qualified as M +import Data.Text.Ascii (encodeBase64Url) import Imports import Polysemy -import Polysemy.State (State, get, gets) -import Wire.API.User (InvitationCode) +import Polysemy.State (State, get, gets, modify') +import Unsafe.Coerce (unsafeCoerce) +import Wire.API.User (InvitationCode (..)) import Wire.InvitationCodeStore --- TODO(mangoiv): I start to feel like we want a proper (in memory) DB here inMemoryInvitationCodeStoreInterpreter :: forall r. ( Member (State (Map (TeamId, InvitationId) StoredInvitation)) r, @@ -20,6 +22,13 @@ inMemoryInvitationCodeStoreInterpreter :: ) => InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case + InsertInvitation invitationId teamId role' createdAt' createdBy email name _timeout -> do + code <- todo -- InvitationCode . encodeBase64Url <$> unsafeCoerce (randBytes 24) + let role = Just role' + createdAt = toUTCTimeMillis createdAt' + inv = MkStoredInvitation {..} + modify' $ \s -> M.insert (inv.teamId, inv.invitationId) inv s + pure inv LookupInvitation tid iid -> gets (!? (tid, iid)) LookupInvitationInfo iid -> gets (!? iid) LookupInvitationCodesByEmail em -> @@ -27,4 +36,5 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case | email == em = Just MkStoredInvitationInfo {..} | otherwise = Nothing in mapMaybe c . elems <$> get + LookupInvitationsPaginated {} -> todo CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 3f71d1eff87..82941cf5a79 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -298,7 +298,6 @@ library , safe-exceptions >=0.1 , saml2-web-sso , schema-profunctor - , scientific >=0.3.4 , servant , servant-openapi3 , servant-server diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 26a6444939c..db2ae010c21 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -87,7 +87,7 @@ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra -import Brig.Options hiding (Timeout, internalEvents) +import Brig.Options hiding (internalEvents) import Brig.Team.DB qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index c4f84d77022..4a7021bebce 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -31,7 +31,6 @@ where import Brig.App (Env, adhocUserKeyStoreInterpreter) import Brig.Data.User -import Brig.Options import Brig.Types.Intra import Cassandra import Control.Error @@ -50,6 +49,7 @@ import Wire.API.User.Activation import Wire.API.User.Password import Wire.PasswordResetCodeStore qualified as E import Wire.PasswordResetCodeStore.Cassandra +import Wire.Timeout import Wire.UserKeyStore -- | The information associated with the pending activation of a 'UserKey'. diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs index b5242afd6fc..f2950c27cac 100644 --- a/services/brig/src/Brig/Data/MLS/KeyPackage.hs +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -26,7 +26,7 @@ where import Brig.API.MLS.KeyPackages.Validation import Brig.App -import Brig.Options hiding (Timeout) +import Brig.Options import Cassandra import Control.Arrow import Control.Error diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index f2c53d5d9bc..2182535dc7f 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -41,10 +41,8 @@ import Data.Misc (HttpsUrl) import Data.Nonce import Data.Range import Data.Schema -import Data.Scientific (toBoundedInteger) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text -import Data.Time.Clock (DiffTime, NominalDiffTime, secondsToDiffTime) import Database.Bloodhound.Types qualified as ES import Imports import Network.AMQP.Extended @@ -57,17 +55,7 @@ import Wire.API.Routes.Version import Wire.API.Team.Feature import Wire.API.User import Wire.EmailSending.SMTP (SMTPConnType (..)) - -newtype Timeout = Timeout - { timeoutDiff :: NominalDiffTime - } - deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) - -instance Read Timeout where - readsPrec i s = - case readsPrec i s of - [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] - _ -> [] +import Wire.Timeout data ElasticSearchOpts = ElasticSearchOpts { -- | ElasticSearch URL @@ -825,16 +813,6 @@ defSrvDiscoveryIntervalSeconds = secondsToDiffTime 10 defSftListLength :: Range 1 100 Int defSftListLength = unsafeRange 5 -instance FromJSON Timeout where - parseJSON (Number n) = - let defaultV = 3600 - bounded = toBoundedInteger n :: Maybe Int64 - in pure $ - Timeout $ - fromIntegral @Int $ - maybe defaultV fromIntegral bounded - parseJSON v = A.typeMismatch "activationTimeout" v - instance FromJSON Settings where parseJSON = genericParseJSON customOptions where diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 5f713dd5edb..ac8e98a38be 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -73,6 +73,7 @@ import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) import Wire.DeleteQueue import Wire.Sem.Paging qualified as P +import Wire.Timeout import Wire.UserStore -- FUTUREWORK: If any of these async threads die, we will have no clue about it diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 0b758d48113..265f46e6a79 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -33,11 +33,13 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App +import Brig.App qualified as App import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import Brig.Team.DB qualified as DB import Brig.Team.Email +import Brig.Team.Template import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize @@ -48,7 +50,10 @@ import Data.Id import Data.List1 qualified as List1 import Data.Qualified (Local) import Data.Range +import Data.Text.Ascii +import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as LT +import Data.Text.Lazy qualified as Text import Data.Time.Clock (UTCTime) import Data.Tuple.Extra import Imports hiding (head) @@ -59,6 +64,7 @@ import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import Servant hiding (Handler, JSON, addHeader) import System.Logger.Message as Log +import URI.ByteString (Absolute, URIRef, laxURIParserOptions, parseURI) import Util.Logging (logFunction, logTeam) import Wire.API.Error import Wire.API.Error.Brig qualified as E @@ -78,8 +84,9 @@ import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public import Wire.BlockListStore import Wire.EmailSending (EmailSending) +import Wire.EmailSubsystem.Template import Wire.Error -import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore import Wire.InvitationCodeStore qualified as Store @@ -224,6 +231,7 @@ createInvitation' :: Member GalleyAPIAccess r, Member UserKeyStore r, Member EmailSending r, + Member TinyLog r, Member InvitationCodeStore r ) => TeamId -> @@ -250,23 +258,23 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - lift $ do - iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid - now <- liftIO =<< view currentTime - timeout <- setTeamInvitationTimeout <$> view settings - (newInv, code) <- - wrapClient $ - DB.insertInvitation - showInvitationUrl - iid - tid - inviteeRole - now - mbInviterUid - email - body.inviteeName - timeout - (newInv, code) <$ sendInvitationMail email tid fromEmail code body.locale + iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid + now <- liftIO =<< view currentTime + timeout <- setTeamInvitationTimeout <$> view settings + newInv <- + lift . liftSem $ + Store.insertInvitation + iid + tid + inviteeRole + now + mbInviterUid + email + body.inviteeName + timeout + lift $ sendInvitationMail email tid fromEmail newInv.code body.locale + inv <- toInvitation showInvitationUrl newInv + pure (inv, newInv.code) deleteInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) () deleteInvitation uid tid iid = do @@ -274,25 +282,80 @@ deleteInvitation uid tid iid = do lift $ wrapClient $ DB.deleteInvitation tid iid listInvitations :: - (Member GalleyAPIAccess r) => + ( Member GalleyAPIAccess r, + Member TinyLog r, + Member InvitationCodeStore r + ) => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList -listInvitations uid tid start mSize = do +listInvitations uid tid startingId mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - rs <- lift $ liftSem $ Store.lookupInvitationsPaginated mSize showInvitationUrl tid start - pure $! todo + let toInvitations is = mapM (toInvitation showInvitationUrl) is + lift (liftSem $ Store.lookupInvitationsPaginated mSize tid startingId) >>= \case + PaginatedResultHasMore storedInvs -> do + invs <- toInvitations storedInvs + pure $ InvitationList invs True + PaginatedResult storedInvs -> do + invs <- toInvitations storedInvs + pure $ InvitationList invs False --- TODO(mangoiv): --- traverse with toInvitation showInvitationUrl --- and no Bool --- Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) +-- \| brig used to not store the role, so for migration we allow this to be empty and fill in the +-- default here. +toInvitation :: + ( Member TinyLog r + ) => + ShowOrHideInvitationUrl -> + StoredInvitation -> + (Handler r) Invitation +toInvitation showUrl storedInv = do + url <- mkInviteUrl showUrl storedInv.teamId storedInv.code + pure $ + Invitation + { team = storedInv.teamId, + role = fromMaybe defaultRole storedInv.role, + invitationId = storedInv.invitationId, + createdAt = storedInv.createdAt, + createdBy = storedInv.createdBy, + inviteeEmail = storedInv.email, + inviteeName = storedInv.name, + inviteeUrl = url + } + +mkInviteUrl :: + (Member TinyLog r) => + ShowOrHideInvitationUrl -> + TeamId -> + InvitationCode -> + (Handler r) (Maybe (URIRef Absolute)) +mkInviteUrl HideInvitationUrl _ _ = pure Nothing +mkInviteUrl ShowInvitationUrl team (InvitationCode c) = do + template <- invitationEmailUrl . invitationEmail . snd <$> teamTemplates Nothing + branding <- view App.templateBranding + let url = Text.toStrict $ renderTextWithBranding template replace branding + parseHttpsUrl url + where + replace "team" = idToText team + replace "code" = toText c + replace x = x + parseHttpsUrl :: (Member TinyLog r) => Text -> (Handler r) (Maybe (URIRef Absolute)) + parseHttpsUrl url = + either (\e -> lift . liftSem $ logError url e >> pure Nothing) (pure . Just) $ + parseURI laxURIParserOptions (encodeUtf8 url) + logError url e = + Log.err $ + Log.msg @Text "Unable to create invitation url. Please check configuration." + . Log.field "url" url + . Log.field "error" (show e) getInvitation :: - (Member GalleyAPIAccess r, Member Store.InvitationCodeStore r) => + ( Member GalleyAPIAccess r, + Member InvitationCodeStore r, + Member TinyLog r + ) => UserId -> TeamId -> InvitationId -> @@ -304,7 +367,7 @@ getInvitation uid tid iid = do Just invitation -> do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift . liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - maybeUrl <- DB.mkInviteUrl showInvitationUrl tid invitation.code + maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) getInvitationByCode :: diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index 67bcee6bcec..00adfa9b9c9 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -17,8 +17,6 @@ module Brig.Team.DB ( module T, - mkInviteUrl, - insertInvitation, deleteInvitation, deleteInvitations, mkInvitationCode, @@ -26,32 +24,17 @@ module Brig.Team.DB ) where -import Brig.App as App import Brig.Data.Types as T -import Brig.Options -import Brig.Team.Template import Cassandra as C -import Control.Lens (view) import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as C import Data.Id -import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) -import Data.Range -import Data.Text.Ascii (encodeBase64Url, toText) -import Data.Text.Encoding -import Data.Text.Lazy (toStrict) -import Data.Time.Clock +import Data.Text.Ascii (encodeBase64Url) import Data.UUID.V4 import Imports import OpenSSL.Random (randBytes) -import System.Logger.Class qualified as Log -import URI.ByteString import UnliftIO.Async (pooledMapConcurrentlyN_) -import Wire.API.Team.Invitation hiding (HeadInvitationByEmailResult (..)) -import Wire.API.Team.Role import Wire.API.User -import Wire.EmailSubsystem.Template (renderTextWithBranding) -import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl (..)) mkInvitationCode :: IO InvitationCode mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 @@ -59,42 +42,6 @@ mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 mkInvitationId :: IO InvitationId mkInvitationId = Id <$> nextRandom -insertInvitation :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - InvitationId -> - TeamId -> - Role -> - UTCTime -> - Maybe UserId -> - EmailAddress -> - Maybe Name -> - -- | The timeout for the invitation code. - Timeout -> - m (Invitation, InvitationCode) -insertInvitation showUrl iid t role (toUTCTimeMillis -> now) minviter email inviteeName timeout = do - code <- liftIO mkInvitationCode - url <- mkInviteUrl showUrl t code - let inv = Invitation t role iid now minviter email inviteeName url - retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, round timeout) - addPrepQuery cqlInvitationInfo (code, t, iid, round timeout) - addPrepQuery cqlInvitationByEmail (email, t, iid, code, round timeout) - pure (inv, code) - where - cqlInvitationInfo :: PrepQuery W (InvitationCode, TeamId, InvitationId, Int32) () - cqlInvitationInfo = "INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ?" - cqlInvitation :: PrepQuery W (TeamId, Role, InvitationId, InvitationCode, EmailAddress, UTCTimeMillis, Maybe UserId, Maybe Name, Int32) () - cqlInvitation = "INSERT INTO team_invitation (team, role, id, code, email, created_at, created_by, name) VALUES (?, ?, ?, ?, ?, ?, ?, ?) USING TTL ?" - -- Note: the edge case of multiple invites to the same team by different admins from the same team results in last-invite-wins in the team_invitation_email table. - cqlInvitationByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () - cqlInvitationByEmail = "INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ?" - lookupInvitationCodeEmail :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe (InvitationCode, EmailAddress)) lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) where @@ -130,56 +77,3 @@ deleteInvitations t = where cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" - --- | brig used to not store the role, so for migration we allow this to be empty and fill in the --- default here. -toInvitation :: - ( MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - ( TeamId, - Maybe Role, - InvitationId, - UTCTimeMillis, - Maybe UserId, - EmailAddress, - Maybe Name, - InvitationCode - ) -> - m Invitation -toInvitation showUrl (t, r, i, tm, minviter, e, inviteeName, code) = do - url <- mkInviteUrl showUrl t code - pure $ Invitation t (fromMaybe defaultRole r) i tm minviter e inviteeName url - -mkInviteUrl :: - ( MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - InvitationCode -> - m (Maybe (URIRef Absolute)) -mkInviteUrl HideInvitationUrl _ _ = pure Nothing -mkInviteUrl ShowInvitationUrl team (InvitationCode c) = do - template <- invitationEmailUrl . invitationEmail . snd <$> teamTemplates Nothing - branding <- view App.templateBranding - let url = toStrict $ renderTextWithBranding template replace branding - parseHttpsUrl url - where - replace "team" = idToText team - replace "code" = toText c - replace x = x - - parseHttpsUrl :: (Log.MonadLogger m) => Text -> m (Maybe (URIRef Absolute)) - parseHttpsUrl url = - either (\e -> logError url e >> pure Nothing) (pure . Just) $ - parseURI laxURIParserOptions (encodeUtf8 url) - - logError :: (Log.MonadLogger m, Show e) => Text -> e -> m () - logError url e = - Log.err $ - Log.msg - (Log.val "Unable to create invitation url. Please check configuration.") - . Log.field "url" url - . Log.field "error" (show e) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index b17ff8e6689..149a17e3f58 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -59,7 +59,6 @@ import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Misc (PlainTextPassword6) import Data.Qualified (Local) -import Data.Time.Clock (UTCTime) import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) @@ -79,6 +78,7 @@ import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.Timeout import Wire.UserKeyStore import Wire.UserStore import Wire.VerificationCode qualified as VerificationCode @@ -177,7 +177,7 @@ withRetryLimit action uid = do let bkey = BudgetKey ("login#" <> idToText uid) budget = Budget - (Opt.timeoutDiff $ Opt.timeout opts) + (timeoutDiff $ Opt.timeout opts) (fromIntegral $ Opt.retryLimit opts) bresult <- action bkey budget case bresult of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 23ed4c461bf..ca39068e9f2 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -60,6 +60,7 @@ import System.Logger.Class qualified as Log import Web.Cookie qualified as WebCookie import Wire.API.User.Auth import Wire.SessionStore qualified as Store +import Wire.Timeout -------------------------------------------------------------------------------- -- Basic Cookie Management diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 0b2e55e8d17..f0a183b1113 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -44,7 +44,6 @@ import Data.String.Conversions (cs) import Data.Text qualified as Text import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time (addUTCTime, getCurrentTime) import Data.UUID qualified as UUID (fromString) import Data.UUID.V4 qualified as UUID import Imports @@ -76,6 +75,7 @@ import Wire.API.Team.Size import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Client (ClientType (PermanentClientType)) +import Wire.Timeout newtype TeamSizeLimit = TeamSizeLimit Word32 @@ -769,7 +769,7 @@ testInvitationInfoBadCode brig = do get (brig . path ("/teams/invitations/info?code=" <> icode)) !!! const 400 === statusCode -testInvitationInfoExpired :: Brig -> Opt.Timeout -> Http () +testInvitationInfoExpired :: Brig -> Timeout -> Http () testInvitationInfoExpired brig timeout = do email <- randomEmail (uid, tid) <- createUserWithTeam brig diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index af2d6a3744e..1f0a998e441 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -59,8 +59,6 @@ import Data.String.Conversions import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding qualified as T -import Data.Time (UTCTime, getCurrentTime) -import Data.Time.Clock (diffUTCTime) import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUID import Federator.MockServer (FederatedRequest (..), MockException (..)) @@ -73,7 +71,7 @@ import Network.Wai.Utilities.Error qualified as Error import Network.Wai.Utilities.Error qualified as Wai import Test.QuickCheck (arbitrary, generate) import Test.Tasty hiding (Timeout) -import Test.Tasty.Cannon hiding (Cannon) +import Test.Tasty.Cannon hiding (Cannon, Timeout) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently_) @@ -93,8 +91,9 @@ 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.Timeout -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree tests _ at opts p b c ch g aws userJournalWatcher = testGroup "account" @@ -490,7 +489,7 @@ testCreateUserExternalSSO brig = do post (brig . path "/register" . contentJson . body (p True True)) !!! const 400 === statusCode -testActivateWithExpiry :: Opt.Opts -> Brig -> Opt.Timeout -> Http () +testActivateWithExpiry :: Opt.Opts -> Brig -> Timeout -> Http () testActivateWithExpiry (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () testActivateWithExpiry _ brig timeout = do u <- responseJsonError =<< registerUser "dilbert" brig diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index d189d6fd4c9..fce6d5e5a2c 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -55,7 +55,7 @@ import Data.ZAuth.Token qualified as ZAuth import Imports import Network.HTTP.Client (equivCookie) import Network.Wai.Utilities.Error qualified as Error -import Test.Tasty +import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Test.Tasty.HUnit qualified as HUnit import UnliftIO.Async hiding (wait) @@ -68,6 +68,7 @@ import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.API.User.Client +import Wire.Timeout -- | FUTUREWORK: Implement this function. This wrapper should make sure that -- wrapped tests run only when the feature flag 'legalhold' is set to @@ -462,7 +463,7 @@ testLimitRetries conf brig = do -- throttling should stop and login should work again do let Just retryAfterSecs = fromByteString =<< getHeader "Retry-After" resp - retryTimeout = Opts.Timeout $ fromIntegral retryAfterSecs + retryTimeout = Timeout $ fromIntegral retryAfterSecs liftIO $ do assertBool ("throttle delay (1): " <> show (retryTimeout, Opts.timeout opts)) @@ -1045,7 +1046,7 @@ testSuspendInactiveUsers config brig cookieType endPoint = do do diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 4cc3d7e9648..44e9f015399 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -55,7 +55,6 @@ import Data.Set qualified as Set import Data.String.Conversions import Data.Text.Ascii (AsciiChars (validate), encodeBase64UrlUnpadded, toText) import Data.Text.Encoding qualified as T -import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import Data.UUID (toByteString) import Data.UUID qualified as UUID @@ -65,7 +64,7 @@ import Network.Wai.Utilities.Error qualified as Error import System.Logger qualified as Log import Test.QuickCheck (arbitrary, generate) import Test.Tasty hiding (Timeout) -import Test.Tasty.Cannon hiding (Cannon) +import Test.Tasty.Cannon hiding (Cannon, Timeout) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) @@ -83,10 +82,11 @@ import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (..), UserMap (..), WrappedQualifiedUserMap) import Wire.API.Wrapped (Wrapped (..)) +import Wire.Timeout import Wire.VerificationCode qualified as Code import Wire.VerificationCodeGen -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree tests _cl _at opts p db n b c g = testGroup "client" diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index e9023104eb9..14b3865a7bb 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -26,7 +26,6 @@ import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Data.Connection (remoteConnectionInsert) -import Brig.Options qualified as Opt import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion @@ -34,7 +33,6 @@ import Data.Domain import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified -import Data.Time.Clock (getCurrentTime) import Data.UUID.V4 qualified as UUID import Imports import Network.Wai.Utilities.Error qualified as Error @@ -48,10 +46,11 @@ import Wire.API.Federation.Component import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User as User +import Wire.Timeout tests :: ConnectionLimit -> - Opt.Timeout -> + Timeout -> Manager -> Brig -> Cannon -> diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 8da3c774ef2..11a606a0e60 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -41,7 +41,7 @@ import Imports import Network.Wai.Utilities.Error qualified as Error import Network.Wai.Utilities.Error qualified as Wai import Test.Tasty hiding (Timeout) -import Test.Tasty.Cannon hiding (Cannon) +import Test.Tasty.Cannon hiding (Cannon, Timeout) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) @@ -51,8 +51,9 @@ import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Handle +import Wire.Timeout -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b c g = testGroup "handles" diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 857bb6c48a2..31ebf1416ee 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -35,11 +35,12 @@ import Test.Tasty hiding (Timeout) import Util import Wire.API.User import Wire.API.User.Auth +import Wire.Timeout tests :: DB.ClientState -> ConnectionLimit -> - Opt.Timeout -> + Timeout -> Opt.Opts -> Manager -> Brig -> diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index cad0d8053b6..6fe06c37714 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -37,8 +37,9 @@ import Util import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.RichInfo +import Wire.Timeout -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b _c g = testGroup "rich info" From 4591c3997f9412e5493d757064c293d543ed6273 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 27 Aug 2024 13:49:55 +0200 Subject: [PATCH 19/96] [fix] missing SELECT in cql. --- .../src/Wire/InvitationCodeStore/Cassandra.hs | 25 ++++++++++++++++--- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 4527ca46475..e8524677362 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -5,7 +5,7 @@ import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Range (Range, fromRange) import Data.Text.Ascii (encodeBase64Url) -import Database.CQL.Protocol (TupleType, asRecord, asTuple) +import Database.CQL.Protocol (TupleType, asRecord) import Imports import OpenSSL.Random (randBytes) import Polysemy @@ -54,14 +54,31 @@ insertInvitationImpl invId teamId role (toUTCTimeMillis -> now) uid email name t name = name, code = code } - retry x5 $ write cqlInsert (params LocalQuorum (asTuple inv, round timeout)) + -- TODO: see how we can improve this + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery cqlInsert (teamId, Just role, invId, now, uid, email, name, code, round timeout) + addPrepQuery cqlInsertInfo (code, teamId, invId, round timeout) + addPrepQuery cqlInsertByEmail (email, teamId, invId, code, round timeout) pure inv where - cqlInsert :: PrepQuery W (TupleType StoredInvitation, Int32) () + cqlInsert :: PrepQuery W (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode, Int32) () cqlInsert = [sql| INSERT INTO team_invitation (team, role, id, created_at, created_by, email, name, code) VALUES (?, ?, ?, ?, ?, ?, ?, ?) USING TTL ? |] + cqlInsertInfo :: PrepQuery W (InvitationCode, TeamId, InvitationId, Int32) () + cqlInsertInfo = + [sql| + INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ? + |] + -- Note: the edge case of multiple invites to the same team by different admins from the same team results in last-invite-wins in the team_invitation_email table. + cqlInsertByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () + cqlInsertByEmail = + [sql| + INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ? + |] lookupInvitationsPaginatedImpl :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> Client (PaginatedResult [StoredInvitation]) lookupInvitationsPaginatedImpl mSize tid miid = do @@ -95,7 +112,7 @@ countInvitationsImpl t = <$> retry x1 (query1 cql (params LocalQuorum (Identity t))) where cql :: PrepQuery R (Identity TeamId) (Identity Int64) - cql = [sql| count(*) FROM team_invitation WHERE team = ?|] + cql = [sql| SELECT count(*) FROM team_invitation WHERE team = ?|] lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe StoredInvitationInfo) lookupInvitationInfoImpl code = From 47e7ea1ef960a10a055cf97a52529a7235a42cca Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 27 Aug 2024 15:32:07 +0200 Subject: [PATCH 20/96] Improved comment. --- libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 3 ++- services/brig/test/integration/API/Team.hs | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index e8524677362..d73eb9977f7 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -73,7 +73,8 @@ insertInvitationImpl invId teamId role (toUTCTimeMillis -> now) uid email name t [sql| INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ? |] - -- Note: the edge case of multiple invites to the same team by different admins from the same team results in last-invite-wins in the team_invitation_email table. + -- Note: the edge case of multiple invites to the same team by different admins from the + -- same team results in last-invite-wins in the team_invitation_email table. cqlInsertByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () cqlInsertByEmail = [sql| diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index f0a183b1113..65e1f1b324a 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -338,6 +338,8 @@ testInvitationEmailLookupRegister brig = do email <- randomEmail (owner, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email + -- This incidentally also tests that sending multiple + -- invites from the same team results in last-invite-wins scenario void $ postInvitation brig tid owner invite inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite -- expect an invitation to be found querying with email after invite From c9333f03e7cc5a50a63cb44338d54fab16b22f69 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 27 Aug 2024 16:17:36 +0200 Subject: [PATCH 21/96] Added deletion to InvitationCodeStore. --- .../src/Wire/InvitationCodeStore.hs | 2 + .../src/Wire/InvitationCodeStore/Cassandra.hs | 39 +++++++++ .../MockInterpreters/InvitationCodeStore.hs | 4 +- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/brig.cabal | 1 - services/brig/src/Brig/API/User.hs | 8 +- services/brig/src/Brig/Team/API.hs | 24 +++--- services/brig/src/Brig/Team/DB.hs | 79 ------------------- 8 files changed, 62 insertions(+), 96 deletions(-) delete mode 100644 services/brig/src/Brig/Team/DB.hs diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 335f4fa9303..0d3f02ef2ec 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -79,6 +79,8 @@ data InvitationCodeStore :: Effect where -- | invariant: page size is 100 LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) CountInvitations :: TeamId -> InvitationCodeStore m Int64 + DeleteInvitation :: TeamId -> InvitationId -> InvitationCodeStore m () + DeleteInvitations :: TeamId -> InvitationCodeStore m () makeSem ''InvitationCodeStore diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index d73eb9977f7..9c5a2936447 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -1,6 +1,8 @@ module Wire.InvitationCodeStore.Cassandra where import Cassandra +import Data.Conduit (runConduit, (.|)) +import Data.Conduit.List qualified as Conduit import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Range (Range, fromRange) @@ -10,6 +12,7 @@ import Imports import OpenSSL.Random (randBytes) import Polysemy import Polysemy.Embed +import UnliftIO.Async (pooledMapConcurrentlyN_) import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore @@ -25,6 +28,8 @@ interpretInvitationCodeStoreToCassandra casClient = LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code LookupInvitationsPaginated mSize tid miid -> embed $ lookupInvitationsPaginatedImpl mSize tid miid CountInvitations tid -> embed $ countInvitationsImpl tid + DeleteInvitation tid invId -> embed $ deleteInvitationImpl tid invId + DeleteInvitations tid -> embed $ deleteInvitationsImpl tid insertInvitationImpl :: -- ( Log.MonadLogger m, @@ -145,5 +150,39 @@ lookupInvitationImpl tid iid = SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? |] +deleteInvitationImpl :: TeamId -> InvitationId -> Client () +deleteInvitationImpl teamId invId = do + codeEmail <- lookupInvitationCodeEmail + case codeEmail of + Just (invCode, invEmail) -> retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery cqlInvitation (teamId, invId) + addPrepQuery cqlInvitationInfo (Identity invCode) + addPrepQuery cqlInvitationEmail (invEmail, teamId) + Nothing -> + retry x5 $ write cqlInvitation (params LocalQuorum (teamId, invId)) + where + cqlInvitation :: PrepQuery W (TeamId, InvitationId) () + cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" + cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () + cqlInvitationInfo = "DELETE FROM team_invitation_info WHERE code = ?" + cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () + cqlInvitationEmail = "DELETE FROM team_invitation_email WHERE email = ? AND team = ?" + lookupInvitationCodeEmail :: Client (Maybe (InvitationCode, EmailAddress)) + lookupInvitationCodeEmail = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (teamId, invId))) + cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) + cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" + +deleteInvitationsImpl :: TeamId -> Client () +deleteInvitationsImpl teamId = + runConduit $ + paginateC cqlSelect (paramsP LocalQuorum (Identity teamId) 100) x1 + .| Conduit.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitationImpl teamId . runIdentity)) + where + cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) + cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" + +-------------------------------- mkInvitationCode :: IO InvitationCode mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 1106dc6c886..f7563bd8f11 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -7,11 +7,9 @@ import Data.Id (InvitationId, TeamId) import Data.Json.Util (toUTCTimeMillis) import Data.Map (elems, (!?)) import Data.Map qualified as M -import Data.Text.Ascii (encodeBase64Url) import Imports import Polysemy import Polysemy.State (State, get, gets, modify') -import Unsafe.Coerce (unsafeCoerce) import Wire.API.User (InvitationCode (..)) import Wire.InvitationCodeStore @@ -38,3 +36,5 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case in mapMaybe c . elems <$> get LookupInvitationsPaginated {} -> todo CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) + DeleteInvitation tid invId -> todo + DeleteInvitations tid -> todo diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index d74d94201c4..a544025aa7b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -140,6 +140,7 @@ library , bytestring , bytestring-conversion , cassandra-util + , conduit , containers , cql , crypton diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 82941cf5a79..c723695019b 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -188,7 +188,6 @@ library Brig.Schema.V84_DropTeamInvitationPhone Brig.Schema.V85_DropUserKeysHashed Brig.Team.API - Brig.Team.DB Brig.Team.Email Brig.Team.Template Brig.Team.Util diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index db2ae010c21..0c07ddb6180 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -88,7 +88,6 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), User import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) -import Brig.Team.DB qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth @@ -436,14 +435,13 @@ createUser new = do lift $ do wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) - liftSem $ + liftSem do Log.info $ field "user" (toByteString uid) . field "team" (toByteString $ invitationInfo.teamId) . msg (val "Accepting invitation") - liftSem $ UserPendingActivationStore.remove uid - wrapClient $ do - Team.deleteInvitation inv.teamId inv.invitationId + UserPendingActivationStore.remove uid + Store.deleteInvitation inv.teamId inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 265f46e6a79..e4362d90452 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -37,7 +37,6 @@ import Brig.App qualified as App import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) -import Brig.Team.DB qualified as DB import Brig.Team.Email import Brig.Team.Template import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) @@ -88,7 +87,7 @@ import Wire.EmailSubsystem.Template import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.InvitationCodeStore +import Wire.InvitationCodeStore (InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency @@ -252,13 +251,13 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do throwStd emailExists maxSize <- setMaxTeamSize <$> view settings - pending <- lift $ liftSem $ countInvitations tid + pending <- lift $ liftSem $ Store.countInvitations tid when (fromIntegral pending >= maxSize) $ throwStd (errorToWai @'E.TooManyTeamInvitations) showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid + iid <- maybe (liftIO randomId) (pure . Id . toUUID) mUid now <- liftIO =<< view currentTime timeout <- setTeamInvitationTimeout <$> view settings newInv <- @@ -276,10 +275,15 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do inv <- toInvitation showInvitationUrl newInv pure (inv, newInv.code) -deleteInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) () +deleteInvitation :: + (Member GalleyAPIAccess r, Member InvitationCodeStore r) => + UserId -> + TeamId -> + InvitationId -> + (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - lift $ wrapClient $ DB.deleteInvitation tid iid + lift . liftSem $ Store.deleteInvitation tid iid listInvitations :: ( Member GalleyAPIAccess r, @@ -413,15 +417,17 @@ suspendTeam :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member InvitationCodeStore r ) => TeamId -> (Handler r) NoContent suspendTeam tid = do lift $ liftSem $ Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) changeTeamAccountStatuses tid Suspended - lift $ wrapClient $ DB.deleteInvitations tid - lift $ liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing + lift . liftSem $ do + Store.deleteInvitations tid + GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing pure NoContent unsuspendTeam :: diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs deleted file mode 100644 index 00adfa9b9c9..00000000000 --- a/services/brig/src/Brig/Team/DB.hs +++ /dev/null @@ -1,79 +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 Brig.Team.DB - ( module T, - deleteInvitation, - deleteInvitations, - mkInvitationCode, - mkInvitationId, - ) -where - -import Brig.Data.Types as T -import Cassandra as C -import Data.Conduit (runConduit, (.|)) -import Data.Conduit.List qualified as C -import Data.Id -import Data.Text.Ascii (encodeBase64Url) -import Data.UUID.V4 -import Imports -import OpenSSL.Random (randBytes) -import UnliftIO.Async (pooledMapConcurrentlyN_) -import Wire.API.User - -mkInvitationCode :: IO InvitationCode -mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 - -mkInvitationId :: IO InvitationId -mkInvitationId = Id <$> nextRandom - -lookupInvitationCodeEmail :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe (InvitationCode, EmailAddress)) -lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) - where - cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) - cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" - -deleteInvitation :: (MonadClient m) => TeamId -> InvitationId -> m () -deleteInvitation t i = do - codeEmail <- lookupInvitationCodeEmail t i - case codeEmail of - Just (invCode, invEmail) -> retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery cqlInvitation (t, i) - addPrepQuery cqlInvitationInfo (Identity invCode) - addPrepQuery cqlInvitationEmail (invEmail, t) - Nothing -> - retry x5 $ write cqlInvitation (params LocalQuorum (t, i)) - where - cqlInvitation :: PrepQuery W (TeamId, InvitationId) () - cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" - cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () - cqlInvitationInfo = "DELETE FROM team_invitation_info WHERE code = ?" - cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () - cqlInvitationEmail = "DELETE FROM team_invitation_email WHERE email = ? AND team = ?" - -deleteInvitations :: (MonadClient m) => TeamId -> m () -deleteInvitations t = - liftClient $ - runConduit $ - paginateC cqlSelect (paramsP LocalQuorum (Identity t) 100) x1 - .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) - where - cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) - cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" From 58c30783f6fcd96307d34e42a421a091eecd49ac Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 27 Aug 2024 16:20:37 +0200 Subject: [PATCH 22/96] Regen nix derivations. --- cassandra-schema.cql | 2 ++ libs/types-common/default.nix | 2 ++ libs/wire-subsystems/default.nix | 2 ++ services/brig/default.nix | 2 -- 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/cassandra-schema.cql b/cassandra-schema.cql index fbc45dc57bb..c6305ab3874 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -641,6 +641,8 @@ CREATE TABLE brig_test.team_invitation ( AND min_index_interval = 128 AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE INDEX team_invitation_by_email ON brig_test.team_invitation (email); +CREATE INDEX team_invitation_by_code ON brig_test.team_invitation (code); CREATE TABLE brig_test.user ( id uuid PRIMARY KEY, diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index 7421aae499c..c4bbd61c01b 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -40,6 +40,7 @@ , quickcheck-instances , random , schema-profunctor +, scientific , servant-server , string-conversions , tagged @@ -96,6 +97,7 @@ mkDerivation { quickcheck-instances random schema-profunctor + scientific servant-server tagged tasty diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 7b12c9be4ac..29e6263437f 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -14,6 +14,7 @@ , bytestring , bytestring-conversion , cassandra-util +, conduit , containers , cql , crypton @@ -96,6 +97,7 @@ mkDerivation { bytestring bytestring-conversion cassandra-util + conduit containers cql crypton diff --git a/services/brig/default.nix b/services/brig/default.nix index 20eb64d007b..03a8b688aa3 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -105,7 +105,6 @@ , safe-exceptions , saml2-web-sso , schema-profunctor -, scientific , servant , servant-client , servant-client-core @@ -247,7 +246,6 @@ mkDerivation { safe-exceptions saml2-web-sso schema-profunctor - scientific servant servant-openapi3 servant-server From e510fd4d88e1bcc9b195cc3282d078872dd82794 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 29 Aug 2024 10:11:39 +0200 Subject: [PATCH 23/96] Added changelog. --- changelog.d/5-internal/wpb-8887 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/wpb-8887 diff --git a/changelog.d/5-internal/wpb-8887 b/changelog.d/5-internal/wpb-8887 new file mode 100644 index 00000000000..43982b422a2 --- /dev/null +++ b/changelog.d/5-internal/wpb-8887 @@ -0,0 +1 @@ +Migrated user invitation DB access to Subsystems. From 27b572e8cff33925b8fa2ca3e34a090fddd243a6 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 29 Aug 2024 10:17:42 +0200 Subject: [PATCH 24/96] Removed indices from cql. --- cassandra-schema.cql | 2 -- 1 file changed, 2 deletions(-) diff --git a/cassandra-schema.cql b/cassandra-schema.cql index c6305ab3874..fbc45dc57bb 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -641,8 +641,6 @@ CREATE TABLE brig_test.team_invitation ( AND min_index_interval = 128 AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; -CREATE INDEX team_invitation_by_email ON brig_test.team_invitation (email); -CREATE INDEX team_invitation_by_code ON brig_test.team_invitation (code); CREATE TABLE brig_test.user ( id uuid PRIMARY KEY, From 61ec10e1e9603a7feee5bad69c7baf0bec0d922b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 29 Aug 2024 11:21:12 +0200 Subject: [PATCH 25/96] Update libs/wire-api/src/Wire/API/Team/Invitation.hs Co-authored-by: Igor Ranieri <54423+elland@users.noreply.github.com> --- libs/wire-api/src/Wire/API/Team/Invitation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index 8fa3bde91c0..967adad2832 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -83,7 +83,7 @@ data Invitation = Invitation role :: Role, invitationId :: InvitationId, createdAt :: UTCTimeMillis, - -- | this is always 'Just' for newvitations, but for + -- | this is always 'Just' for new invitations, but for -- migration it is allowed to be 'Nothing'. createdBy :: Maybe UserId, inviteeEmail :: EmailAddress, From c32143b499107f03b89eaccaebc53937eaaa63dc Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 29 Aug 2024 11:21:43 +0200 Subject: [PATCH 26/96] Update libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs Co-authored-by: Igor Ranieri <54423+elland@users.noreply.github.com> --- .../wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 9c5a2936447..8e12afefce1 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -32,10 +32,6 @@ interpretInvitationCodeStoreToCassandra casClient = DeleteInvitations tid -> embed $ deleteInvitationsImpl tid insertInvitationImpl :: - -- ( Log.MonadLogger m, - -- MonadClient m - -- ) => - -- ShowOrHideInvitationUrl -> InvitationId -> TeamId -> Role -> From fa976378b6b28e0014891d41dcea62ac0076761a Mon Sep 17 00:00:00 2001 From: Igor Ranieri <54423+elland@users.noreply.github.com> Date: Thu, 29 Aug 2024 13:39:30 +0200 Subject: [PATCH 27/96] Update libs/wire-subsystems/src/Wire/InvitationCodeStore.hs --- libs/wire-subsystems/src/Wire/InvitationCodeStore.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 0d3f02ef2ec..18d809c5c53 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -76,7 +76,7 @@ data InvitationCodeStore :: Effect where LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] - -- | invariant: page size is 100 + -- | Range is page size, it defaults to 100 LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) CountInvitations :: TeamId -> InvitationCodeStore m Int64 DeleteInvitation :: TeamId -> InvitationId -> InvitationCodeStore m () From ab1a1ed65c320b972c0da99876d3a524487e637a Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 29 Aug 2024 14:13:26 +0200 Subject: [PATCH 28/96] Cleaned up + review feedback. --- .../src/Wire/InvitationCodeStore/Cassandra.hs | 29 ++++++++++++++----- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- .../MockInterpreters/InvitationCodeStore.hs | 4 ++- services/brig/src/Brig/API/User.hs | 17 ++++++----- services/brig/src/Brig/Team/API.hs | 2 +- 5 files changed, 36 insertions(+), 18 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 8e12afefce1..d1363034cbf 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -159,16 +159,32 @@ deleteInvitationImpl teamId invId = do Nothing -> retry x5 $ write cqlInvitation (params LocalQuorum (teamId, invId)) where + lookupInvitationCodeEmail :: Client (Maybe (InvitationCode, EmailAddress)) + lookupInvitationCodeEmail = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (teamId, invId))) + cqlInvitation :: PrepQuery W (TeamId, InvitationId) () - cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" + cqlInvitation = + [sql| + DELETE FROM team_invitation where team = ? AND id = ? + |] + cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () - cqlInvitationInfo = "DELETE FROM team_invitation_info WHERE code = ?" + cqlInvitationInfo = + [sql| + DELETE FROM team_invitation_info WHERE code = ? + |] + cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () - cqlInvitationEmail = "DELETE FROM team_invitation_email WHERE email = ? AND team = ?" - lookupInvitationCodeEmail :: Client (Maybe (InvitationCode, EmailAddress)) - lookupInvitationCodeEmail = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (teamId, invId))) + cqlInvitationEmail = + [sql| + DELETE FROM team_invitation_email WHERE email = ? AND team = ? + |] + cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) - cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" + cqlInvitationCodeEmail = + [sql| + SELECT code, email FROM team_invitation WHERE team = ? AND id = ? + |] deleteInvitationsImpl :: TeamId -> Client () deleteInvitationsImpl teamId = @@ -179,6 +195,5 @@ deleteInvitationsImpl teamId = cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" --------------------------------- mkInvitationCode :: IO InvitationCode mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index cfcea76329b..ea92056f5e5 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -103,7 +103,7 @@ interpretUserSubsystem :: interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others - GetAccountsBy criteria -> getAccountsByImpl criteria + GetAccountsBy getBy -> getAccountsByImpl getBy GetSelfProfile self -> getSelfProfileImpl self GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index f7563bd8f11..585fce8dab9 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -10,8 +10,10 @@ import Data.Map qualified as M import Imports import Polysemy import Polysemy.State (State, get, gets, modify') +import Unsafe.Coerce (unsafeCoerce) import Wire.API.User (InvitationCode (..)) import Wire.InvitationCodeStore +import Wire.InvitationCodeStore.Cassandra (mkInvitationCode) inMemoryInvitationCodeStoreInterpreter :: forall r. @@ -21,7 +23,7 @@ inMemoryInvitationCodeStoreInterpreter :: InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case InsertInvitation invitationId teamId role' createdAt' createdBy email name _timeout -> do - code <- todo -- InvitationCode . encodeBase64Url <$> unsafeCoerce (randBytes 24) + code <- unsafeCoerce mkInvitationCode let role = Just role' createdAt = toUTCTimeMillis createdAt' inv = MkStoredInvitation {..} diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 0c07ddb6180..088ebc7ecf9 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -140,7 +140,8 @@ import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess -import Wire.InvitationCodeStore qualified as Store +import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation, StoredInvitationInfo) +import Wire.InvitationCodeStore qualified as InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem @@ -269,7 +270,7 @@ createUser :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, - Member Store.InvitationCodeStore r + Member InvitationCodeStore r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -385,13 +386,13 @@ createUser new = do RegisterError (AppT r) ( Maybe - (Store.StoredInvitation, Store.StoredInvitationInfo, TeamId) + (StoredInvitation, StoredInvitationInfo, TeamId) ) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = - lift (liftSem $ Store.lookupInvitationInfo c) >>= \case + lift (liftSem $ InvitationCodeStore.lookupInvitationInfo c) >>= \case Just invitationInfo -> do - inv <- lift . liftSem $ Store.lookupInvitation invitationInfo.teamId invitationInfo.invitationId + inv <- lift . liftSem $ InvitationCodeStore.lookupInvitation invitationInfo.teamId invitationInfo.invitationId case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do @@ -415,8 +416,8 @@ createUser new = do acceptTeamInvitation :: UserAccount -> - Store.StoredInvitation -> - Store.StoredInvitationInfo -> + StoredInvitation -> + StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () @@ -441,7 +442,7 @@ createUser new = do . field "team" (toByteString $ invitationInfo.teamId) . msg (val "Accepting invitation") UserPendingActivationStore.remove uid - Store.deleteInvitation inv.teamId inv.invitationId + InvitationCodeStore.deleteInvitation inv.teamId inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index e4362d90452..129f3fcd69e 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -307,7 +307,7 @@ listInvitations uid tid startingId mSize = do invs <- toInvitations storedInvs pure $ InvitationList invs False --- \| brig used to not store the role, so for migration we allow this to be empty and fill in the +-- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. toInvitation :: ( Member TinyLog r From e94876850e3f29ac7d51884e61c84d66da8ce0af Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 29 Aug 2024 15:07:01 +0200 Subject: [PATCH 29/96] Renamed effect function. --- libs/wire-subsystems/src/Wire/InvitationCodeStore.hs | 2 +- libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 2 +- .../test/unit/Wire/MockInterpreters/InvitationCodeStore.hs | 2 +- services/brig/src/Brig/Team/API.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 18d809c5c53..b018a9c5538 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -80,7 +80,7 @@ data InvitationCodeStore :: Effect where LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) CountInvitations :: TeamId -> InvitationCodeStore m Int64 DeleteInvitation :: TeamId -> InvitationId -> InvitationCodeStore m () - DeleteInvitations :: TeamId -> InvitationCodeStore m () + DeleteAllTeamInvitations :: TeamId -> InvitationCodeStore m () makeSem ''InvitationCodeStore diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index d1363034cbf..2f9221a4edd 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -29,7 +29,7 @@ interpretInvitationCodeStoreToCassandra casClient = LookupInvitationsPaginated mSize tid miid -> embed $ lookupInvitationsPaginatedImpl mSize tid miid CountInvitations tid -> embed $ countInvitationsImpl tid DeleteInvitation tid invId -> embed $ deleteInvitationImpl tid invId - DeleteInvitations tid -> embed $ deleteInvitationsImpl tid + DeleteAllTeamInvitations tid -> embed $ deleteInvitationsImpl tid insertInvitationImpl :: InvitationId -> diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 585fce8dab9..4dd22cf40b4 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -39,4 +39,4 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case LookupInvitationsPaginated {} -> todo CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) DeleteInvitation tid invId -> todo - DeleteInvitations tid -> todo + DeleteAllTeamInvitations tid -> todo diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 129f3fcd69e..8ea5d4b4810 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -426,7 +426,7 @@ suspendTeam tid = do lift $ liftSem $ Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) changeTeamAccountStatuses tid Suspended lift . liftSem $ do - Store.deleteInvitations tid + Store.deleteAllTeamInvitations tid GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing pure NoContent From 301c39d1a1bbf25df29173c48b7eb99bad923823 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 29 Aug 2024 15:21:02 +0200 Subject: [PATCH 30/96] Moved Timeout. --- libs/types-common/src/{Wire => Util}/Timeout.hs | 2 +- libs/types-common/types-common.cabal | 2 +- libs/wire-subsystems/src/Wire/InvitationCodeStore.hs | 2 +- libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 2 +- services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/Options.hs | 2 +- services/brig/src/Brig/Run.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 2 +- services/brig/src/Brig/User/Auth/Cookie.hs | 2 +- services/brig/test/integration/API/Team.hs | 2 +- services/brig/test/integration/API/User/Account.hs | 2 +- services/brig/test/integration/API/User/Auth.hs | 2 +- services/brig/test/integration/API/User/Client.hs | 2 +- services/brig/test/integration/API/User/Connection.hs | 2 +- services/brig/test/integration/API/User/Handles.hs | 2 +- services/brig/test/integration/API/User/PasswordReset.hs | 2 +- services/brig/test/integration/API/User/RichInfo.hs | 2 +- 17 files changed, 17 insertions(+), 17 deletions(-) rename libs/types-common/src/{Wire => Util}/Timeout.hs (97%) diff --git a/libs/types-common/src/Wire/Timeout.hs b/libs/types-common/src/Util/Timeout.hs similarity index 97% rename from libs/types-common/src/Wire/Timeout.hs rename to libs/types-common/src/Util/Timeout.hs index 016c377eb23..e09c358e88d 100644 --- a/libs/types-common/src/Wire/Timeout.hs +++ b/libs/types-common/src/Util/Timeout.hs @@ -1,4 +1,4 @@ -module Wire.Timeout +module Util.Timeout ( Timeout (..), module Data.Time.Clock, ) diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index d1371245a96..77b3e7e528f 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -38,8 +38,8 @@ library Util.Options Util.Options.Common Util.Test + Util.Timeout Wire.Arbitrary - Wire.Timeout other-modules: Paths_types_common hs-source-dirs: src diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index b018a9c5538..4c42c4b1ad9 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -30,13 +30,13 @@ import Polysemy import Polysemy.TinyLog (TinyLog) import System.Logger.Message qualified as Log import URI.ByteString +import Util.Timeout import Wire.API.Team.Invitation (Invitation (inviteeEmail)) import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Role (Role, defaultRole) import Wire.API.User (EmailAddress, InvitationCode, Name) import Wire.Arbitrary (Arbitrary, GenericUniform (..)) import Wire.Sem.Logger qualified as Log -import Wire.Timeout data StoredInvitation = MkStoredInvitation { teamId :: TeamId, diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 2f9221a4edd..d7fc3d24b1e 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -13,10 +13,10 @@ import OpenSSL.Random (randBytes) import Polysemy import Polysemy.Embed import UnliftIO.Async (pooledMapConcurrentlyN_) +import Util.Timeout import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore -import Wire.Timeout interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor InvitationCodeStore r interpretInvitationCodeStoreToCassandra casClient = diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 4a7021bebce..838d43a192f 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -44,12 +44,12 @@ import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Polysemy import Text.Printf (printf) +import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password import Wire.PasswordResetCodeStore qualified as E import Wire.PasswordResetCodeStore.Cassandra -import Wire.Timeout import Wire.UserKeyStore -- | The information associated with the pending activation of a 'UserKey'. diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 2182535dc7f..31d586cf165 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -49,13 +49,13 @@ import Network.AMQP.Extended import Network.DNS qualified as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options +import Util.Timeout import Wire.API.Allowlists (AllowlistEmailDomains (..)) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version import Wire.API.Team.Feature import Wire.API.User import Wire.EmailSending.SMTP (SMTPConnType (..)) -import Wire.Timeout data ElasticSearchOpts = ElasticSearchOpts { -- | ElasticSearch URL diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index ac8e98a38be..eda8c9fe88f 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -65,6 +65,7 @@ import Servant qualified import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options +import Util.Timeout import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Public.Brig @@ -73,7 +74,6 @@ import Wire.API.Routes.Version.Wai import Wire.API.User (AccountStatus (PendingInvitation)) import Wire.DeleteQueue import Wire.Sem.Paging qualified as P -import Wire.Timeout import Wire.UserStore -- FUTUREWORK: If any of these async threads die, we will have no clue about it diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 149a17e3f58..ed72ce03fd1 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -67,6 +67,7 @@ import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) +import Util.Timeout import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public import Wire.API.User @@ -78,7 +79,6 @@ import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.Timeout import Wire.UserKeyStore import Wire.UserStore import Wire.VerificationCode qualified as VerificationCode diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index ca39068e9f2..f9f621ae4bb 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -57,10 +57,10 @@ import Imports import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log +import Util.Timeout import Web.Cookie qualified as WebCookie import Wire.API.User.Auth import Wire.SessionStore qualified as Store -import Wire.Timeout -------------------------------------------------------------------------------- -- Basic Cookie Management diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 65e1f1b324a..2eeea65b3e6 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -59,6 +59,7 @@ import URI.ByteString import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcurrently) import Util import Util.AWS as Util +import Util.Timeout import Web.Cookie (parseSetCookie, setCookieName) import Wire.API.Asset import Wire.API.Connection @@ -75,7 +76,6 @@ import Wire.API.Team.Size import Wire.API.User import Wire.API.User.Auth import Wire.API.User.Client (ClientType (PermanentClientType)) -import Wire.Timeout newtype TeamSizeLimit = TeamSizeLimit Word32 diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1f0a998e441..4772091981c 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -77,6 +77,7 @@ import Test.Tasty.HUnit import UnliftIO (mapConcurrently_) import Util import Util.AWS as Util +import Util.Timeout import Web.Cookie (parseSetCookie) import Wire.API.Asset hiding (Asset) import Wire.API.Asset qualified as Asset @@ -91,7 +92,6 @@ 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.Timeout tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree tests _ at opts p b c ch g aws userJournalWatcher = diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index fce6d5e5a2c..79b6ac62bf8 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -60,6 +60,7 @@ import Test.Tasty.HUnit import Test.Tasty.HUnit qualified as HUnit import UnliftIO.Async hiding (wait) import Util +import Util.Timeout import Wire.API.Conversation (Conversation (..)) import Wire.API.Password (Password, mkSafePasswordScrypt) import Wire.API.User as Public @@ -68,7 +69,6 @@ import Wire.API.User.Auth.LegalHold import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.API.User.Client -import Wire.Timeout -- | FUTUREWORK: Implement this function. This wrapper should make sure that -- wrapped tests run only when the feature flag 'legalhold' is set to diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 44e9f015399..fb6bf3fc06d 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -69,6 +69,7 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification import Wire.API.MLS.CipherSuite import Wire.API.Routes.Version @@ -82,7 +83,6 @@ import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (..), UserMap (..), WrappedQualifiedUserMap) import Wire.API.Wrapped (Wrapped (..)) -import Wire.Timeout import Wire.VerificationCode qualified as Code import Wire.VerificationCodeGen diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 14b3865a7bb..76aebdaff09 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -39,6 +39,7 @@ import Network.Wai.Utilities.Error qualified as Error import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Connection import Wire.API.Conversation import Wire.API.Federation.API.Brig @@ -46,7 +47,6 @@ import Wire.API.Federation.Component import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.MultiTablePaging import Wire.API.User as User -import Wire.Timeout tests :: ConnectionLimit -> diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 11a606a0e60..d94f3fbe00f 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -46,12 +46,12 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification hiding (target) import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Handle -import Wire.Timeout tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b c g = diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 31ebf1416ee..034c6c40ece 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -33,9 +33,9 @@ import Data.Misc import Imports import Test.Tasty hiding (Timeout) import Util +import Util.Timeout import Wire.API.User import Wire.API.User.Auth -import Wire.Timeout tests :: DB.ClientState -> diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 6fe06c37714..2ce2855a1cc 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -34,10 +34,10 @@ import Imports import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.RichInfo -import Wire.Timeout tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b _c g = From 86a9641364bb92adb93fb69c8758b65cbab260af Mon Sep 17 00:00:00 2001 From: Igor Ranieri <54423+elland@users.noreply.github.com> Date: Mon, 2 Sep 2024 09:49:15 +0200 Subject: [PATCH 31/96] Update changelog.d/5-internal/wpb-8887 --- changelog.d/5-internal/wpb-8887 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.d/5-internal/wpb-8887 b/changelog.d/5-internal/wpb-8887 index 43982b422a2..8858aac302d 100644 --- a/changelog.d/5-internal/wpb-8887 +++ b/changelog.d/5-internal/wpb-8887 @@ -1 +1 @@ -Migrated user invitation DB access to Subsystems. +Implemented GetBy* for complex account queries. From 34061ea2fc159f62c9b293b5c34a55f223d468ad Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 2 Sep 2024 09:49:28 +0200 Subject: [PATCH 32/96] Renamed lookupAccounts to getUsers. --- libs/wire-subsystems/src/Wire/UserStore.hs | 4 +--- .../src/Wire/UserStore/Cassandra.hs | 6 +++--- .../src/Wire/UserSubsystem/Interpreter.hs | 4 ++-- .../unit/Wire/MockInterpreters/UserStore.hs | 2 +- services/brig/src/Brig/API/User.hs | 17 ----------------- 5 files changed, 7 insertions(+), 26 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 39f822666ca..99fb8d1ce1e 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -47,6 +47,7 @@ data StoredUserUpdateError = StoredUserUpdateHandleExists -- database logic; validate handle is application logic.) data UserStore m a where GetUser :: UserId -> UserStore m (Maybe StoredUser) + GetUsers :: [UserId] -> UserStore m [StoredUser] UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) DeleteUser :: User -> UserStore m () @@ -63,9 +64,6 @@ data UserStore m a where -- an email address or phone number. IsActivated :: UserId -> UserStore m Bool LookupLocale :: UserId -> UserStore m (Maybe (Maybe Language, Maybe Country)) - -- | Look up accounts given user ids. For the purpose of the DB, Users and accounts are identical, so this - -- returns a @['StoredUser']@ - LookupAccounts :: [UserId] -> UserStore m [StoredUser] makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index a54a02126b2..59f847e2db5 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -18,6 +18,7 @@ interpretUserStoreCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case GetUser uid -> getUserImpl uid + GetUsers uids -> embed $ getUsersImpl uids UpdateUser uid update -> embed $ updateUserImpl uid update UpdateUserHandleEither uid update -> embed $ updateUserHandleEitherImpl uid update DeleteUser user -> embed $ deleteUserImpl user @@ -26,10 +27,9 @@ interpretUserStoreCassandra casClient = LookupStatus uid -> embed $ lookupStatusImpl uid IsActivated uid -> embed $ isActivatedImpl uid LookupLocale uid -> embed $ lookupLocaleImpl uid - LookupAccounts uids -> embed $ lookupAccountsImpl uids -lookupAccountsImpl :: [UserId] -> Client [StoredUser] -lookupAccountsImpl usrs = +getUsersImpl :: [UserId] -> Client [StoredUser] +getUsersImpl usrs = map asRecord <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index ea92056f5e5..dac7f67e280 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -556,14 +556,14 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByE accsByIds :: [UserAccount] <- wither accountValid - =<< lookupAccounts (nubOrd $ handleUserIds <> getByUserIds) + =<< getUsers (nubOrd $ handleUserIds <> getByUserIds) accsByEmail <- flip foldMap getByEmail \email -> do let ek = mkEmailKey email mactiveUid <- lookupKey ek ac <- lookupActivationCode ek let muidFromActivationKey = ac >>= fst - res <- lookupAccounts (nubOrd $ catMaybes [mactiveUid, muidFromActivationKey]) + res <- getUsers (nubOrd $ catMaybes [mactiveUid, muidFromActivationKey]) pure $ map storedToAcc diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 296f980a667..38d99d01e7b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -19,6 +19,7 @@ inMemoryUserStoreInterpreter :: InterpreterFor UserStore r inMemoryUserStoreInterpreter = interpret $ \case GetUser uid -> gets $ find (\user -> user.id == uid) + GetUsers TODO -> TODO UpdateUser uid update -> modify (map doUpdate) where doUpdate :: StoredUser -> StoredUser @@ -59,7 +60,6 @@ inMemoryUserStoreInterpreter = interpret $ \case LookupStatus uid -> lookupStatusImpl uid IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid - LookupAccounts TODO -> TODO lookupLocaleImpl :: (Member (State [StoredUser]) r) => UserId -> Sem r (Maybe ((Maybe Language, Maybe Country))) lookupLocaleImpl uid = do diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 088ebc7ecf9..4b7edf87604 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -33,7 +33,6 @@ module Brig.API.User changeSingleAccountStatus, Data.lookupAccounts, Data.lookupAccount, - lookupAccountsByIdentity, getLegalHoldStatus, Data.lookupName, Data.lookupUser, @@ -1127,22 +1126,6 @@ getLegalHoldStatus' user = teamMember <- GalleyAPIAccess.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember --- | Find user accounts for a given identity, both activated and those --- currently pending activation. -lookupAccountsByIdentity :: - (Member UserKeyStore r) => - EmailAddress -> - Bool -> - AppT r [UserAccount] -lookupAccountsByIdentity email includePendingInvitations = do - let uk = mkEmailKey email - activeUid <- liftSem $ lookupKey uk - uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) - result <- wrapClient $ Data.lookupAccounts (nub $ catMaybes [activeUid, uidFromKey]) - if includePendingInvitations - then pure result - else pure $ filter ((/= PendingInvitation) . accountStatus) result - isBlacklisted :: (Member BlockListStore r) => EmailAddress -> AppT r Bool isBlacklisted email = do let uk = mkEmailKey email From bfb00e1ebc070f691c87ee33aa11bbe986f297a0 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 2 Sep 2024 10:54:27 +0200 Subject: [PATCH 33/96] Added comments to similarly named functions. --- services/brig/src/Brig/Team/API.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 8ea5d4b4810..f3bd7122d86 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -424,9 +424,11 @@ suspendTeam :: (Handler r) NoContent suspendTeam tid = do lift $ liftSem $ Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) + -- Update the status of all users from the given team changeTeamAccountStatuses tid Suspended lift . liftSem $ do Store.deleteAllTeamInvitations tid + -- RPC to galley to change team status there GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing pure NoContent From 27f859f0d5a44714e2f0d1265b265677c483f555 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 2 Sep 2024 11:02:08 +0200 Subject: [PATCH 34/96] Restore behaviour for getInvitation. --- services/brig/src/Brig/Team/API.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index f3bd7122d86..4bbd19832ce 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -365,11 +365,12 @@ getInvitation :: InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do + ensurePermissions uid tid [AddTeamMember] + invitationM <- lift . liftSem $ Store.lookupInvitation tid iid case invitationM of Nothing -> pure Nothing Just invitation -> do - ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift . liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) From fbd48cb77eb55f9be3fc3711052968fa7d040567 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 2 Sep 2024 17:38:37 +0200 Subject: [PATCH 35/96] Make route names unique. --- libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs | 2 +- services/brig/src/Brig/API/OAuth.hs | 2 +- tools/stern/src/Stern/API.hs | 2 +- tools/stern/src/Stern/API/Routes.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs index 70d478643a0..78d4ddcbf0a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs @@ -39,7 +39,7 @@ type OAuthAPI = :> Post '[JSON] OAuthClientCredentials ) :<|> Named - "get-oauth-client" + "i-get-oauth-client" ( Summary "Get OAuth client by id" :> CanThrow 'OAuthFeatureDisabled :> CanThrow 'OAuthClientNotFound diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index 9e06bc14d4d..80326619a49 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -67,7 +67,7 @@ import Wire.Sem.Now qualified as Now internalOauthAPI :: ServerT I.OAuthAPI (Handler r) internalOauthAPI = Named @"create-oauth-client" registerOAuthClient - :<|> Named @"get-oauth-client" getOAuthClientById + :<|> Named @"i-get-oauth-client" getOAuthClientById :<|> Named @"update-oauth-client" updateOAuthClient :<|> Named @"delete-oauth-client" deleteOAuthClient diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index f5675118477..2e0f7d49efc 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -184,7 +184,7 @@ sitemap' = :<|> Named @"put-sso-domain-redirect" Intra.putSsoDomainRedirect :<|> Named @"delete-sso-domain-redirect" Intra.deleteSsoDomainRedirect :<|> Named @"register-oauth-client" Intra.registerOAuthClient - :<|> Named @"get-oauth-client" Intra.getOAuthClient + :<|> Named @"stern-get-oauth-client" Intra.getOAuthClient :<|> Named @"update-oauth-client" Intra.updateOAuthClient :<|> Named @"delete-oauth-client" Intra.deleteOAuthClient diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 38dba2f5817..3c78d30ebe5 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -411,7 +411,7 @@ type SternAPI = :> Post '[JSON] OAuthClientCredentials ) :<|> Named - "get-oauth-client" + "stern-get-oauth-client" ( Summary "Get OAuth client by id" :> "i" :> "oauth" From 5a5d9ee8a8e121c3dcd8b3d706b47b053b3e3530 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 2 Sep 2024 17:39:03 +0200 Subject: [PATCH 36/96] weeder. --- weeder.toml | 1 + 1 file changed, 1 insertion(+) diff --git a/weeder.toml b/weeder.toml index 4e17e0becfa..54609bfe871 100644 --- a/weeder.toml +++ b/weeder.toml @@ -125,6 +125,7 @@ roots = [ # may of the entries here are about general-purpose module "^Test.Data.Schema.userSchemaWithDefaultName'", "^Test.Federator.JSON.deriveJSONOptions", # This is used inside an instance derivation via TH "^Test.Wire.API.Golden.Run.main$", + "^Run.main$", "^Test.Wire.API.Password.testHashPasswordScrypt", # FUTUREWORK: reworking scrypt/argon2id is planned for next sprint "^TestSetup.runFederationClient", "^TestSetup.viewCargohold", From a581e6c4e7a8bae1b1a4b0a517554cb66cc420c6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 2 Sep 2024 17:43:21 +0200 Subject: [PATCH 37/96] one more helper function in UserSubsystem. --- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index c3924a8266d..6f00c9b1f45 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -116,3 +116,11 @@ getUserProfile luid targetUser = getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) + +getLocalUserAccount :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) +getLocalUserAccount uid = + listToMaybe + <$> getAccountsBy + ( qualifyAs uid $ + def {getByUserIds = [tUnqualified uid]} + ) From 954394d7471499faf0e57a54e70f50d63e92334f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 2 Sep 2024 23:03:37 +0200 Subject: [PATCH 38/96] Get local domain from api in some more places. [WIP] --- .../src/Wire/API/Routes/Internal/Galley.hs | 2 +- .../src/Wire/API/Routes/Public/Brig.hs | 8 +- .../src/Wire/API/Routes/Public/Brig/OAuth.hs | 12 +- .../Wire/PasswordResetCodeStore/Cassandra.hs | 16 ++- services/brig/src/Brig/API/Auth.hs | 25 ++++- services/brig/src/Brig/API/Client.hs | 22 ++-- services/brig/src/Brig/API/Connection.hs | 11 +- services/brig/src/Brig/API/Internal.hs | 12 +- services/brig/src/Brig/API/OAuth.hs | 49 +++++---- services/brig/src/Brig/API/Public.hs | 58 ++++++---- services/brig/src/Brig/API/User.hs | 46 +++++--- services/brig/src/Brig/App.hs | 6 +- services/brig/src/Brig/Data/Activation.hs | 42 +++++-- services/brig/src/Brig/Data/Client.hs | 29 +++-- services/brig/src/Brig/Data/User.hs | 103 +++++------------- .../brig/src/Brig/InternalEvent/Process.hs | 5 +- services/brig/src/Brig/Provider/API.hs | 12 +- services/brig/src/Brig/User/Auth.hs | 70 ++++++++---- services/galley/src/Galley/API/Internal.hs | 2 +- 19 files changed, 296 insertions(+), 234 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index fb4ab2cc9e5..22f23d50a31 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -566,7 +566,7 @@ type IMiscAPI = (RespondEmpty 200 "OK") ) :<|> Named - "add-bot" + "i-add-bot" ( -- This endpoint can lead to the following events being sent: -- - MemberJoin event to members CanThrow ('ActionDenied 'AddConversationMember) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 29f05a6b708..72afa66ff3b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -268,7 +268,7 @@ type UserAPI = "get-rich-info" ( Summary "Get a user's rich info" :> CanThrow 'InsufficientTeamPermissions - :> ZUser + :> ZLocalUser :> "users" :> CaptureUserId "uid" :> "rich-info" @@ -322,7 +322,7 @@ type SelfAPI = :> CanThrow 'MissingAuth :> CanThrow 'DeleteCodePending :> CanThrow 'OwnerDeletingSelf - :> ZUser + :> ZLocalUser :> "self" :> ReqBody '[JSON] DeleteUser :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout) @@ -743,7 +743,7 @@ type UserClientAPI = :> CanThrow 'MalformedPrekeys :> CanThrow 'CodeAuthenticationFailed :> CanThrow 'CodeAuthenticationRequired - :> ZUser + :> ZLocalUser :> ZConn :> "clients" :> ReqBody '[JSON] NewClient @@ -766,7 +766,7 @@ type UserClientAPI = :> CanThrow 'MalformedPrekeys :> CanThrow 'CodeAuthenticationFailed :> CanThrow 'CodeAuthenticationRequired - :> ZUser + :> ZLocalUser :> ZConn :> "clients" :> ReqBody '[JSON] NewClient diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs index 2db4a8320ec..19d20cd30f6 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs @@ -39,7 +39,7 @@ type OAuthAPI = ( Summary "Get OAuth client information" :> CanThrow 'OAuthFeatureDisabled :> CanThrow 'OAuthClientNotFound - :> ZUser + :> ZLocalUser :> "oauth" :> "clients" :> Capture' '[Description "The ID of the OAuth client"] "OAuthClientId" OAuthClientId @@ -55,7 +55,7 @@ type OAuthAPI = "create-oauth-auth-code" ( Summary "Create an OAuth authorization code" :> Description "Currently only supports the 'code' response type, which corresponds to the authorization code flow." - :> ZUser + :> ZLocalUser :> "oauth" :> "authorization" :> "codes" @@ -99,7 +99,7 @@ type OAuthAPI = "get-oauth-applications" ( Summary "Get OAuth applications with account access" :> Description "Get all OAuth applications with active account access for a user." - :> ZUser + :> ZLocalUser :> "oauth" :> "applications" :> MultiVerb1 @@ -110,7 +110,7 @@ type OAuthAPI = :<|> Named "revoke-oauth-account-access-v6" ( Summary "Revoke account access from an OAuth application" - :> ZUser + :> ZLocalUser :> Until 'V7 :> "oauth" :> "applications" @@ -125,7 +125,7 @@ type OAuthAPI = "revoke-oauth-account-access" ( Summary "Revoke account access from an OAuth application" :> CanThrow 'AccessDenied - :> ZUser + :> ZLocalUser :> From 'V7 :> "oauth" :> "applications" @@ -142,7 +142,7 @@ type OAuthAPI = "delete-oauth-refresh-token" ( Summary "Revoke an active OAuth session" :> Description "Revoke an active OAuth session by providing the refresh token ID." - :> ZUser + :> ZLocalUser :> CanThrow 'AccessDenied :> CanThrow 'OAuthClientNotFound :> "oauth" diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 74bdd0ca1f7..dbd16e8ceb7 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -19,6 +19,7 @@ module Wire.PasswordResetCodeStore.Cassandra ( passwordResetCodeStoreToCassandra, interpretClientToIO, + codeDeleteImpl, ) where @@ -58,12 +59,7 @@ passwordResetCodeStoreToCassandra = . write codeInsertQuery . params LocalQuorum $ (prk, prc, uid, runIdentity n, runIdentity ut, ttl) - CodeDelete prk -> - retry x5 - . write codeDeleteQuery - . params LocalQuorum - . Identity - $ prk + CodeDelete prk -> codeDeleteImpl prk where toRecord :: (PasswordResetCode, UserId, Maybe Int32, Maybe UTCTime) -> @@ -79,6 +75,14 @@ genPhoneCode = PasswordResetCode . unsafeFromText . pack . printf "%06d" <$> liftIO (randIntegerZeroToNMinusOne 1000000) +codeDeleteImpl :: (MonadClient m) => PasswordResetKey -> m () +codeDeleteImpl prk = + retry x5 + . write codeDeleteQuery + . params LocalQuorum + . Identity + $ prk + interpretClientToIO :: (Member (Final IO) r) => ClientState -> diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index cb167140ffb..eace1f730de 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -114,6 +114,7 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Login -> @@ -169,9 +170,16 @@ listCookies lusr (fold -> labels) = CookieList <$> wrapClientE (Auth.listCookies (tUnqualified lusr) (toList labels)) -removeCookies :: (Member TinyLog r, Member PasswordStore r) => Local UserId -> RemoveCookies -> Handler r () +removeCookies :: + ( Member TinyLog r, + Member PasswordStore r, + Member UserSubsystem r + ) => + Local UserId -> + RemoveCookies -> + Handler r () removeCookies lusr (RemoveCookies pw lls ids) = - Auth.revokeAccess (tUnqualified lusr) pw ids lls !>> authError + Auth.revokeAccess lusr pw ids lls !>> authError legalHoldLogin :: ( Member GalleyAPIAccess r, @@ -208,12 +216,19 @@ ssoLogin l (fromMaybe False -> persist) = do getLoginCode :: Phone -> Handler r PendingLoginCode getLoginCode _ = throwStd loginCodeNotFound -reauthenticate :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => UserId -> ReAuthUser -> Handler r () -reauthenticate uid body = do +reauthenticate :: + ( Member GalleyAPIAccess r, + Member VerificationCodeSubsystem r, + Member UserSubsystem r + ) => + Local UserId -> + ReAuthUser -> + Handler r () +reauthenticate luid@(tUnqualified -> uid) body = do wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError case reAuthCodeAction body of Just action -> - Auth.verifyCode (reAuthCode body) action uid + Auth.verifyCode (reAuthCode body) action luid `catchE` \case VerificationCodeRequired -> throwE $ reauthError ReAuthCodeVerificationRequired VerificationCodeNoPendingCode -> throwE $ reauthError ReAuthCodeVerificationNoPendingCode diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index eecc682427b..55d601e09b9 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -115,6 +115,7 @@ import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSubsystem import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) @@ -164,6 +165,7 @@ addClient :: ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member TinyLog r, Member DeleteQueue r, Member (Input (Local ())) r, @@ -172,7 +174,7 @@ addClient :: Member EmailSubsystem r, Member VerificationCodeSubsystem r ) => - UserId -> + Local UserId -> Maybe ConnId -> NewClient -> ExceptT ClientError (AppT r) Client @@ -191,16 +193,17 @@ addClientWithReAuthPolicy :: Member DeleteQueue r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Data.ReAuthPolicy -> - UserId -> + Local UserId -> Maybe ConnId -> NewClient -> ExceptT ClientError (AppT r) Client -addClientWithReAuthPolicy policy u con new = do - acc <- lift (wrapClient $ Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) pure - verifyCode (newClientVerificationCode new) (userId . accountUser $ acc) +addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do + usr <- (lift . liftSem $ getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new @@ -212,10 +215,9 @@ addClientWithReAuthPolicy policy u con new = do lhcaps = ClientSupportsLegalholdImplicitConsent (clt0, old, count) <- wrapClientE - (Data.addClientWithReAuthPolicy policy u clientId' new maxPermClients caps) + (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients caps) !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} - let usr = accountUser acc lift $ do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u (clientId clt) @@ -231,12 +233,12 @@ addClientWithReAuthPolicy policy u con new = do verifyCode :: Maybe Code.Value -> - UserId -> + Local UserId -> ExceptT ClientError (AppT r) () - verifyCode mbCode uid = + verifyCode mbCode luid1 = -- this only happens inside the login flow (in particular, when logging in from a new device) -- the code obtained for logging in is used a second time for adding the device - UserAuth.verifyCode mbCode Code.Login uid `catchE` \case + UserAuth.verifyCode mbCode Code.Login luid1 `catchE` \case VerificationCodeRequired -> throwE ClientCodeAuthenticationRequired VerificationCodeNoPendingCode -> throwE ClientCodeAuthenticationFailed VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index f718cd465d1..cb3ed7e3dd0 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -72,6 +72,7 @@ import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.UserStore +import Wire.UserSubsystem ensureNotSameTeam :: (Member GalleyAPIAccess r) => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do @@ -86,6 +87,7 @@ createConnection :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -106,6 +108,7 @@ createConnectionToLocalUser :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -116,7 +119,7 @@ createConnectionToLocalUser self conn target = do ensureNotSameAndActivated self (tUntagged target) noteT (InvalidUser (tUntagged target)) $ ensureIsActivated target - checkLegalholdPolicyConflict (tUnqualified self) (tUnqualified target) + checkLegalholdPolicyConflict self target ensureNotSameTeam self target s2o <- lift . wrapClient $ Data.lookupConnection self (tUntagged target) o2s <- lift . wrapClient $ Data.lookupConnection target (tUntagged self) @@ -194,9 +197,9 @@ createConnectionToLocalUser self conn target = do -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. checkLegalholdPolicyConflict :: - (Member GalleyAPIAccess r) => - UserId -> - UserId -> + (Member GalleyAPIAccess r, Member UserSubsystem r) => + Local UserId -> + Local UserId -> ExceptT ConnectionError (AppT r) () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 5b61c803233..0faac9ca06c 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -271,6 +271,7 @@ authAPI :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, @@ -281,7 +282,7 @@ authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) :<|> Named @"login-code" getLoginCode - :<|> Named @"reauthenticate" reauthenticate + :<|> Named @"reauthenticate" (\uid reauth -> qualifyLocal uid >>= \luid -> reauthenticate luid reauth) federationRemotesAPI :: (Member FederationConfigStore r) => ServerT BrigIRoutes.FederationRemotesAPI (Handler r) federationRemotesAPI = @@ -411,6 +412,7 @@ addClientInternalH :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => UserId -> @@ -422,7 +424,8 @@ addClientInternalH usr mSkipReAuth new connId = do let policy | mSkipReAuth == Just True = \_ _ -> False | otherwise = Data.reAuthForNewClients - API.addClientWithReAuthPolicy policy usr connId new !>> clientError + lusr <- qualifyLocal usr + API.addClientWithReAuthPolicy policy lusr connId new !>> clientError legalHoldClientRequestedH :: ( Member (Embed HttpClientIO) r, @@ -470,6 +473,7 @@ createUserNoVerify :: Member NotificationSubsystem r, Member InvitationCodeStore r, Member UserKeyStore r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -519,6 +523,7 @@ deleteUserNoAuthH :: Member UserStore r, Member TinyLog r, Member UserKeyStore r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, @@ -527,7 +532,8 @@ deleteUserNoAuthH :: UserId -> (Handler r) DeleteUserResponse deleteUserNoAuthH uid = do - r <- lift $ API.ensureAccountDeleted uid + luid <- qualifyLocal uid + r <- lift $ API.ensureAccountDeleted luid case r of NoUser -> throwStd (errorToWai @'E.UserNotFound) AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index 80326619a49..bd9eedc3f48 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -39,6 +39,7 @@ import Data.Id import Data.Json.Util (toUTCTimeMillis) import Data.Map qualified as Map import Data.Misc +import Data.Qualified import Data.Set qualified as Set import Data.Text.Ascii import Data.Text.Encoding qualified as T @@ -122,14 +123,14 @@ deleteOAuthClient cid = do void $ getOAuthClientById cid lift $ wrapClient $ deleteOAuthClient' cid -getOAuthClient :: UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient) +getOAuthClient :: Local UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient) getOAuthClient _ cid = do unlessM (Opt.setOAuthEnabled <$> view settings) $ throwStd $ errorToWai @'OAuthFeatureDisabled lift $ wrapClient $ lookupOauthClient cid -createNewOAuthAuthorizationCode :: UserId -> CreateOAuthAuthorizationCodeRequest -> (Handler r) CreateOAuthCodeResponse -createNewOAuthAuthorizationCode uid code = do - runExceptT (validateAndCreateAuthorizationCode uid code) >>= \case +createNewOAuthAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> (Handler r) CreateOAuthCodeResponse +createNewOAuthAuthorizationCode luid code = do + runExceptT (validateAndCreateAuthorizationCode luid code) >>= \case Right oauthCode -> pure $ CreateOAuthCodeSuccess $ @@ -174,11 +175,11 @@ data CreateNewOAuthCodeError | CreateNewOAuthCodeErrorUnsupportedResponseType | CreateNewOAuthCodeErrorRedirectUrlMissMatch -validateAndCreateAuthorizationCode :: UserId -> CreateOAuthAuthorizationCodeRequest -> ExceptT CreateNewOAuthCodeError (Handler r) OAuthAuthorizationCode -validateAndCreateAuthorizationCode uid (CreateOAuthAuthorizationCodeRequest cid scope responseType redirectUrl _state _ chal) = do +validateAndCreateAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> ExceptT CreateNewOAuthCodeError (Handler r) OAuthAuthorizationCode +validateAndCreateAuthorizationCode luid@(tUnqualified -> uid) (CreateOAuthAuthorizationCodeRequest cid scope responseType redirectUrl _state _ chal) = do failWithM CreateNewOAuthCodeErrorFeatureDisabled (assertMay . Opt.setOAuthEnabled <$> view settings) failWith CreateNewOAuthCodeErrorUnsupportedResponseType (assertMay $ responseType == OAuthResponseTypeCode) - client <- failWithM CreateNewOAuthCodeErrorClientNotFound $ getOAuthClient uid cid + client <- failWithM CreateNewOAuthCodeErrorClientNotFound $ getOAuthClient luid cid failWith CreateNewOAuthCodeErrorRedirectUrlMissMatch (assertMay $ client.redirectUrl == redirectUrl) lift mkAuthorizationCode where @@ -201,7 +202,8 @@ createAccessTokenWithRefreshToken req = do unless (req.grantType == OAuthGrantTypeRefreshToken) $ throwStd $ errorToWai @'OAuthInvalidGrantType key <- signingKey (OAuthRefreshTokenInfo _ cid uid scope _) <- lookupVerifyAndDeleteToken key req.refreshToken - void $ getOAuthClient uid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + let luid = undefined uid + void $ getOAuthClient luid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (cid == req.clientId) $ throwStd $ errorToWai @'OAuthInvalidClientCredentials createAccessToken key uid cid scope @@ -226,7 +228,8 @@ createAccessTokenWithAuthorizationCode req = do (cid, uid, scope, uri, mChal) <- lift (wrapClient $ lookupAndDeleteByOAuthAuthorizationCode req.code) >>= maybe (throwStd $ errorToWai @'OAuthAuthorizationCodeNotFound) pure - oauthClient <- getOAuthClient uid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + let luid = undefined uid + oauthClient <- getOAuthClient luid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (uri == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch unless (oauthClient.redirectUrl == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch @@ -305,7 +308,8 @@ revokeRefreshToken :: (Member Jwk r) => OAuthRevokeRefreshTokenRequest -> (Handl revokeRefreshToken req = do key <- signingKey info <- lookupAndVerifyToken key req.refreshToken - void $ getOAuthClient info.userId info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + let luid = undefined info.userId + void $ getOAuthClient luid info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure lift $ wrapClient $ deleteOAuthRefreshToken info.userId info.refreshTokenId lookupAndVerifyToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo @@ -316,8 +320,8 @@ lookupAndVerifyToken key = . lookupOAuthRefreshTokenInfo >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure -getOAuthApplications :: UserId -> (Handler r) [OAuthApplication] -getOAuthApplications uid = do +getOAuthApplications :: Local UserId -> (Handler r) [OAuthApplication] +getOAuthApplications (tUnqualified -> uid) = do activeRefreshTokens <- lift $ wrapClient $ lookupOAuthRefreshTokens uid toApplications activeRefreshTokens where @@ -325,26 +329,27 @@ getOAuthApplications uid = do toApplications infos = do let grouped = Map.fromListWith (<>) $ (\info -> (info.clientId, [info])) <$> infos mApps <- for (Map.toList grouped) $ \(cid, tokens) -> do - mClient <- getOAuthClient uid cid + let luid = undefined uid + mClient <- getOAuthClient luid cid pure $ (\client -> OAuthApplication cid client.name ((\i -> OAuthSession i.refreshTokenId (toUTCTimeMillis i.createdAt)) <$> tokens)) <$> mClient pure $ catMaybes mApps -revokeOAuthAccountAccessV6 :: UserId -> OAuthClientId -> (Handler r) () -revokeOAuthAccountAccessV6 uid cid = do +revokeOAuthAccountAccessV6 :: Local UserId -> OAuthClientId -> (Handler r) () +revokeOAuthAccountAccessV6 (tUnqualified -> uid) cid = do rts <- lift $ wrapClient $ lookupOAuthRefreshTokens uid for_ rts $ \rt -> when (rt.clientId == cid) $ lift $ wrapClient $ deleteOAuthRefreshToken uid rt.refreshTokenId -revokeOAuthAccountAccess :: UserId -> OAuthClientId -> PasswordReqBody -> (Handler r) () -revokeOAuthAccountAccess uid cid req = do - wrapClientE $ reauthenticate uid req.fromPasswordReqBody !>> toAccessDenied - revokeOAuthAccountAccessV6 uid cid +revokeOAuthAccountAccess :: Local UserId -> OAuthClientId -> PasswordReqBody -> (Handler r) () +revokeOAuthAccountAccess luid@(tUnqualified -> uid) cid req = do + wrapClientE (reauthenticate uid req.fromPasswordReqBody) !>> toAccessDenied + revokeOAuthAccountAccessV6 luid cid where toAccessDenied :: ReAuthError -> HttpError toAccessDenied _ = StdError $ errorToWai @'AccessDenied -deleteOAuthRefreshTokenById :: UserId -> OAuthClientId -> OAuthRefreshTokenId -> PasswordReqBody -> (Handler r) () -deleteOAuthRefreshTokenById uid cid tokenId req = do - wrapClientE $ reauthenticate uid req.fromPasswordReqBody !>> toAccessDenied +deleteOAuthRefreshTokenById :: Local UserId -> OAuthClientId -> OAuthRefreshTokenId -> PasswordReqBody -> (Handler r) () +deleteOAuthRefreshTokenById (tUnqualified -> uid) cid tokenId req = do + wrapClientE (reauthenticate uid req.fromPasswordReqBody) !>> toAccessDenied mInfo <- lift $ wrapClient $ lookupOAuthRefreshTokenInfo tokenId case mInfo of Nothing -> pure () diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 606ed55b5bb..70e2d6ebcbd 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -53,7 +53,6 @@ import Brig.Team.API qualified as Team import Brig.Team.Email qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra (UserAccount (UserAccount, accountUser)) -import Brig.Types.User (HavePendingInvitations (..)) import Brig.User.API.Handle qualified as Handle import Brig.User.API.Search (teamUserSearch) import Brig.User.API.Search qualified as Search @@ -163,7 +162,7 @@ import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) -import Wire.UserSubsystem qualified as UserSubsystem +import Wire.UserSubsystem qualified as User import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -561,17 +560,18 @@ addClient :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => - UserId -> + Local UserId -> ConnId -> Public.NewClient -> Handler r Public.Client -addClient usr con new = do +addClient lusr con new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ throwE (clientError ClientLegalHoldCannotBeAdded) - API.addClient usr (Just con) new + API.addClient lusr (Just con) new !>> clientError deleteClient :: @@ -625,21 +625,21 @@ getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) maybe (throwStd (errorToWai @'E.ClientNotFound)) (pure . Public.clientCapabilities) mclient -getRichInfo :: UserId -> UserId -> Handler r Public.RichInfoAssocList -getRichInfo self user = do +getRichInfo :: (Member UserSubsystem r) => Local UserId -> UserId -> Handler r Public.RichInfoAssocList +getRichInfo lself user = do + let luser = qualifyAs lself user -- Check that both users exist and the requesting user is allowed to see rich info of the -- other user - selfUser <- - ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations self) - otherUser <- - ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations user) + let fetch luid = + ifNothing (errorToWai @'E.UserNotFound) + =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount luid) + selfUser <- fetch lself + otherUser <- fetch luser case (Public.userTeam selfUser, Public.userTeam otherUser) of (Just t1, Just t2) | t1 == t2 -> pure () _ -> throwStd insufficientTeamPermissions -- Query rich info - wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo user + wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo (tUnqualified luser) getSupportedProtocols :: (Member UserSubsystem r) => @@ -693,6 +693,7 @@ createUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member EmailSending r ) => Public.NewUserPublic -> @@ -937,7 +938,7 @@ changeLocale lusr conn l = updateUserProfile lusr (Just conn) - UserSubsystem.UpdateOriginWireClient + User.UpdateOriginWireClient def {locale = Just l.luLocale} changeSupportedProtocols :: @@ -947,7 +948,7 @@ changeSupportedProtocols :: Public.SupportedProtocolUpdate -> Handler r () changeSupportedProtocols u conn (Public.SupportedProtocolUpdate prots) = - lift . liftSem $ UserSubsystem.updateUserProfile u (Just conn) UpdateOriginWireClient upd + lift . liftSem $ User.updateUserProfile u (Just conn) UpdateOriginWireClient upd where upd = def {supportedProtocols = Just prots} @@ -955,7 +956,7 @@ changeSupportedProtocols u conn (Public.SupportedProtocolUpdate prots) = -- *any* account.) checkHandle :: (Member UserSubsystem r) => UserId -> Text -> Handler r () checkHandle _uid hndl = - lift (liftSem $ UserSubsystem.checkHandle hndl) >>= \case + lift (liftSem $ User.checkHandle hndl) >>= \case API.CheckHandleFound -> pure () API.CheckHandleNotFound -> throwStd (errorToWai @'E.HandleNotFound) @@ -984,7 +985,7 @@ getHandleInfoUnqualifiedH self handle = do changeHandle :: (Member UserSubsystem r) => Local UserId -> ConnId -> Public.HandleUpdate -> Handler r () changeHandle u conn (Public.HandleUpdate h) = lift $ liftSem do - UserSubsystem.updateHandle u (Just conn) UpdateOriginWireClient h + User.updateHandle u (Just conn) UpdateOriginWireClient h beginPasswordReset :: (Member AuthenticationSubsystem r) => @@ -1044,6 +1045,7 @@ createConnectionUnqualified :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => UserId -> @@ -1060,6 +1062,7 @@ createConnection :: Member GalleyAPIAccess r, Member NotificationSubsystem r, Member UserStore r, + Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1175,19 +1178,21 @@ deleteSelfUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) -deleteSelfUser u body = do - API.deleteSelfUser u (Public.deleteUserPassword body) !>> deleteUserError +deleteSelfUser lu body = do + API.deleteSelfUser lu (Public.deleteUserPassword body) !>> deleteUserError verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member UserStore r, + Member UserSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member UserKeyStore r, @@ -1238,6 +1243,7 @@ activate :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -1255,6 +1261,7 @@ activateKey :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r @@ -1278,7 +1285,9 @@ sendVerificationCode :: forall r. ( Member GalleyAPIAccess r, Member UserKeyStore r, + Member (Input (Local ())) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Public.SendVerificationCode -> @@ -1304,9 +1313,10 @@ sendVerificationCode req = do _ -> pure () where getAccount :: Public.EmailAddress -> (Handler r) (Maybe UserAccount) - getAccount email = lift $ do - mbUserId <- liftSem $ lookupKey $ mkEmailKey email - join <$> wrapClient (Data.lookupAccount `traverse` mbUserId) + getAccount email = lift . liftSem $ do + mbUserId <- lookupKey $ mkEmailKey email + mbLUserId <- qualifyLocal' `traverse` mbUserId + join <$> User.getLocalUserAccount `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 4b7edf87604..78900ec2cd3 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -31,8 +31,6 @@ module Brig.API.User lookupHandle, changeAccountStatus, changeSingleAccountStatus, - Data.lookupAccounts, - Data.lookupAccount, getLegalHoldStatus, Data.lookupName, Data.lookupUser, @@ -98,6 +96,7 @@ import Control.Lens (preview, to, view, (^.), _Just) import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code +import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Handle (Handle (fromHandle)) import Data.Id as Id @@ -110,10 +109,10 @@ import Data.Qualified import Data.Range import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) -import Imports +import Imports hiding (local) import Network.Wai.Utilities import Polysemy -import Polysemy.Input (Input) +import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import Prometheus qualified as Prom @@ -263,6 +262,7 @@ createUser :: Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member UserKeyStore r, + Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, @@ -293,7 +293,8 @@ createUser new = do Nothing -> pure (Nothing, Nothing, Nothing) let mbInv = (.invitationId) . fst <$> teamInvitation - mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> wrapClient $ Data.lookupAccount (Id uuid)) + local :: Local () <- lift $ liftSem input + mbExistingAccount <- lift $ join <$> for mbInv (\someId -> liftSem $ User.getLocalUserAccount (qualifyAs local $ coerce someId)) let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -331,7 +332,7 @@ createUser new = do pure account - let uid = userId (accountUser account) + let uid = qUnqualified account.accountUser.userQualifiedId createUserTeam <- do activatedTeam <- lift $ do @@ -685,7 +686,8 @@ activate :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -701,6 +703,7 @@ activateWithCurrency :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => ActivationTarget -> @@ -717,7 +720,7 @@ activateWithCurrency tgt code usr cur = do field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") - event <- wrapClientE $ Data.activateKey key code usr + event <- Data.activateKey key code usr case event of Nothing -> pure ActivationPass Just e -> do @@ -871,6 +874,7 @@ deleteSelfUser :: Member (Embed HttpClientIO) r, Member UserKeyStore r, Member NotificationSubsystem r, + -- TODO: maybe delete? Member (Input (Local ())) r, Member PasswordStore r, Member UserStore r, @@ -878,13 +882,14 @@ deleteSelfUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) -deleteSelfUser uid pwd = do - account <- lift . wrapClient $ Data.lookupAccount uid +deleteSelfUser luid@(tUnqualified -> uid) pwd = do + account <- lift . liftSem $ User.getLocalUserAccount luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -950,6 +955,7 @@ verifyDeleteUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => VerifyDeleteUser -> @@ -959,7 +965,8 @@ verifyDeleteUser d = do let code = verifyDeleteUserCode d c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) - account <- lift . wrapClient $ Data.lookupAccount (Id a) + local :: Local () <- lift . liftSem $ input + account <- lift . liftSem $ User.getLocalUserAccount (qualifyAs local $ Id a) for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -977,12 +984,13 @@ ensureAccountDeleted :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member UserStore r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> AppT r DeleteUserResult -ensureAccountDeleted uid = do - mbAcc <- wrapClient $ lookupAccount uid +ensureAccountDeleted luid@(tUnqualified -> uid) = do + mbAcc <- liftSem $ User.getLocalUserAccount luid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1110,10 +1118,12 @@ enqueueMultiDeleteCallsCounter = } getLegalHoldStatus :: - (Member GalleyAPIAccess r) => - UserId -> + ( Member GalleyAPIAccess r, + Member UserSubsystem r + ) => + Local UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) +getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) =<< User.getLocalUserAccount uid getLegalHoldStatus' :: (Member GalleyAPIAccess r) => diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 1df8edefd8e..882204e28d7 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -108,7 +108,7 @@ import Brig.User.Search.Index (IndexEnv (..), MonadIndexIO (..), runIndexIO) import Brig.User.Template import Brig.ZAuth (MonadZAuth (..), runZAuth) import Brig.ZAuth qualified as ZAuth -import Cassandra (MonadClient, runClient) +import Cassandra (runClient) import Cassandra qualified as Cas import Cassandra.Util (initCassandraForService) import Control.AutoUpdate @@ -621,13 +621,13 @@ instance HasRequestId (AppT r) where -- Ad hoc interpreters -- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. -adhocUserKeyStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[UserKeyStore, UserStore, Embed IO] a -> m a +adhocUserKeyStoreInterpreter :: (MonadIO m, MonadReader Env m) => Sem '[UserKeyStore, UserStore, Embed IO] a -> m a adhocUserKeyStoreInterpreter action = do clientState <- asks (view casClient) liftIO $ runM . interpretUserStoreCassandra clientState . interpretUserKeyStoreCassandra clientState $ action -- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. -adhocSessionStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[SessionStore, Embed IO] a -> m a +adhocSessionStoreInterpreter :: (MonadIO m, MonadReader Env m) => Sem '[SessionStore, Embed IO] a -> m a adhocSessionStoreInterpreter action = do clientState <- asks (view casClient) liftIO $ runM . interpretSessionStoreCassandra clientState $ action diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 838d43a192f..0b990293e5a 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -29,12 +29,15 @@ module Brig.Data.Activation ) where -import Brig.App (Env, adhocUserKeyStoreInterpreter) +import Brig.App (AppT, adhocUserKeyStoreInterpreter, liftSem, settings, wrapClient, wrapClientE) import Brig.Data.User +import Brig.Options qualified as Opt import Brig.Types.Intra import Cassandra import Control.Error +import Control.Lens ((^.)) import Data.Id +import Data.Qualified import Data.Text (pack) import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding qualified as T @@ -48,9 +51,10 @@ import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password -import Wire.PasswordResetCodeStore qualified as E import Wire.PasswordResetCodeStore.Cassandra import Wire.UserKeyStore +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User -- | The information associated with the pending activation of a 'UserKey'. data Activation = Activation @@ -86,24 +90,29 @@ maxAttempts = 3 -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: - forall m. - (MonadClient m, MonadReader Env m) => + forall r. + ( Member UserSubsystem r + ) => ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError m (Maybe ActivationEvent) -activateKey k c u = verifyCode k c >>= pickUser >>= activate + ExceptT ActivationError (AppT r) (Maybe ActivationEvent) +activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate where + pickUser :: (t, Maybe UserId) -> ExceptT ActivationError (AppT r) (t, UserId) pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u') - activate (key :: EmailKey, uid) = do - a <- lift (lookupAccount uid) >>= maybe (throwE invalidUser) pure + + activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) + activate (key, uid) = do + dom <- lift $ asks (^. settings . Opt.federationDomain) + a <- lift (liftSem $ User.getLocalUserAccount (toLocalUnsafe dom uid)) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of Nothing -> do claim key uid let ident = EmailIdentity (emailKeyOrig key) - lift $ activateUser uid ident + wrapClientE (activateUser uid ident) let a' = a {accountUser = (accountUser a) {userIdentity = Just ident}} pure . Just $ AccountActivated a' Just _ -> do @@ -111,6 +120,13 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate profileNeedsUpdate = Just (emailKeyOrig key) /= userEmail usr oldKey :: Maybe EmailKey = mkEmailKey <$> userEmail usr in handleExistingIdentity uid profileNeedsUpdate oldKey key + + handleExistingIdentity :: + UserId -> + Bool -> + Maybe EmailKey -> + EmailKey -> + ExceptT ActivationError (AppT r) (Maybe ActivationEvent) handleExistingIdentity uid profileNeedsUpdate oldKey key | oldKey == Just key && not profileNeedsUpdate = pure Nothing -- activating existing key and exactly same profile @@ -120,15 +136,17 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do - lift (runM (passwordResetCodeStoreToCassandra @m @'[Embed m] (E.codeDelete (mkPasswordResetKey uid)))) + wrapClientE (codeDeleteImpl (mkPasswordResetKey uid)) claim key uid lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) for_ oldKey $ lift . adhocUserKeyStoreInterpreter . deleteKey pure . Just $ EmailActivated uid (emailKeyOrig key) where - updateEmailAndDeleteEmailUnvalidated :: UserId -> EmailAddress -> m () + updateEmailAndDeleteEmailUnvalidated :: UserId -> EmailAddress -> AppT r () updateEmailAndDeleteEmailUnvalidated u' email = - updateEmail u' email <* deleteEmailUnvalidated u' + wrapClient (updateEmail u' email <* deleteEmailUnvalidated u') + + claim :: EmailKey -> UserId -> ExceptT ActivationError (AppT r) () claim key uid = do ok <- lift $ adhocUserKeyStoreInterpreter (claimKey key uid) unless ok $ diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 4c0c2b3415c..9bae096a0f3 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -73,6 +73,7 @@ import Data.HashMap.Strict qualified as HashMap import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Map qualified as Map +import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time.Clock @@ -115,8 +116,10 @@ reAuthForNewClients :: ReAuthPolicy reAuthForNewClients count upsert = count > 0 && not upsert addClient :: - (MonadClient m, MonadReader Brig.App.Env m) => - UserId -> + ( MonadClient m, + MonadReader Brig.App.Env m + ) => + Local UserId -> ClientId -> NewClient -> Int -> @@ -125,26 +128,28 @@ addClient :: addClient = addClientWithReAuthPolicy reAuthForNewClients addClientWithReAuthPolicy :: - (MonadClient m, MonadReader Brig.App.Env m) => + ( MonadClient m, + MonadReader Brig.App.Env m + ) => ReAuthPolicy -> - UserId -> + Local UserId -> ClientId -> NewClient -> Int -> Maybe (Imports.Set ClientCapability) -> ExceptT ClientDataError m (Client, [Client], Word) addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients cps = do - clients <- lookupClients u + clients <- lookupClients (tUnqualified u) let typed = filter ((== newClientType c) . clientType) clients let count = length typed let upsert = any exists typed when (reAuthPolicy count upsert) $ fmapLT ClientReAuthError $ - User.reauthenticate u (newClientPassword c) + User.reauthenticate (tUnqualified u) (newClientPassword c) let capacity = fmap (+ (-count)) limit unless (maybe True (> 0) capacity || upsert) $ throwE TooManyClients - new <- insert + new <- insert (tUnqualified u) let !total = fromIntegral (length clients + if upsert then 0 else 1) let old = maybe (filter (not . exists) typed) (const []) limit pure (new, old, total) @@ -158,16 +163,16 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: (MonadClient m, MonadReader Brig.App.Env m) => ExceptT ClientDataError m Client - insert = do + insert :: (MonadClient m, MonadReader Brig.App.Env m) => UserId -> ExceptT ClientDataError m Client + insert uid = do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) let keys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c - updatePrekeys u newId keys + updatePrekeys uid newId keys let mdl = newClientModel c - prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, mdl, C.Set . Set.toList <$> cps) + prm = (uid, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, mdl, C.Set . Set.toList <$> cps) retry x5 $ write insertClient (params LocalQuorum prm) - addMLSPublicKeys u newId (Map.assocs (newClientMLSPublicKeys c)) + addMLSPublicKeys uid newId (Map.assocs (newClientMLSPublicKeys c)) pure $! Client { clientId = newId, diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index c128c294863..d58a705d604 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -32,8 +32,6 @@ module Brig.Data.User isSamlUser, -- * Lookups - lookupAccount, - lookupAccounts, lookupUser, lookupUsers, lookupName, @@ -202,7 +200,13 @@ authenticate u pw = -- | Password reauthentication. If the account has a password, reauthentication -- is mandatory. If the account has no password, or is an SSO user, and no password is given, -- reauthentication is a no-op. -reauthenticate :: (MonadClient m, MonadReader Env m) => UserId -> Maybe PlainTextPassword6 -> ExceptT ReAuthError m () +reauthenticate :: + ( MonadClient m, + MonadReader Env m + ) => + UserId -> + Maybe PlainTextPassword6 -> + ExceptT ReAuthError m () reauthenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE (ReAuthError AuthInvalidUser) @@ -214,17 +218,18 @@ reauthenticate u pw = Just (Just pw', Ephemeral) -> maybeReAuth pw' where maybeReAuth pw' = case pw of - Nothing -> unlessM (isSamlUser u) $ throwE ReAuthMissingPassword + Nothing -> do + musr <- lookupUser NoPendingInvitations u + unless (maybe False isSamlUser musr) $ throwE ReAuthMissingPassword Just p -> unless (verifyPassword p pw') $ throwE (ReAuthError AuthInvalidCredentials) -isSamlUser :: (MonadClient m, MonadReader Env m) => UserId -> m Bool -isSamlUser uid = do - account <- lookupAccount uid - case userIdentity . accountUser =<< account of - Just (SSOIdentity (UserSSOId _) _) -> pure True - _ -> pure False +isSamlUser :: User -> Bool +isSamlUser usr = do + case usr.userIdentity of + Just (SSOIdentity (UserSSOId _) _) -> True + _ -> False insertAccount :: (MonadClient m) => @@ -390,14 +395,14 @@ lookupUsers hpi usrs = do domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) -lookupAccount :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe UserAccount) -lookupAccount u = listToMaybe <$> lookupAccounts [u] - -lookupAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [UserAccount] -lookupAccounts usrs = do - loc <- setDefaultUserLocale <$> view settings - domain <- viewFederationDomain - fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) +-- lookupAccount :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe UserAccount) +-- lookupAccount u = listToMaybe <$> lookupAccounts [u] +-- +-- lookupAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [UserAccount] +-- lookupAccounts usrs = do +-- loc <- setDefaultUserLocale <$> view settings +-- domain <- viewFederationDomain +-- fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) lookupServiceUser :: (MonadClient m) => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) @@ -448,6 +453,8 @@ lookupFeatureConferenceCalling uid = do type Activated = Bool +-- UserRow is the same as AccountRow from the user subsystem. when migrating this code there, +-- consider eliminating it instead. type UserRow = ( UserId, Name, @@ -495,9 +502,6 @@ type UserRowInsert = deriving instance Show UserRowInsert --- Represents a 'UserAccount' -type AccountRow = UserRow - usersSelect :: PrepQuery R (Identity [UserId]) UserRow usersSelect = "SELECT id, name, text_status, picture, email, sso_id, accent_id, assets, \ @@ -523,13 +527,6 @@ richInfoSelectMulti = "SELECT user, json FROM rich_info WHERE user in ?" teamSelect :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId)) teamSelect = "SELECT team FROM user WHERE id = ?" -accountsSelect :: PrepQuery R (Identity [UserId]) AccountRow -accountsSelect = - "SELECT id, name, text_status, picture, email, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, \ - \service, handle, team, managed_by, supported_protocols \ - \FROM user WHERE id IN ?" - userInsert :: PrepQuery W UserRowInsert () userInsert = "INSERT INTO user (id, name, text_status, picture, assets, email, sso_id, \ @@ -570,56 +567,6 @@ userRichInfoUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE r ------------------------------------------------------------------------------- -- Conversions --- | Construct a 'UserAccount' from a raw user record in the database. -toUserAccount :: Domain -> Locale -> AccountRow -> UserAccount -toUserAccount - domain - defaultLocale - ( uid, - name, - textStatus, - pict, - email, - ssoid, - accent, - assets, - activated, - status, - expires, - lan, - con, - pid, - sid, - handle, - tid, - managed_by, - prots - ) = - let ident = toIdentity activated email ssoid - deleted = Just Deleted == status - expiration = if status == Just Ephemeral then expires else Nothing - loc = toLocale defaultLocale (lan, con) - svc = newServiceRef <$> sid <*> pid - in UserAccount - ( User - (Qualified uid domain) - ident - name - textStatus - (fromMaybe noPict pict) - (fromMaybe [] assets) - accent - deleted - loc - svc - handle - expiration - tid - (fromMaybe ManagedByWire managed_by) - (fromMaybe defSupportedProtocols prots) - ) - (fromMaybe Active status) - toUsers :: Domain -> Locale -> HavePendingInvitations -> [UserRow] -> [User] toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp where diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 899381faa23..b7effed797b 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -44,6 +44,7 @@ import Wire.Sem.Delay import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore (UserStore) +import Wire.UserSubsystem -- | Handle an internal event. -- @@ -58,6 +59,7 @@ onEvent :: Member UserKeyStore r, Member (Input UTCTime) r, Member UserStore r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r, Member PropertySubsystem r ) => @@ -71,7 +73,8 @@ onEvent n = handleTimeout $ case n of Log.info $ msg (val "Processing user delete event") ~~ field "user" (toByteString uid) - embed (API.lookupAccount uid) >>= mapM_ API.deleteAccount + luid <- qualifyLocal' uid + getLocalUserAccount luid >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index bbd0e6f6940..44eb3c26b56 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -214,7 +214,14 @@ newAccount new = do lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKey :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) +activateAccountKey :: + ( Member GalleyAPIAccess r, + Member EmailSending r, + Member VerificationCodeSubsystem r + ) => + Code.Key -> + Code.Value -> + (Handler r) (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do guardSecondFactorDisabled Nothing c <- (lift . liftSem $ verifyCode key IdentityVerification val) >>= maybeInvalidCode @@ -678,7 +685,8 @@ addBot zuid zcon cid add = do -- if we want to protect bots against lh, 'addClient' cannot just send lh capability -- implicitly in the next line. pure $ FutureWork @'UnprotectedBot undefined - wrapClientE (User.addClient (botUserId bid) bcl newClt maxPermClients (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent)) + lbid <- qualifyLocal (botUserId bid) + wrapClientE (User.addClient lbid bcl newClt maxPermClients (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent)) !>> const (StdError $ badGatewayWith "MalformedPrekeys") -- Add the bot to the conversation diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index ed72ce03fd1..4c15e449ae5 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -58,7 +58,7 @@ import Data.List.NonEmpty qualified as NE import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Misc (PlainTextPassword6) -import Data.Qualified (Local) +import Data.Qualified import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) @@ -81,6 +81,7 @@ import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore +import Wire.UserSubsystem import Wire.VerificationCode qualified as VerificationCode import Wire.VerificationCodeGen qualified as VerificationCodeGen import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) @@ -98,6 +99,7 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Login -> @@ -117,8 +119,9 @@ login (MkLogin li pw label code) typ = do newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label where verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) () - verifyLoginCode mbCode uid = - verifyCode mbCode Login uid + verifyLoginCode mbCode uid = do + luid <- lift $ qualifyLocal uid + verifyCode mbCode Login luid `catchE` \case VerificationCodeNoPendingCode -> wrapHttpClientE $ loginFailedWith LoginCodeInvalid uid VerificationCodeRequired -> wrapHttpClientE $ loginFailedWith LoginCodeRequired uid @@ -126,17 +129,18 @@ login (MkLogin li pw label code) typ = do verifyCode :: forall r. - (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => + (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r, Member UserSubsystem r) => Maybe Code.Value -> VerificationAction -> - UserId -> + Local UserId -> ExceptT VerificationCodeError (AppT r) () -verifyCode mbCode action uid = do - (mbEmail, mbTeamId) <- getEmailAndTeamId uid +verifyCode mbCode action luid = do + (mbEmail, mbTeamId) <- getEmailAndTeamId luid featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid + account <- lift . liftSem $ getLocalUserAccount luid + let isSsoUser = maybe False Data.isSamlUser ((.accountUser) <$> account) when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do @@ -148,10 +152,10 @@ verifyCode mbCode action uid = do (_, Nothing) -> throwE VerificationCodeNoEmail where getEmailAndTeamId :: - UserId -> + Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- wrapHttpClientE $ Data.lookupAccount u + mbAccount <- lift . liftSem $ getLocalUserAccount u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -217,15 +221,21 @@ renewAccess uts at mcid = do pure $ Access at' ck' revokeAccess :: - (Member TinyLog r, Member PasswordStore r) => - UserId -> + ( Member TinyLog r, + Member PasswordStore r, + Member UserSubsystem r + ) => + Local UserId -> PlainTextPassword6 -> [CookieId] -> [CookieLabel] -> ExceptT AuthError (AppT r) () -revokeAccess u pw cc ll = do +revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") - unlessM (lift . wrapHttpClient $ Data.isSamlUser u) $ Data.authenticate u pw + isSaml <- lift . liftSem $ do + account <- getLocalUserAccount luid + pure $ maybe False Data.isSamlUser ((.accountUser) <$> account) + unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll -------------------------------------------------------------------------------- @@ -282,32 +292,48 @@ newAccess uid cid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing pure $ Access t (Just ck) -resolveLoginId :: (Member UserKeyStore r, Member UserStore r) => LoginId -> ExceptT LoginError (AppT r) UserId +resolveLoginId :: + ( Member UserKeyStore r, + Member UserStore r, + Member UserSubsystem r, + Member (Input (Local ())) r + ) => + LoginId -> + ExceptT LoginError (AppT r) UserId resolveLoginId li = do - usr <- wrapClientE (validateLoginId li) >>= lift . either (liftSem . lookupKey) (liftSem . lookupHandle) + usr <- validateLoginId li >>= lift . liftSem . either lookupKey lookupHandle case usr of Nothing -> do - pending <- wrapClientE $ isPendingActivation li + pending <- lift $ isPendingActivation li throwE $ if pending then LoginPendingActivation else LoginFailed Just uid -> pure uid -validateLoginId :: (MonadReader Env m) => LoginId -> ExceptT LoginError m (Either EmailKey Handle) +validateLoginId :: (Applicative m) => LoginId -> m (Either EmailKey Handle) validateLoginId (LoginByEmail email) = (pure . Left . mkEmailKey) email validateLoginId (LoginByHandle h) = (pure . Right) h -isPendingActivation :: (MonadClient m, MonadReader Env m) => LoginId -> m Bool +isPendingActivation :: + forall r. + (Member UserSubsystem r, Member (Input (Local ())) r) => + LoginId -> + AppT r Bool isPendingActivation ident = case ident of (LoginByHandle _) -> pure False (LoginByEmail e) -> checkKey (mkEmailKey e) where + checkKey :: EmailKey -> AppT r Bool checkKey k = do - usr <- (>>= fst) <$> Data.lookupActivationCode k - case usr of + musr <- (>>= fst) <$> wrapClient (Data.lookupActivationCode k) + case musr of Nothing -> pure False - Just u -> maybe False (checkAccount k) <$> Data.lookupAccount u + Just usr -> liftSem do + lusr <- qualifyLocal' usr + maybe False (checkAccount k) <$> getLocalUserAccount lusr + + checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = let i = userIdentity (accountUser a) statusAdmitsPending = case accountStatus a of diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 12a6ff05ac5..1782a635e1d 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -229,7 +229,7 @@ miscAPI = <@> mkNamedAPI @"test-delete-client" Clients.rmClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService - <@> mkNamedAPI @"add-bot" Update.addBot + <@> mkNamedAPI @"i-add-bot" Update.addBot <@> mkNamedAPI @"delete-bot" Update.rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend From 90ad39c6fcecda4b7e600a1bcfc618a61f5f0722 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 09:10:55 +0200 Subject: [PATCH 39/96] Cleaned up. --- .../src/Wire/PasswordResetCodeStore/Cassandra.hs | 1 + services/brig/src/Brig/API/Client.hs | 5 +++-- services/brig/src/Brig/API/Internal.hs | 2 ++ services/brig/src/Brig/API/OAuth.hs | 6 +++--- services/brig/src/Brig/API/User.hs | 15 +++++++++------ services/brig/src/Brig/Data/Activation.hs | 1 + services/brig/src/Brig/Data/User.hs | 9 --------- services/brig/src/Brig/User/Auth.hs | 11 ++++++----- 8 files changed, 25 insertions(+), 25 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index dbd16e8ceb7..be9b7571b4c 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -19,6 +19,7 @@ module Wire.PasswordResetCodeStore.Cassandra ( passwordResetCodeStoreToCassandra, interpretClientToIO, + -- Temporary measure until we create AuthSubsystem codeDeleteImpl, ) where diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 55d601e09b9..feb122a2eb5 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -115,7 +115,8 @@ import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.UserSubsystem +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) @@ -202,7 +203,7 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- (lift . liftSem $ getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + usr <- (lift . liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 0faac9ca06c..89c2cb551b2 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -282,6 +282,8 @@ authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) :<|> Named @"login-code" getLoginCode + -- We qualify in place to avoid changing the internal API too much + -- FUTUREWORK? :<|> Named @"reauthenticate" (\uid reauth -> qualifyLocal uid >>= \luid -> reauthenticate luid reauth) federationRemotesAPI :: (Member FederationConfigStore r) => ServerT BrigIRoutes.FederationRemotesAPI (Handler r) diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index bd9eedc3f48..145d0772959 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -202,7 +202,7 @@ createAccessTokenWithRefreshToken req = do unless (req.grantType == OAuthGrantTypeRefreshToken) $ throwStd $ errorToWai @'OAuthInvalidGrantType key <- signingKey (OAuthRefreshTokenInfo _ cid uid scope _) <- lookupVerifyAndDeleteToken key req.refreshToken - let luid = undefined uid + luid <- qualifyLocal uid void $ getOAuthClient luid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (cid == req.clientId) $ throwStd $ errorToWai @'OAuthInvalidClientCredentials createAccessToken key uid cid scope @@ -228,7 +228,7 @@ createAccessTokenWithAuthorizationCode req = do (cid, uid, scope, uri, mChal) <- lift (wrapClient $ lookupAndDeleteByOAuthAuthorizationCode req.code) >>= maybe (throwStd $ errorToWai @'OAuthAuthorizationCodeNotFound) pure - let luid = undefined uid + luid <- qualifyLocal uid oauthClient <- getOAuthClient luid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (uri == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch @@ -308,7 +308,7 @@ revokeRefreshToken :: (Member Jwk r) => OAuthRevokeRefreshTokenRequest -> (Handl revokeRefreshToken req = do key <- signingKey info <- lookupAndVerifyToken key req.refreshToken - let luid = undefined info.userId + luid <- qualifyLocal info.userId void $ getOAuthClient luid info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure lift $ wrapClient $ deleteOAuthRefreshToken info.userId info.refreshTokenId diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 78900ec2cd3..94393d406ca 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -112,7 +112,7 @@ import Data.UUID.V4 (nextRandom) import Imports hiding (local) import Network.Wai.Utilities import Polysemy -import Polysemy.Input (Input, input) +import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import Prometheus qualified as Prom @@ -293,8 +293,12 @@ createUser new = do Nothing -> pure (Nothing, Nothing, Nothing) let mbInv = (.invitationId) . fst <$> teamInvitation - local :: Local () <- lift $ liftSem input - mbExistingAccount <- lift $ join <$> for mbInv (\someId -> liftSem $ User.getLocalUserAccount (qualifyAs local $ coerce someId)) + mbExistingAccount <- + lift $ + join <$> for mbInv do + \invid -> liftSem $ do + luid <- qualifyLocal' (coerce invid) + User.getLocalUserAccount luid let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -874,7 +878,6 @@ deleteSelfUser :: Member (Embed HttpClientIO) r, Member UserKeyStore r, Member NotificationSubsystem r, - -- TODO: maybe delete? Member (Input (Local ())) r, Member PasswordStore r, Member UserStore r, @@ -965,8 +968,8 @@ verifyDeleteUser d = do let code = verifyDeleteUserCode d c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) - local :: Local () <- lift . liftSem $ input - account <- lift . liftSem $ User.getLocalUserAccount (qualifyAs local $ Id a) + luid <- qualifyLocal $ Id a + account <- lift . liftSem $ User.getLocalUserAccount luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 0b990293e5a..a21a538ac58 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -136,6 +136,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do + -- Temporary measure until we create AuthSubsystem wrapClientE (codeDeleteImpl (mkPasswordResetKey uid)) claim key uid lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index d58a705d604..d0e61be1260 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -395,15 +395,6 @@ lookupUsers hpi usrs = do domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) --- lookupAccount :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe UserAccount) --- lookupAccount u = listToMaybe <$> lookupAccounts [u] --- --- lookupAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [UserAccount] --- lookupAccounts usrs = do --- loc <- setDefaultUserLocale <$> view settings --- domain <- viewFederationDomain --- fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) - lookupServiceUser :: (MonadClient m) => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 4c15e449ae5..a46539d4e85 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -81,7 +81,8 @@ import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore -import Wire.UserSubsystem +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User import Wire.VerificationCode qualified as VerificationCode import Wire.VerificationCodeGen qualified as VerificationCodeGen import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) @@ -139,7 +140,7 @@ verifyCode mbCode action luid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ getLocalUserAccount luid + account <- lift . liftSem $ User.getLocalUserAccount luid let isSsoUser = maybe False Data.isSamlUser ((.accountUser) <$> account) when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -155,7 +156,7 @@ verifyCode mbCode action luid = do Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ getLocalUserAccount u + mbAccount <- lift . liftSem $ User.getLocalUserAccount u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -233,7 +234,7 @@ revokeAccess :: revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do - account <- getLocalUserAccount luid + account <- User.getLocalUserAccount luid pure $ maybe False Data.isSamlUser ((.accountUser) <$> account) unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll @@ -331,7 +332,7 @@ isPendingActivation ident = case ident of Nothing -> pure False Just usr -> liftSem do lusr <- qualifyLocal' usr - maybe False (checkAccount k) <$> getLocalUserAccount lusr + maybe False (checkAccount k) <$> User.getLocalUserAccount lusr checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = From f6c0f9b6c55ab54bbd0404384a391eb996df04e3 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 09:18:05 +0200 Subject: [PATCH 40/96] Lint --- services/brig/src/Brig/User/Auth.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index a46539d4e85..d27ad90bf60 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -141,7 +141,7 @@ verifyCode mbCode action luid = do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled account <- lift . liftSem $ User.getLocalUserAccount luid - let isSsoUser = maybe False Data.isSamlUser ((.accountUser) <$> account) + let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do @@ -235,7 +235,7 @@ revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do account <- User.getLocalUserAccount luid - pure $ maybe False Data.isSamlUser ((.accountUser) <$> account) + pure $ maybe False (Data.isSamlUser . ((.accountUser))) account unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll From ac6e48de6c7b6cb90acd990cb3cab409842925ca Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 09:44:33 +0200 Subject: [PATCH 41/96] WIP: Remove extra Timeout type --- libs/types-common/src/Data/Code.hs | 14 ++++++-- libs/types-common/src/Util/Timeout.hs | 32 ------------------- libs/types-common/types-common.cabal | 2 -- libs/wire-api/src/Wire/API/User/Auth.hs | 1 - libs/wire-api/src/Wire/API/User/Scim.hs | 1 - .../src/Wire/InvitationCodeStore.hs | 3 +- .../src/Wire/InvitationCodeStore/Cassandra.hs | 2 +- services/brig/src/Brig/API/Client.hs | 1 - services/brig/src/Brig/API/User.hs | 1 - services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/Options.hs | 2 +- services/brig/src/Brig/Run.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 5 ++- services/brig/src/Brig/User/Auth/Cookie.hs | 3 +- services/brig/test/integration/API/Team.hs | 2 +- .../brig/test/integration/API/User/Account.hs | 3 +- .../brig/test/integration/API/User/Auth.hs | 4 +-- .../brig/test/integration/API/User/Client.hs | 3 +- .../test/integration/API/User/Connection.hs | 2 +- .../brig/test/integration/API/User/Handles.hs | 2 +- .../integration/API/User/PasswordReset.hs | 4 +-- .../test/integration/API/User/RichInfo.hs | 2 +- services/galley/src/Galley/API/Update.hs | 1 - 23 files changed, 32 insertions(+), 62 deletions(-) delete mode 100644 libs/types-common/src/Util/Timeout.hs diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index 6bba1c5f087..ba7dadcf2d3 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -22,7 +22,11 @@ -- with this program. If not, see . -- | Types for verification codes. -module Data.Code where +module Data.Code + ( module Data.Code, + module Data.Time.Clock, + ) +where import Cassandra hiding (Value) import Data.Aeson qualified as A @@ -92,7 +96,7 @@ instance ToHttpApiData Value where -- number of seconds remaining. newtype Timeout = Timeout {timeoutDiffTime :: NominalDiffTime} - deriving (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) + deriving newtype (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Timeout) instance ToSchema Timeout where @@ -101,6 +105,12 @@ instance ToSchema Timeout where roundDiffTime :: NominalDiffTime -> Int32 roundDiffTime = round +instance Read Timeout where + readsPrec i s = + case readsPrec i s of + [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] + _ -> [] + -- | A 'Timeout' is rendered as an integer representing the number of seconds remaining. instance ToByteString Timeout where builder (Timeout t) = builder (round t :: Int32) diff --git a/libs/types-common/src/Util/Timeout.hs b/libs/types-common/src/Util/Timeout.hs deleted file mode 100644 index e09c358e88d..00000000000 --- a/libs/types-common/src/Util/Timeout.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Util.Timeout - ( Timeout (..), - module Data.Time.Clock, - ) -where - -import Data.Aeson -import Data.Aeson.Types -import Data.Scientific -import Data.Time.Clock -import Imports - -newtype Timeout = Timeout - { timeoutDiff :: NominalDiffTime - } - deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) - -instance Read Timeout where - readsPrec i s = - case readsPrec i s of - [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] - _ -> [] - -instance FromJSON Timeout where - parseJSON (Number n) = - let defaultV = 3600 - bounded = toBoundedInteger n :: Maybe Int64 - in pure $ - Timeout $ - fromIntegral @Int $ - maybe defaultV fromIntegral bounded - parseJSON v = typeMismatch "activationTimeout" v diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 77b3e7e528f..5fb1c0ca72c 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -38,7 +38,6 @@ library Util.Options Util.Options.Common Util.Test - Util.Timeout Wire.Arbitrary other-modules: Paths_types_common @@ -126,7 +125,6 @@ library , quickcheck-instances >=0.3.16 , random >=1.1 , schema-profunctor - , scientific , servant-server , tagged >=0.8 , tasty >=0.11 diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index e395fece0e6..e5c7e48ac41 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -77,7 +77,6 @@ import Data.Schema import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Lazy.Encoding qualified as LT -import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra hiding (first) import Data.ZAuth.Token (header, time) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 50f0c95b15d..8c8f98f880e 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -63,7 +63,6 @@ import Data.OpenApi hiding (Operation) import Data.Proxy import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time.Clock (UTCTime) import Imports import SAML2.WebSSO qualified as SAML import SAML2.WebSSO.Test.Arbitrary () diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 4c42c4b1ad9..5d2a4d80de7 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -21,6 +21,7 @@ module Wire.InvitationCodeStore where import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.Code import Data.Id (InvitationId, TeamId, UserId) import Data.Json.Util (UTCTimeMillis) import Data.Range (Range) @@ -30,7 +31,6 @@ import Polysemy import Polysemy.TinyLog (TinyLog) import System.Logger.Message qualified as Log import URI.ByteString -import Util.Timeout import Wire.API.Team.Invitation (Invitation (inviteeEmail)) import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Role (Role, defaultRole) @@ -57,7 +57,6 @@ data StoredInvitationInfo = MkStoredInvitationInfo { teamId :: TeamId, invitationId :: InvitationId, code :: InvitationCode - -- TODO(mangoiv): maybe we can drop this last element } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform StoredInvitationInfo) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index d7fc3d24b1e..e9d40711ea6 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -1,6 +1,7 @@ module Wire.InvitationCodeStore.Cassandra where import Cassandra +import Data.Code import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as Conduit import Data.Id @@ -13,7 +14,6 @@ import OpenSSL.Random (randBytes) import Polysemy import Polysemy.Embed import UnliftIO.Async (pooledMapConcurrentlyN_) -import Util.Timeout import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index feb122a2eb5..d1cfebe9998 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -83,7 +83,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error -import Data.Time.Clock (UTCTime) import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 94393d406ca..605f3a57d68 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -107,7 +107,6 @@ import Data.List1 as List1 (List1, singleton) import Data.Misc import Data.Qualified import Data.Range -import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) import Imports hiding (local) import Network.Wai.Utilities diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index a21a538ac58..aeb09cbe401 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -36,6 +36,7 @@ import Brig.Types.Intra import Cassandra import Control.Error import Control.Lens ((^.)) +import Data.Code import Data.Id import Data.Qualified import Data.Text (pack) @@ -47,7 +48,6 @@ import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Polysemy import Text.Printf (printf) -import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 31d586cf165..721152585ca 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -32,6 +32,7 @@ import Control.Lens qualified as Lens import Data.Aeson import Data.Aeson.Types qualified as A import Data.Char qualified as Char +import Data.Code import Data.Code qualified as Code import Data.Default import Data.Domain (Domain (..)) @@ -49,7 +50,6 @@ import Network.AMQP.Extended import Network.DNS qualified as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options -import Util.Timeout import Wire.API.Allowlists (AllowlistEmailDomains (..)) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index eda8c9fe88f..ef6a9cf2978 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -46,6 +46,7 @@ import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (randomRIO) import Data.Aeson qualified as Aeson import Data.ByteString.UTF8 qualified as UTF8 +import Data.Code import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) @@ -65,7 +66,6 @@ import Servant qualified import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options -import Util.Timeout import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Public.Brig diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index d27ad90bf60..fa4ca7f292c 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -50,7 +50,7 @@ import Cassandra import Control.Error hiding (bool) import Control.Lens (to, view) import Data.ByteString.Conversion (toByteString) -import Data.Code qualified as Code +import Data.Code as Code import Data.Default import Data.Handle (Handle) import Data.Id @@ -67,7 +67,6 @@ import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) -import Util.Timeout import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public import Wire.API.User @@ -182,7 +181,7 @@ withRetryLimit action uid = do let bkey = BudgetKey ("login#" <> idToText uid) budget = Budget - (timeoutDiff $ Opt.timeout opts) + (timeoutDiffTime $ Opt.timeout opts) (fromIntegral $ Opt.retryLimit opts) bresult <- action bkey budget case bresult of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index f9f621ae4bb..35bee4e9f14 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -48,16 +48,15 @@ import Control.Error import Control.Lens (to, view) import Control.Monad.Except import Data.ByteString.Conversion +import Data.Code import Data.Id import Data.List qualified as List import Data.Proxy import Data.RetryAfter -import Data.Time.Clock import Imports import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log -import Util.Timeout import Web.Cookie qualified as WebCookie import Wire.API.User.Auth import Wire.SessionStore qualified as Store diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 2eeea65b3e6..bbc862b964b 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -35,6 +35,7 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) +import Data.Code import Data.Default (def) import Data.Either.Extra (eitherToMaybe) import Data.Id @@ -59,7 +60,6 @@ import URI.ByteString import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcurrently) import Util import Util.AWS as Util -import Util.Timeout import Web.Cookie (parseSetCookie, setCookieName) import Wire.API.Asset import Wire.API.Connection diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 4772091981c..e7e8dbec0df 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -43,6 +43,7 @@ import Data.Aeson.Lens qualified as AesonL import Data.ByteString qualified as C8 import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion +import Data.Code (Timeout, UTCTime, diffUTCTime) import Data.Domain import Data.Handle import Data.Id @@ -59,6 +60,7 @@ import Data.String.Conversions import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding qualified as T +import Data.Time (getCurrentTime) import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUID import Federator.MockServer (FederatedRequest (..), MockException (..)) @@ -77,7 +79,6 @@ import Test.Tasty.HUnit import UnliftIO (mapConcurrently_) import Util import Util.AWS as Util -import Util.Timeout import Web.Cookie (parseSetCookie) import Wire.API.Asset hiding (Asset) import Wire.API.Asset qualified as Asset diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 79b6ac62bf8..1da57d53fda 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -40,6 +40,7 @@ import Data.Aeson as Aeson hiding (json) import Data.ByteString qualified as BS import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as Lazy +import Data.Code (Timeout (..)) import Data.Handle (parseHandle) import Data.Id import Data.Misc (PlainTextPassword6, plainTextPassword6, plainTextPassword6Unsafe) @@ -60,7 +61,6 @@ import Test.Tasty.HUnit import Test.Tasty.HUnit qualified as HUnit import UnliftIO.Async hiding (wait) import Util -import Util.Timeout import Wire.API.Conversation (Conversation (..)) import Wire.API.Password (Password, mkSafePasswordScrypt) import Wire.API.User as Public @@ -1046,7 +1046,7 @@ testSuspendInactiveUsers config brig cookieType endPoint = do do diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index fb6bf3fc06d..cd0e3fd1816 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -40,6 +40,7 @@ import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as M import Data.Aeson.Lens import Data.ByteString.Conversion +import Data.Code (Timeout) import Data.Code qualified as Code import Data.Coerce (coerce) import Data.Default @@ -55,6 +56,7 @@ import Data.Set qualified as Set import Data.String.Conversions import Data.Text.Ascii (AsciiChars (validate), encodeBase64UrlUnpadded, toText) import Data.Text.Encoding qualified as T +import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import Data.UUID (toByteString) import Data.UUID qualified as UUID @@ -69,7 +71,6 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util -import Util.Timeout import Wire.API.Internal.Notification import Wire.API.MLS.CipherSuite import Wire.API.Routes.Version diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 76aebdaff09..963d8c4c840 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -29,6 +29,7 @@ import Brig.Data.Connection (remoteConnectionInsert) import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion +import Data.Code import Data.Domain import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) @@ -39,7 +40,6 @@ import Network.Wai.Utilities.Error qualified as Error import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util -import Util.Timeout import Wire.API.Connection import Wire.API.Conversation import Wire.API.Federation.API.Brig diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index d94f3fbe00f..cb6381f1bf0 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -32,6 +32,7 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Conversion +import Data.Code (Timeout) import Data.Handle (parseHandle) import Data.Id import Data.List1 qualified as List1 @@ -46,7 +47,6 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util -import Util.Timeout import Wire.API.Internal.Notification hiding (target) import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.Team.SearchVisibility diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 034c6c40ece..e77b02d25fc 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -23,17 +23,17 @@ module API.User.PasswordReset where import API.User.Util -import Bilge hiding (accept, timeout) +import Bilge hiding (accept) import Bilge.Assert import Brig.Options qualified as Opt import Cassandra qualified as DB import Data.Aeson as A import Data.Aeson.KeyMap qualified as KeyMap +import Data.Code (Timeout) import Data.Misc import Imports import Test.Tasty hiding (Timeout) import Util -import Util.Timeout import Wire.API.User import Wire.API.User.Auth diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 2ce2855a1cc..7e4f7b67dcf 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -28,13 +28,13 @@ import Bilge.Assert import Brig.Options import Brig.Options qualified as Opt import Data.CaseInsensitive qualified as CI +import Data.Code import Data.List1 qualified as List1 import Data.Text qualified as Text import Imports import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util -import Util.Timeout import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.RichInfo diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index a05438a3e10..55af7c296cc 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -83,7 +83,6 @@ import Data.Misc (HttpsUrl) import Data.Qualified import Data.Set qualified as Set import Data.Singletons -import Data.Time import Galley.API.Action import Galley.API.Error import Galley.API.Mapping From 28398db629fc48278f9496b90804856e31c78775 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 3 Sep 2024 10:08:51 +0200 Subject: [PATCH 42/96] Tweak changelog. --- changelog.d/5-internal/wpb-8887 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.d/5-internal/wpb-8887 b/changelog.d/5-internal/wpb-8887 index 8858aac302d..087d81745a8 100644 --- a/changelog.d/5-internal/wpb-8887 +++ b/changelog.d/5-internal/wpb-8887 @@ -1 +1 @@ -Implemented GetBy* for complex account queries. +New user subsystem operation `getAccountsBy` for complex account lookups. From 3d3ee05fa5c685b93fd89ff0e878ceb89ca8c303 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 3 Sep 2024 10:17:17 +0200 Subject: [PATCH 43/96] Simplify UserSubsystem operations set (resolves TODO). --- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 10 ++++++++-- .../src/Wire/UserSubsystem/Interpreter.hs | 14 -------------- .../unit/Wire/MockInterpreters/UserSubsystem.hs | 6 +----- 3 files changed, 9 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 6f00c9b1f45..1dee90d5823 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -90,8 +90,6 @@ data UserSubsystem m a where CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] -- | parses a handle, this may fail so it's effectful UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m () - -- TODO(mangoiv): this can probably go in favour of 'GetAccountsBy' - GetLocalUserAccountByUserKey :: Local EmailKey -> UserSubsystem m (Maybe UserAccount) -- | returns the user's locale or the default locale if the users exists LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) -- | checks if an email is blocked @@ -124,3 +122,11 @@ getLocalUserAccount uid = ( qualifyAs uid $ def {getByUserIds = [tUnqualified uid]} ) + +getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) +getLocalUserAccountByUserKey email = + listToMaybe + <$> getAccountsBy + ( qualifyAs email $ + def {getByEmail = [emailKeyOrig $ tUnqualified email]} + ) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index dac7f67e280..cd25b6188b4 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -110,7 +110,6 @@ interpretUserSubsystem = interpret \case CheckHandle uhandle -> checkHandleImpl uhandle CheckHandles hdls cnt -> checkHandlesImpl hdls cnt UpdateHandle uid mconn mb uhandle -> updateHandleImpl uid mconn mb uhandle - GetLocalUserAccountByUserKey userKey -> getLocalUserAccountByUserKeyImpl userKey LookupLocaleWithDefault luid -> lookupLocaleOrDefaultImpl luid IsBlocked email -> isBlockedImpl email BlockListDelete email -> blockListDeleteImpl email @@ -430,19 +429,6 @@ mkProfileUpdateHandleEvent :: UserId -> Handle -> UserEvent mkProfileUpdateHandleEvent uid handle = UserUpdated $ (emptyUserUpdatedData uid) {eupHandle = Just handle} -getLocalUserAccountByUserKeyImpl :: - ( Member UserStore r, - Member UserKeyStore r, - Member (Input UserSubsystemConfig) r - ) => - Local EmailKey -> - Sem r (Maybe UserAccount) -getLocalUserAccountByUserKeyImpl target = runMaybeT $ do - config <- lift input - uid <- MaybeT $ lookupKey (tUnqualified target) - user <- MaybeT $ getUser uid - pure $ mkAccountFromStored (tDomain target) config.defaultLocale user - -------------------------------------------------------------------------------- -- Update Handle diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index b47bfbd7d25..3514b7820ca 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -1,15 +1,11 @@ module Wire.MockInterpreters.UserSubsystem where -import Data.Qualified import Imports import Polysemy import Wire.API.User -import Wire.UserKeyStore import Wire.UserSubsystem userSubsystemTestInterpreter :: [UserAccount] -> InterpreterFor UserSubsystem r -userSubsystemTestInterpreter initialUsers = +userSubsystemTestInterpreter _initialUsers = interpret \case - GetLocalUserAccountByUserKey localUserKey -> case (tUnqualified localUserKey) of - EmailKey _ email -> pure $ find (\u -> userEmail u.accountUser == Just email) initialUsers _ -> error $ "userSubsystemTestInterpreter: implement on demand" From b28e04a863a5d529272855aad206b59721a7f98e Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 11:52:44 +0200 Subject: [PATCH 44/96] Fix user activation, add include pending activation to GetBy. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 17 ++++++- .../src/Wire/UserSubsystem/Interpreter.hs | 51 ++++++++++--------- services/brig/src/Brig/API/Internal.hs | 1 + services/brig/src/Brig/API/Types.hs | 2 + services/brig/src/Brig/API/User.hs | 2 +- services/brig/src/Brig/Data/Activation.hs | 10 ++-- 6 files changed, 49 insertions(+), 34 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 1dee90d5823..2572b8a0374 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -55,8 +55,10 @@ instance Default UserProfileUpdate where -- | how to get an account for a user data GetBy = MkGetBy - { -- | whether or not to include ending invitations in the lookups } + { -- | whether or not to include ending invitations in the lookups includePendingInvitations :: !Bool, + -- | whether or not to include users with unverified identities + includePendingActivations :: !Bool, -- | get accounds by 'UserId's getByUserIds :: ![UserId], -- | get accounds by 'Email's @@ -68,7 +70,7 @@ data GetBy = MkGetBy deriving (Arbitrary) via GenericUniform GetBy instance Default GetBy where - def = MkGetBy False [] [] [] + def = MkGetBy False False [] [] [] data UserSubsystem m a where -- | First arg is for authorization only. @@ -115,6 +117,17 @@ getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) +getLocalUserAccountUnverified :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) +getLocalUserAccountUnverified uid = + listToMaybe + <$> getAccountsBy + ( qualifyAs uid $ + def + { includePendingActivations = True, + getByUserIds = [tUnqualified uid] + } + ) + getLocalUserAccount :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) getLocalUserAccount uid = listToMaybe diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index cd25b6188b4..f5ff73d8a91 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -509,42 +509,43 @@ getAccountsByImpl :: ) => Local GetBy -> Sem r [UserAccount] -getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do +getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includePendingActivations, getByEmail, getByHandle, getByUserIds})) = do config <- input - handleUserIds <- wither lookupHandle getByHandle - let storedToAcc = mkAccountFromStored domain config.defaultLocale accountValid :: StoredUser -> Sem r (Maybe UserAccount) - accountValid storedUser = + accountValid storedUser = do let account = storedToAcc storedUser notValid = pure Nothing valid = pure $ Just account - in case userIdentity . accountUser $ account of - Nothing -> notValid - Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of - (PendingInvitation, False, _) -> notValid - (PendingInvitation, True, Just email) -> - lookupInvitationByEmail email >>= \case - Nothing -> do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - -- job akin to 'pendingUserActivationCleanup' - enqueueUserDeletion (userId account.accountUser) - notValid - Just _ -> valid - (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email - (Active, _, _) -> valid - (Suspended, _, _) -> valid - (Deleted, _, _) -> valid - (Ephemeral, _, _) -> valid + if includePendingActivations + then valid + else case userIdentity . accountUser $ account of + Nothing -> notValid + Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of + (PendingInvitation, False, _) -> notValid + (PendingInvitation, True, Just email) -> + lookupInvitationByEmail email >>= \case + Nothing -> do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + -- job akin to 'pendingUserActivationCleanup' + enqueueUserDeletion (userId account.accountUser) + notValid + Just _ -> valid + (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email + (Active, _, _) -> valid + (Suspended, _, _) -> valid + (Deleted, _, _) -> valid + (Ephemeral, _, _) -> valid + + handleUserIds :: [UserId] <- wither lookupHandle getByHandle accsByIds :: [UserAccount] <- - wither accountValid - =<< getUsers (nubOrd $ handleUserIds <> getByUserIds) + wither accountValid =<< getUsers (nubOrd $ handleUserIds <> getByUserIds) - accsByEmail <- flip foldMap getByEmail \email -> do + accsByEmail :: [UserAccount] <- flip foldMap getByEmail \email -> do let ek = mkEmailKey email mactiveUid <- lookupKey ek ac <- lookupActivationCode ek diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 89c2cb551b2..5430a08b8ae 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -582,6 +582,7 @@ listActivatedAccountsH dom $> MkGetBy { includePendingInvitations = include, + includePendingActivations = False, getByUserIds = uids, getByEmail = emails, getByHandle = handles diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 028b87d541d..076b844e1fc 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -69,6 +69,7 @@ data ActivationResult ActivationSuccess !(Maybe UserIdentity) !Bool | -- | The key/code was valid but already recently activated. ActivationPass + deriving (Show) -- | Outcome of the invariants check in 'Brig.API.User.changeEmail'. data ChangeEmailResult @@ -76,6 +77,7 @@ data ChangeEmailResult ChangeEmailNeedsActivation !(User, Activation, EmailAddress) | -- | The user asked to change the email address to the one already owned ChangeEmailIdempotent + deriving (Show) ------------------------------------------------------------------------------- -- Failures diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 605f3a57d68..324b684573d 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -296,7 +296,7 @@ createUser new = do lift $ join <$> for mbInv do \invid -> liftSem $ do - luid <- qualifyLocal' (coerce invid) + luid :: Local UserId <- qualifyLocal' (coerce invid) User.getLocalUserAccount luid let (new', mbHandle) = case mbExistingAccount of diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index aeb09cbe401..0d0cc6570b4 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -29,16 +29,13 @@ module Brig.Data.Activation ) where -import Brig.App (AppT, adhocUserKeyStoreInterpreter, liftSem, settings, wrapClient, wrapClientE) +import Brig.App (AppT, adhocUserKeyStoreInterpreter, liftSem, qualifyLocal, wrapClient, wrapClientE) import Brig.Data.User -import Brig.Options qualified as Opt import Brig.Types.Intra import Cassandra import Control.Error -import Control.Lens ((^.)) import Data.Code import Data.Id -import Data.Qualified import Data.Text (pack) import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding qualified as T @@ -83,6 +80,7 @@ activationErrorToRegisterError = \case data ActivationEvent = AccountActivated !UserAccount | EmailActivated !UserId !EmailAddress + deriving (Show) -- | Max. number of activation attempts per 'ActivationKey'. maxAttempts :: Int32 @@ -104,8 +102,8 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do - dom <- lift $ asks (^. settings . Opt.federationDomain) - a <- lift (liftSem $ User.getLocalUserAccount (toLocalUnsafe dom uid)) >>= maybe (throwE invalidUser) pure + luid <- qualifyLocal uid + a <- lift (liftSem $ User.getLocalUserAccountUnverified luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of From f26be09777280b083200e304a36c4ccd7fd02a71 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 11:58:01 +0200 Subject: [PATCH 45/96] nix --- libs/types-common/default.nix | 2 -- 1 file changed, 2 deletions(-) diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index c4bbd61c01b..7421aae499c 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -40,7 +40,6 @@ , quickcheck-instances , random , schema-profunctor -, scientific , servant-server , string-conversions , tagged @@ -97,7 +96,6 @@ mkDerivation { quickcheck-instances random schema-profunctor - scientific servant-server tagged tasty From 61a1e827b0b9801d4632dcf0f220281afda9cecb Mon Sep 17 00:00:00 2001 From: Igor Ranieri <54423+elland@users.noreply.github.com> Date: Tue, 3 Sep 2024 14:02:38 +0200 Subject: [PATCH 46/96] Apply suggestions from code review Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Co-authored-by: Matthias Fischmann --- .../src/Wire/ActivationCodeStore/Cassandra.hs | 4 +--- .../src/Wire/PasswordResetCodeStore/Cassandra.hs | 2 ++ libs/wire-subsystems/src/Wire/UserSubsystem.hs | 6 +++--- services/brig/src/Brig/Team/API.hs | 1 - 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs index 9259c1fca91..7f0ba27ba03 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -28,9 +28,7 @@ interpretActivationCodeStoreToCassandra casClient = mkActivationKey :: EmailKey -> IO ActivationKey mkActivationKey k = do - d <- - maybe (fail "mkActivationKey: SHA256 not found") pure - =<< getDigestByName "SHA256" + Just d <- getDigestByName "SHA256" pure do ActivationKey . Ascii.encodeBase64Url diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index be9b7571b4c..3ce4b6925d9 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -76,6 +76,8 @@ genPhoneCode = PasswordResetCode . unsafeFromText . pack . printf "%06d" <$> liftIO (randIntegerZeroToNMinusOne 1000000) +-- FUTUREWORK(fisx,elland): this should be replaced by a method in a +-- future auth subsystem codeDeleteImpl :: (MonadClient m) => PasswordResetKey -> m () codeDeleteImpl prk = retry x5 diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 2572b8a0374..7742fe729d0 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -59,11 +59,11 @@ data GetBy = MkGetBy includePendingInvitations :: !Bool, -- | whether or not to include users with unverified identities includePendingActivations :: !Bool, - -- | get accounds by 'UserId's + -- | get accounts by 'UserId's getByUserIds :: ![UserId], - -- | get accounds by 'Email's + -- | get accounts by 'Email's getByEmail :: ![EmailAddress], - -- | get accounds by their 'Handle' + -- | get accounts by their 'Handle' getByHandle :: ![Handle] } deriving stock (Eq, Ord, Show, Generic) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 4bbd19832ce..c03a23cde81 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -397,7 +397,6 @@ headInvitationByEmail email = . Log.field "email" (show email) pure Public.InvitationByEmailMoreThanOne --- Store.InvitationByEmail _ -> Public.InvitationByEmail -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and From 7451319b0dfb65dbdf6937dce7a50a6cf941c4a8 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 3 Sep 2024 15:47:56 +0200 Subject: [PATCH 47/96] Fix getBy usage. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 8 ++- .../src/Wire/UserSubsystem/Interpreter.hs | 70 ++++++++++--------- .../MockInterpreters/InvitationCodeStore.hs | 6 +- .../unit/Wire/MockInterpreters/UserStore.hs | 2 +- .../Wire/MockInterpreters/UserSubsystem.hs | 7 ++ services/brig/src/Brig/API/Internal.hs | 2 +- 6 files changed, 56 insertions(+), 39 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 7742fe729d0..825f099604e 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -62,7 +62,7 @@ data GetBy = MkGetBy -- | get accounts by 'UserId's getByUserIds :: ![UserId], -- | get accounts by 'Email's - getByEmail :: ![EmailAddress], + getByEmail :: ![EmailKey], -- | get accounts by their 'Handle' getByHandle :: ![Handle] } @@ -141,5 +141,9 @@ getLocalUserAccountByUserKey email = listToMaybe <$> getAccountsBy ( qualifyAs email $ - def {getByEmail = [emailKeyOrig $ tUnqualified email]} + def + { includePendingInvitations = True, + includePendingActivations = True, + getByEmail = [tUnqualified email] + } ) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index f5ff73d8a91..87de1f4c55f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Wire.UserSubsystem.Interpreter ( runUserSubsystem, @@ -514,47 +516,51 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includ let storedToAcc = mkAccountFromStored domain config.defaultLocale + filterPendingInvitations = + if includePendingInvitations + then pure + else pure . filter (\acc -> acc.accountStatus /= PendingInvitation) + + filterPendingActivation = + if includePendingActivations + then pure + else pure . filter (\acc -> isNothing acc.accountUser.userIdentity) + accountValid :: StoredUser -> Sem r (Maybe UserAccount) accountValid storedUser = do let account = storedToAcc storedUser notValid = pure Nothing valid = pure $ Just account - if includePendingActivations - then valid - else case userIdentity . accountUser $ account of - Nothing -> notValid - Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of - (PendingInvitation, False, _) -> notValid - (PendingInvitation, True, Just email) -> - lookupInvitationByEmail email >>= \case - Nothing -> do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - -- job akin to 'pendingUserActivationCleanup' - enqueueUserDeletion (userId account.accountUser) - notValid - Just _ -> valid - (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email - (Active, _, _) -> valid - (Suspended, _, _) -> valid - (Deleted, _, _) -> valid - (Ephemeral, _, _) -> valid + case userIdentity . accountUser $ account of + Nothing -> notValid + Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of + (PendingInvitation, False, _) -> notValid + (PendingInvitation, True, Just email) -> + lookupInvitationByEmail email >>= \case + Nothing -> do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + -- job akin to 'pendingUserActivationCleanup' + enqueueUserDeletion (userId account.accountUser) + notValid + Just _ -> valid + (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email + (Active, _, _) -> valid + (Suspended, _, _) -> valid + (Deleted, _, _) -> valid + (Ephemeral, _, _) -> valid handleUserIds :: [UserId] <- wither lookupHandle getByHandle accsByIds :: [UserAccount] <- - wither accountValid =<< getUsers (nubOrd $ handleUserIds <> getByUserIds) + getUsers (nubOrd $ handleUserIds <> getByUserIds) + >>= wither accountValid + >>= (filterPendingInvitations >=> filterPendingActivation) - accsByEmail :: [UserAccount] <- flip foldMap getByEmail \email -> do - let ek = mkEmailKey email + accsByEmail :: [UserAccount] <- flip foldMap getByEmail \ek -> do mactiveUid <- lookupKey ek - ac <- lookupActivationCode ek - let muidFromActivationKey = ac >>= fst - res <- getUsers (nubOrd $ catMaybes [mactiveUid, muidFromActivationKey]) - pure $ - map - storedToAcc - if includePendingInvitations - then res - else filter (\acc -> acc.status /= Just PendingInvitation) res + getUsers (nubOrd . catMaybes $ [mactiveUid]) + <&> map storedToAcc + >>= (filterPendingInvitations >=> filterPendingActivation) + pure (nubOrd $ accsByIds <> accsByEmail) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 4dd22cf40b4..d7deb8ff549 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -36,7 +36,7 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case | email == em = Just MkStoredInvitationInfo {..} | otherwise = Nothing in mapMaybe c . elems <$> get - LookupInvitationsPaginated {} -> todo + LookupInvitationsPaginated {} -> error "LookupInvitationsPaginated" CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) - DeleteInvitation tid invId -> todo - DeleteAllTeamInvitations tid -> todo + DeleteInvitation tid invId -> error "DeleteInvitation" + DeleteAllTeamInvitations tid -> error "DeleteAllTeamInvitations" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 38d99d01e7b..04933736dd0 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -19,7 +19,7 @@ inMemoryUserStoreInterpreter :: InterpreterFor UserStore r inMemoryUserStoreInterpreter = interpret $ \case GetUser uid -> gets $ find (\user -> user.id == uid) - GetUsers TODO -> TODO + GetUsers uids -> gets $ filter (\user -> user.id `elem` uids) UpdateUser uid update -> modify (map doUpdate) where doUpdate :: StoredUser -> StoredUser diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 3514b7820ca..ef62881d657 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -1,5 +1,6 @@ module Wire.MockInterpreters.UserSubsystem where +import Debug.Trace (traceM) import Imports import Polysemy import Wire.API.User @@ -8,4 +9,10 @@ import Wire.UserSubsystem userSubsystemTestInterpreter :: [UserAccount] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter _initialUsers = interpret \case + GetAccountsBy getBy -> do + traceM $ "\n getBy: " <> show getBy + pure [] _ -> error $ "userSubsystemTestInterpreter: implement on demand" + +-- case (tUnqualified localUserKey) of +-- EmailKey _ email -> pure $ find (\u -> userEmail u.accountUser == Just email) initialUsers diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 5430a08b8ae..c47c7dc38a0 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -572,7 +572,7 @@ listActivatedAccountsH :: listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) - (maybe [] fromCommaSeparatedList -> emails) + (maybe [] (fromCommaSeparatedList . fmap mkEmailKey) -> emails) (fromMaybe False -> include) = do when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") From 90d95e0d9069a181b98b626c7bf1b93cbf2a0fd8 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 4 Sep 2024 10:07:03 +0200 Subject: [PATCH 48/96] Fix password tests. --- .../Wire/PasswordResetCodeStore/Cassandra.hs | 2 +- .../Wire/MockInterpreters/UserSubsystem.hs | 24 +++++++++++++------ services/brig/src/Brig/Team/API.hs | 1 - 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 3ce4b6925d9..1758799f758 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -76,7 +76,7 @@ genPhoneCode = PasswordResetCode . unsafeFromText . pack . printf "%06d" <$> liftIO (randIntegerZeroToNMinusOne 1000000) --- FUTUREWORK(fisx,elland): this should be replaced by a method in a +-- FUTUREWORK(fisx,elland): this should be replaced by a method in a -- future auth subsystem codeDeleteImpl :: (MonadClient m) => PasswordResetKey -> m () codeDeleteImpl prk = diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index ef62881d657..69891129652 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -1,18 +1,28 @@ module Wire.MockInterpreters.UserSubsystem where -import Debug.Trace (traceM) +import Data.Qualified import Imports import Polysemy import Wire.API.User +import Wire.UserKeyStore import Wire.UserSubsystem userSubsystemTestInterpreter :: [UserAccount] -> InterpreterFor UserSubsystem r -userSubsystemTestInterpreter _initialUsers = +userSubsystemTestInterpreter initialUsers = interpret \case - GetAccountsBy getBy -> do - traceM $ "\n getBy: " <> show getBy - pure [] + GetAccountsBy (tSplit -> (_dom, getBy)) -> + pure $ + filter + ( \u -> + mailKeyFrom u + `elem` getBy.getByEmail + ) + initialUsers _ -> error $ "userSubsystemTestInterpreter: implement on demand" --- case (tUnqualified localUserKey) of --- EmailKey _ email -> pure $ find (\u -> userEmail u.accountUser == Just email) initialUsers +mailKeyFrom :: UserAccount -> EmailKey +mailKeyFrom acc = + case acc.accountUser.userIdentity of + Just (EmailIdentity mail) -> mkEmailKey mail + Just (SSOIdentity _ (Just mail)) -> mkEmailKey mail + _ -> error "Why are we testing users without emails for this?" diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index c03a23cde81..6984b2d2e3d 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -397,7 +397,6 @@ headInvitationByEmail email = . Log.field "email" (show email) pure Public.InvitationByEmailMoreThanOne - -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and -- 'getInvitationByEmailH' are almost the same thing. From 9787b4233116b9402e2266c32d27920e0efdfedb Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 4 Sep 2024 16:50:25 +0200 Subject: [PATCH 49/96] Fixed bugs and added GetBy tests. --- .../src/Wire/UserSubsystem/Interpreter.hs | 60 +++--- .../test/unit/Wire/MiniBackend.hs | 30 ++- .../Wire/UserSubsystem/InterpreterSpec.hs | 196 +++++++++++++++++- 3 files changed, 251 insertions(+), 35 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 87de1f4c55f..8db2e2a615d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -516,45 +516,47 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includ let storedToAcc = mkAccountFromStored domain config.defaultLocale + filterPendingInvitations :: [UserAccount] -> Sem r [UserAccount] filterPendingInvitations = - if includePendingInvitations - then pure - else pure . filter (\acc -> acc.accountStatus /= PendingInvitation) - + filterM + ( \acc -> + if acc.accountStatus == PendingInvitation + then do + case mailKeyFrom acc of + -- TODO: ensure this case is sound + -- Some tests fail but they seem to not rely on this + Nothing -> pure includePendingInvitations + Just key -> do + -- This is the case of expired invitations for users still pending + lookupInvitationByEmail key >>= \case + Nothing -> do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + -- job akin to 'pendingUserActivationCleanup' + enqueueUserDeletion (userId acc.accountUser) + pure False + Just _ -> pure includePendingInvitations + else pure True + ) + + filterPendingActivation :: [UserAccount] -> Sem r [UserAccount] filterPendingActivation = if includePendingActivations then pure else pure . filter (\acc -> isNothing acc.accountUser.userIdentity) - accountValid :: StoredUser -> Sem r (Maybe UserAccount) - accountValid storedUser = do - let account = storedToAcc storedUser - notValid = pure Nothing - valid = pure $ Just account - case userIdentity . accountUser $ account of - Nothing -> notValid - Just ident -> case (accountStatus account, includePendingInvitations, emailIdentity ident) of - (PendingInvitation, False, _) -> notValid - (PendingInvitation, True, Just email) -> - lookupInvitationByEmail email >>= \case - Nothing -> do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - -- job akin to 'pendingUserActivationCleanup' - enqueueUserDeletion (userId account.accountUser) - notValid - Just _ -> valid - (PendingInvitation, True, Nothing) -> valid -- cannot happen, user invited via scim always has an email - (Active, _, _) -> valid - (Suspended, _, _) -> valid - (Deleted, _, _) -> valid - (Ephemeral, _, _) -> valid - + mailKeyFrom :: UserAccount -> Maybe EmailAddress + mailKeyFrom acc = + case acc.accountUser.userIdentity of + Just (EmailIdentity mail) -> Just mail + Just (SSOIdentity _ (Just mail)) -> Just mail + -- TODO: fix this error + _ -> Nothing -- error "SCIM invited user should have an email" handleUserIds :: [UserId] <- wither lookupHandle getByHandle accsByIds :: [UserAccount] <- getUsers (nubOrd $ handleUserIds <> getByUserIds) - >>= wither accountValid + <&> map storedToAcc >>= (filterPendingInvitations >=> filterPendingActivation) accsByEmail :: [UserAccount] <- flip foldMap getByEmail \ek -> do diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index a730dd08b17..a8017ef998f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -19,6 +19,8 @@ module Wire.MiniBackend -- * Quickcheck helpers NotPendingStoredUser (..), + NotPendingEmptyIdentityStoredUser (..), + PendingNotEmptyIdentityStoredUser (..), PendingStoredUser (..), ) where @@ -78,6 +80,24 @@ import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.Interpreter +newtype PendingNotEmptyIdentityStoredUser = PendingNotEmptyIdentityStoredUser StoredUser + deriving (Show, Eq) + +instance Arbitrary PendingNotEmptyIdentityStoredUser where + arbitrary = do + user <- arbitrary `suchThat` \user -> isJust user.identity + pure $ PendingNotEmptyIdentityStoredUser (user {status = Just PendingInvitation}) + +newtype NotPendingEmptyIdentityStoredUser = NotPendingEmptyIdentityStoredUser StoredUser + deriving (Show, Eq) + +-- TODO: make sure this is a valid state +instance Arbitrary NotPendingEmptyIdentityStoredUser where + arbitrary = do + user <- arbitrary `suchThat` \user -> isNothing user.identity + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) + pure $ NotPendingEmptyIdentityStoredUser (user {status = notPendingStatus}) + newtype PendingStoredUser = PendingStoredUser StoredUser deriving (Show, Eq) @@ -383,16 +403,16 @@ liftInvitationInfoStoreState = interpret \case Polysemy.State.Get -> gets (.invitationInfos) Put newAcs -> modify $ \b -> b {invitationInfos = newAcs} -liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a -liftActivationCodeStoreState = interpret \case - Polysemy.State.Get -> gets (.activationCodes) - Put newAcs -> modify $ \b -> b {activationCodes = newAcs} - liftInvitationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map (TeamId, InvitationId) StoredInvitation) : r) a -> Sem r a liftInvitationCodeStoreState = interpret \case Polysemy.State.Get -> gets (.invitations) Put newInvs -> modify $ \b -> b {invitations = newInvs} +liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a +liftActivationCodeStoreState = interpret \case + Polysemy.State.Get -> gets (.activationCodes) + Put newAcs -> modify $ \b -> b {activationCodes = newAcs} + liftBlockListStoreState :: (Member (State MiniBackend) r) => Sem (State [EmailKey] : r) a -> Sem r a liftBlockListStoreState = interpret $ \case Polysemy.State.Get -> gets (.blockList) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 9a98d7b1ae5..dda5c626001 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -28,6 +28,8 @@ import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User hiding (DeleteUser) import Wire.API.UserEvent +import Wire.InvitationCodeStore (StoredInvitation) +import Wire.InvitationCodeStore qualified as InvitationStore import Wire.MiniBackend import Wire.StoredUser import Wire.UserKeyStore @@ -277,6 +279,198 @@ spec = describe "UserSubsystem.Interpreter" do ) ] + describe "getAccountsBy" do + prop "GetBy userId when pending fails if not explicitly allowed" $ + \(PendingStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserIds = [alice.id], + -- Do not rely on default behaviour + includePendingInvitations = False + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy userId works for pending if explicitly queried" $ + \(PendingStoredUser alice') email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByUserIds = [alice.id], + includePendingInvitations = True, + -- So we don't accidentally filter alice out + includePendingActivations = True + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy email not pending" $ + \(NotPendingStoredUser alice') email localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByEmail = [emailKey], + -- We don't care about activation + includePendingActivations = True + } + emailKey = mkEmailKey email + alice = alice' {email = Just email} + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy email pending fails even if explicit when no invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') email localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByEmail = [emailKey], + includePendingInvitations = True, + includePendingActivations = True + } + alice = alice' {email = Just email} + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + prop "GetBy email pending works if explicit" $ + \(PendingStoredUser alice') teamId email localDomain invitationInfo visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByEmail = [emailKey], + includePendingInvitations = True, + includePendingActivations = True + } + alice = + alice' + { email = Just email, + teamId = Just teamId + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id, + -- Pending users always require a valid invitation + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy userId works even if identity is empty" $ + \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = toLocalUnsafe localDomain $ def {getByUserIds = [alice.id]} + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy userId if not pending" $ + \(NotPendingStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserIds = [alice.id], + -- We don't care about user status, only if the email is there. + includePendingInvitations = True, + includePendingActivations = True + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy pending user requires a valid invitation" $ + \(PendingStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByEmail = [mkEmailKey email], + -- We don't care about user status, only if the email is there. + includePendingInvitations = True, + -- We don't want to risk filtering out + -- non-activated users generated by Arbitrary + includePendingActivations = True + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id, + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + alice = alice' {email = Just email, teamId = Just teamId} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + describe "user managed by scim doesn't allow certain update operations, but allows others" $ do prop "happy" $ \(NotPendingStoredUser alice) localDomain update config -> @@ -471,7 +665,7 @@ spec = describe "UserSubsystem.Interpreter" do describe "getLocalUserAccountByUserKey" $ do prop "gets users iff they are indexed by the UserKeyStore" $ - \(config :: UserSubsystemConfig) (localDomain :: Domain) (storedUser :: StoredUser) (userKey :: EmailKey) -> + \(config :: UserSubsystemConfig) (localDomain :: Domain) (NotPendingStoredUser storedUser) (userKey :: EmailKey) -> let localBackend = def { users = [storedUser], From 4aaf25e853b39f075c363f029b391d610f34f2d5 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 5 Sep 2024 10:25:06 +0200 Subject: [PATCH 50/96] Removed unnecessary filter. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 11 +++++----- .../src/Wire/UserSubsystem/Interpreter.hs | 12 +++------- .../Wire/UserSubsystem/InterpreterSpec.hs | 22 +++++-------------- services/brig/src/Brig/API/Client.hs | 6 +++++ services/brig/src/Brig/API/Internal.hs | 1 - 5 files changed, 20 insertions(+), 32 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 825f099604e..89a1592ea9b 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -57,8 +57,9 @@ instance Default UserProfileUpdate where data GetBy = MkGetBy { -- | whether or not to include ending invitations in the lookups includePendingInvitations :: !Bool, - -- | whether or not to include users with unverified identities - includePendingActivations :: !Bool, + -- -- | whether or not to include users with unverified identities + -- includePendingActivations :: !Bool, + -- | get accounts by 'UserId's getByUserIds :: ![UserId], -- | get accounts by 'Email's @@ -70,7 +71,7 @@ data GetBy = MkGetBy deriving (Arbitrary) via GenericUniform GetBy instance Default GetBy where - def = MkGetBy False False [] [] [] + def = MkGetBy False [] [] [] data UserSubsystem m a where -- | First arg is for authorization only. @@ -123,8 +124,7 @@ getLocalUserAccountUnverified uid = <$> getAccountsBy ( qualifyAs uid $ def - { includePendingActivations = True, - getByUserIds = [tUnqualified uid] + { getByUserIds = [tUnqualified uid] } ) @@ -143,7 +143,6 @@ getLocalUserAccountByUserKey email = ( qualifyAs email $ def { includePendingInvitations = True, - includePendingActivations = True, getByEmail = [tUnqualified email] } ) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8db2e2a615d..eca8c054aaa 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -511,7 +511,7 @@ getAccountsByImpl :: ) => Local GetBy -> Sem r [UserAccount] -getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includePendingActivations, getByEmail, getByHandle, getByUserIds})) = do +getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do config <- input let storedToAcc = mkAccountFromStored domain config.defaultLocale @@ -539,12 +539,6 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includ else pure True ) - filterPendingActivation :: [UserAccount] -> Sem r [UserAccount] - filterPendingActivation = - if includePendingActivations - then pure - else pure . filter (\acc -> isNothing acc.accountUser.userIdentity) - mailKeyFrom :: UserAccount -> Maybe EmailAddress mailKeyFrom acc = case acc.accountUser.userIdentity of @@ -557,12 +551,12 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includ accsByIds :: [UserAccount] <- getUsers (nubOrd $ handleUserIds <> getByUserIds) <&> map storedToAcc - >>= (filterPendingInvitations >=> filterPendingActivation) + >>= filterPendingInvitations accsByEmail :: [UserAccount] <- flip foldMap getByEmail \ek -> do mactiveUid <- lookupKey ek getUsers (nubOrd . catMaybes $ [mactiveUid]) <&> map storedToAcc - >>= (filterPendingInvitations >=> filterPendingActivation) + >>= filterPendingInvitations pure (nubOrd $ accsByIds <> accsByEmail) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index dda5c626001..eb8d650282f 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -309,9 +309,7 @@ spec = describe "UserSubsystem.Interpreter" do toLocalUnsafe localDomain $ def { getByUserIds = [alice.id], - includePendingInvitations = True, - -- So we don't accidentally filter alice out - includePendingActivations = True + includePendingInvitations = True } localBackend = def @@ -339,9 +337,7 @@ spec = describe "UserSubsystem.Interpreter" do getBy = toLocalUnsafe localDomain $ def - { getByEmail = [emailKey], - -- We don't care about activation - includePendingActivations = True + { getByEmail = [emailKey] } emailKey = mkEmailKey email alice = alice' {email = Just email} @@ -363,8 +359,7 @@ spec = describe "UserSubsystem.Interpreter" do toLocalUnsafe localDomain $ def { getByEmail = [emailKey], - includePendingInvitations = True, - includePendingActivations = True + includePendingInvitations = True } alice = alice' {email = Just email} localBackend = @@ -384,8 +379,7 @@ spec = describe "UserSubsystem.Interpreter" do toLocalUnsafe localDomain $ def { getByEmail = [emailKey], - includePendingInvitations = True, - includePendingActivations = True + includePendingInvitations = True } alice = alice' @@ -429,8 +423,7 @@ spec = describe "UserSubsystem.Interpreter" do def { getByUserIds = [alice.id], -- We don't care about user status, only if the email is there. - includePendingInvitations = True, - includePendingActivations = True + includePendingInvitations = True } localBackend = def {users = [alice]} result = @@ -447,10 +440,7 @@ spec = describe "UserSubsystem.Interpreter" do def { getByEmail = [mkEmailKey email], -- We don't care about user status, only if the email is there. - includePendingInvitations = True, - -- We don't want to risk filtering out - -- non-activated users generated by Arbitrary - includePendingActivations = True + includePendingInvitations = True } localBackend = def diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index d1cfebe9998..0b5b0fc0562 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -83,6 +83,7 @@ import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error +import Debug.Trace import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities @@ -202,8 +203,11 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do + traceM "\n --------------- addClientWithReAuthPolicy" usr <- (lift . liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + traceM "\n --------------- will verify code" verifyCode (newClientVerificationCode new) luid + traceM "\n --------------- verified code" maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new @@ -218,6 +222,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients caps) !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} + traceM $ "\n 1 ------- ctl: " <> show clt lift $ do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u (clientId clt) @@ -227,6 +232,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do for_ (userEmail usr) $ \email -> liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) + traceM $ "\n 2 ------- client: " <> show clt pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c47c7dc38a0..6e69cf4c759 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -582,7 +582,6 @@ listActivatedAccountsH dom $> MkGetBy { includePendingInvitations = include, - includePendingActivations = False, getByUserIds = uids, getByEmail = emails, getByHandle = handles From 629b8828f605aa6002e92c47dd813690fda1c110 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 5 Sep 2024 10:54:12 +0200 Subject: [PATCH 51/96] Fixed another logic error in invitation pending. --- .../src/Wire/UserSubsystem/Interpreter.hs | 29 +++++++------------ services/brig/src/Brig/API/Client.hs | 6 ---- 2 files changed, 11 insertions(+), 24 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index eca8c054aaa..7445f6d28f1 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -1,6 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} module Wire.UserSubsystem.Interpreter ( runUserSubsystem, @@ -30,7 +28,6 @@ import Wire.API.Team.Feature import Wire.API.Team.Member hiding (userId) import Wire.API.User import Wire.API.UserEvent -import Wire.ActivationCodeStore (ActivationCodeStore, lookupActivationCode) import Wire.Arbitrary import Wire.BlockListStore as BlockList import Wire.DeleteQueue @@ -74,8 +71,7 @@ runUserSubsystem :: FederationMonad fedM, Typeable fedM, Member (TinyLog) r, - Member InvitationCodeStore r, - Member ActivationCodeStore r + Member InvitationCodeStore r ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r @@ -98,7 +94,6 @@ interpretUserSubsystem :: FederationMonad fedM, Typeable fedM, Member InvitationCodeStore r, - Member ActivationCodeStore r, Member TinyLog r ) => InterpreterFor UserSubsystem r @@ -506,7 +501,6 @@ getAccountsByImpl :: Member (Input UserSubsystemConfig) r, Member InvitationCodeStore r, Member UserKeyStore r, - Member ActivationCodeStore r, Member TinyLog r ) => Local GetBy -> @@ -522,25 +516,24 @@ getAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByE ( \acc -> if acc.accountStatus == PendingInvitation then do - case mailKeyFrom acc of + case accountIdentityEmail acc of -- TODO: ensure this case is sound -- Some tests fail but they seem to not rely on this Nothing -> pure includePendingInvitations Just key -> do -- This is the case of expired invitations for users still pending - lookupInvitationByEmail key >>= \case - Nothing -> do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - -- job akin to 'pendingUserActivationCleanup' - enqueueUserDeletion (userId acc.accountUser) - pure False - Just _ -> pure includePendingInvitations + hasInvitation <- isJust <$> lookupInvitationByEmail key + unless hasInvitation do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + -- job akin to 'pendingUserActivationCleanup' + enqueueUserDeletion (userId acc.accountUser) + pure (hasInvitation && includePendingInvitations) else pure True ) - mailKeyFrom :: UserAccount -> Maybe EmailAddress - mailKeyFrom acc = + accountIdentityEmail :: UserAccount -> Maybe EmailAddress + accountIdentityEmail acc = case acc.accountUser.userIdentity of Just (EmailIdentity mail) -> Just mail Just (SSOIdentity _ (Just mail)) -> Just mail diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 0b5b0fc0562..d1cfebe9998 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -83,7 +83,6 @@ import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error -import Debug.Trace import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities @@ -203,11 +202,8 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - traceM "\n --------------- addClientWithReAuthPolicy" usr <- (lift . liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) - traceM "\n --------------- will verify code" verifyCode (newClientVerificationCode new) luid - traceM "\n --------------- verified code" maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new @@ -222,7 +218,6 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients caps) !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} - traceM $ "\n 1 ------- ctl: " <> show clt lift $ do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u (clientId clt) @@ -232,7 +227,6 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do for_ (userEmail usr) $ \email -> liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) - traceM $ "\n 2 ------- client: " <> show clt pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) From dc74199ba23abd1ba184859da8186a5fc13eb255 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 5 Sep 2024 11:20:30 +0200 Subject: [PATCH 52/96] Removed Wwarns, added a type to document the insert effect. --- .../src/Wire/InvitationCodeStore.hs | 15 ++++++++++++- .../src/Wire/InvitationCodeStore/Cassandra.hs | 12 +++-------- .../MockInterpreters/InvitationCodeStore.hs | 7 +++---- .../unit/Wire/MockInterpreters/UserStore.hs | 2 -- services/brig/src/Brig/Team/API.hs | 21 +++++++++++-------- 5 files changed, 32 insertions(+), 25 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 5d2a4d80de7..300ab934308 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -63,6 +63,19 @@ data StoredInvitationInfo = MkStoredInvitationInfo recordInstance ''StoredInvitationInfo +data InsertInvitation = MkInsertInvitation + { invitationId :: InvitationId, + teamId :: TeamId, + role :: Role, + createdAt :: UTCTime, + createdBy :: Maybe UserId, + inviteeEmail :: EmailAddress, + inviteeName :: Maybe Name + } + deriving (Show, Eq, Generic) + +recordInstance ''InsertInvitation + data PaginatedResult a = PaginatedResultHasMore a | PaginatedResult a @@ -71,7 +84,7 @@ data PaginatedResult a ---------------------------- data InvitationCodeStore :: Effect where - InsertInvitation :: InvitationId -> TeamId -> Role -> UTCTime -> Maybe UserId -> EmailAddress -> Maybe Name -> Timeout -> InvitationCodeStore m StoredInvitation + InsertInvitation :: InsertInvitation -> Timeout -> InvitationCodeStore m StoredInvitation LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index e9d40711ea6..a29755bdd57 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -22,7 +22,7 @@ interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState interpretInvitationCodeStoreToCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case - InsertInvitation iid tid role time muid mail mname timeout -> embed $ insertInvitationImpl iid tid role time muid mail mname timeout + InsertInvitation newInv timeout -> embed $ insertInvitationImpl newInv timeout LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code @@ -32,17 +32,11 @@ interpretInvitationCodeStoreToCassandra casClient = DeleteAllTeamInvitations tid -> embed $ deleteInvitationsImpl tid insertInvitationImpl :: - InvitationId -> - TeamId -> - Role -> - UTCTime -> - Maybe UserId -> - EmailAddress -> - Maybe Name -> + InsertInvitation -> -- | The timeout for the invitation code. Timeout -> Client StoredInvitation -insertInvitationImpl invId teamId role (toUTCTimeMillis -> now) uid email name timeout = do +insertInvitationImpl (MkInsertInvitation invId teamId role (toUTCTimeMillis -> now) uid email name) timeout = do code <- liftIO mkInvitationCode let inv = MkStoredInvitation diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index d7deb8ff549..5133bceed6c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wwarn #-} module Wire.MockInterpreters.InvitationCodeStore where @@ -22,7 +21,7 @@ inMemoryInvitationCodeStoreInterpreter :: ) => InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case - InsertInvitation invitationId teamId role' createdAt' createdBy email name _timeout -> do + InsertInvitation (MkInsertInvitation invitationId teamId role' createdAt' createdBy email name) _timeout -> do code <- unsafeCoerce mkInvitationCode let role = Just role' createdAt = toUTCTimeMillis createdAt' @@ -38,5 +37,5 @@ inMemoryInvitationCodeStoreInterpreter = interpret \case in mapMaybe c . elems <$> get LookupInvitationsPaginated {} -> error "LookupInvitationsPaginated" CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) - DeleteInvitation tid invId -> error "DeleteInvitation" - DeleteAllTeamInvitations tid -> error "DeleteAllTeamInvitations" + DeleteInvitation _tid _invId -> error "DeleteInvitation" + DeleteAllTeamInvitations _tid -> error "DeleteAllTeamInvitations" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 04933736dd0..b28ea9a5a99 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wwarn #-} - module Wire.MockInterpreters.UserStore where import Data.Handle diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 6984b2d2e3d..00092ba8270 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# OPTIONS_GHC -Wwarn #-} module Brig.Team.API ( servantAPI, @@ -87,7 +86,7 @@ import Wire.EmailSubsystem.Template import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess -import Wire.InvitationCodeStore (InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) +import Wire.InvitationCodeStore (InsertInvitation (..), InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency @@ -260,16 +259,20 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do iid <- maybe (liftIO randomId) (pure . Id . toUUID) mUid now <- liftIO =<< view currentTime timeout <- setTeamInvitationTimeout <$> view settings + let insertInv = + MkInsertInvitation + { invitationId = iid, + teamId = tid, + role = inviteeRole, + createdAt = now, + createdBy = mbInviterUid, + inviteeEmail = email, + inviteeName = body.inviteeName + } newInv <- lift . liftSem $ Store.insertInvitation - iid - tid - inviteeRole - now - mbInviterUid - email - body.inviteeName + insertInv timeout lift $ sendInvitationMail email tid fromEmail newInv.code body.locale inv <- toInvitation showInvitationUrl newInv From c2ee5dfada867f7d0cc94b3dec4e9fd8c31356bf Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 5 Sep 2024 13:05:26 +0200 Subject: [PATCH 53/96] wip (fix errors from merge) --- services/brig/src/Brig/API/User.hs | 63 +++++++++++++++++------------- 1 file changed, 35 insertions(+), 28 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e4a5418022b..46b96f5b6d9 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -87,7 +87,6 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), User import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra import Brig.Options hiding (Timeout, internalEvents) -import Brig.Team.DB qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth @@ -142,6 +141,7 @@ import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess +import Wire.InvitationCodeStore qualified as Team import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem @@ -243,7 +243,7 @@ createUserSpar new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, role) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -292,8 +292,16 @@ createUser new = do pure (Nothing, Nothing, Just tid) Nothing -> pure (Nothing, Nothing, Nothing) - let mbInv = Team.inInvitation . fst <$> teamInvitation - mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> wrapClient $ Data.lookupAccount (Id uuid)) + let mbInv = (.invitationId) . fst <$> teamInvitation + mbExistingAccount <- + lift $ + join + <$> for + mbInv + ( \(Id uuid) -> liftSem $ do + uid <- qualifyLocal' (Id uuid) + getLocalUserAccount uid + ) let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -351,10 +359,10 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do - let em = Team.inInviteeEmail inv + let em = inv.inviteeEmail acceptTeamInvitation account inv invInfo (mkEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName (Team.inTeam inv) - pure (Just $ CreateUserTeam (Team.inTeam inv) nm) + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.team + pure (Just $ CreateUserTeam inv.team nm) Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of @@ -382,17 +390,17 @@ createUser new = do pure email - findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.StoredInvitationInfo, TeamId)) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = - lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case + lift (liftSem $ Team.lookupInvitationInfo c) >>= \case Just ii -> do - inv <- lift . wrapClient $ Team.lookupInvitation HideInvitationUrl (Team.iiTeam ii) (Team.iiInvId ii) - case (inv, Team.inInviteeEmail <$> inv) of + inv <- lift . liftSem $ Team.lookupInvitation HideInvitationUrl ii.team ii.invId + case (inv, (.inviteeEmail) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - _ <- ensureMemberCanJoin (Team.iiTeam ii) - pure $ Just (invite, ii, Team.iiTeam ii) + _ <- ensureMemberCanJoin ii.team + pure $ Just (invite, ii, ii.team) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -412,7 +420,7 @@ createUser new = do acceptTeamInvitation :: UserAccount -> Team.Invitation -> - Team.InvitationInfo -> + Team.StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () @@ -421,27 +429,26 @@ createUser new = do ok <- lift $ liftSem $ claimKey uk uid unless ok $ throwE RegisterErrorUserKeyExists - let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) - minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid (Team.iiTeam ii) minvmeta + let minvmeta :: (Maybe (UserId, UTCTimeMillis)) + minvmeta = (,inv.createdAt) <$> inv.createdBy + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid ii.team minvmeta inv.role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) - liftSem $ + liftSem $ do Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ Team.iiTeam ii) + . field "team" (toByteString ii.team) . msg (val "Accepting invitation") - liftSem $ UserPendingActivationStore.remove uid - wrapClient $ do - Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) + UserPendingActivationStore.remove uid + Team.deleteInvitation inv.team inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing defaultRole unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -879,7 +886,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser uid pwd = do - account <- lift . wrapClient $ Data.lookupAccount uid + account <- lift . liftSem $ getLocalUserAccount uid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -954,7 +961,7 @@ verifyDeleteUser d = do let code = verifyDeleteUserCode d c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) - account <- lift . wrapClient $ Data.lookupAccount (Id a) + account <- lift . liftSem $ getLocalUserAccount (Id a) for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -977,7 +984,7 @@ ensureAccountDeleted :: UserId -> AppT r DeleteUserResult ensureAccountDeleted uid = do - mbAcc <- wrapClient $ lookupAccount uid + mbAcc <- liftSem $ getLocalUserAccount uid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1108,7 +1115,7 @@ getLegalHoldStatus :: (Member GalleyAPIAccess r) => UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) +getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< liftSem (getLocalUserAccount uid) getLegalHoldStatus' :: (Member GalleyAPIAccess r) => @@ -1132,7 +1139,7 @@ lookupExtendedAccountsByIdentity email includePendingInvitations = do let uk = mkEmailKey email activeUid <- liftSem $ lookupKey uk uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) - result <- wrapClient $ getLocalExtendedAccounts (nub $ catMaybes [activeUid, uidFromKey]) + result <- liftSem $ getLocalExtendedAccounts =<< qualifyLocal (nub $ catMaybes [activeUid, uidFromKey]) if includePendingInvitations then pure result else pure $ filter ((/= PendingInvitation) . accountStatus . account) result From c6afad506fee5550c4245a64a5cb4c498a9f1ee2 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 5 Sep 2024 15:00:39 +0200 Subject: [PATCH 54/96] Update libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> --- .../wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 1758799f758..ef043d14bc8 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -19,7 +19,6 @@ module Wire.PasswordResetCodeStore.Cassandra ( passwordResetCodeStoreToCassandra, interpretClientToIO, - -- Temporary measure until we create AuthSubsystem codeDeleteImpl, ) where From 561a36174c46b6116bda9cf6be0de8b3e8aecb92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 5 Sep 2024 15:01:28 +0200 Subject: [PATCH 55/96] Make it compile again --- libs/wire-api/src/Wire/API/User/Scim.hs | 1 - services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/User.hs | 146 +++++++++++------------- 3 files changed, 66 insertions(+), 83 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 21b82fb61ee..6c3ea06dd1b 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -65,7 +65,6 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.These import Data.These.Combinators -import Data.Time.Clock (UTCTime) import Imports import SAML2.WebSSO qualified as SAML import SAML2.WebSSO.Test.Arbitrary () diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index bfd1505bff1..045eecce7cd 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -578,7 +578,7 @@ listActivatedAccountsH throwStd (notFound "no user keys") lift $ liftSem do dom <- input - getAccountsBy $ + getExtendedAccountsBy $ dom $> MkGetBy { includePendingInvitations = include, diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 46b96f5b6d9..373d3cba2ae 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -31,8 +31,6 @@ module Brig.API.User lookupHandle, changeAccountStatus, changeSingleAccountStatus, - lookupAccountsByIdentity, - lookupExtendedAccountsByIdentity, getLegalHoldStatus, Data.lookupName, Data.lookupUser, @@ -86,7 +84,7 @@ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra -import Brig.Options hiding (Timeout, internalEvents) +import Brig.Options hiding (internalEvents) import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth @@ -98,6 +96,7 @@ import Control.Lens (preview, to, view, (^.), _Just) import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code +import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Handle (Handle (fromHandle)) import Data.Id as Id @@ -108,9 +107,8 @@ import Data.List1 as List1 (List1, singleton) import Data.Misc import Data.Qualified import Data.Range -import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) -import Imports +import Imports hiding (local) import Network.Wai.Utilities import Polysemy import Polysemy.Input (Input) @@ -125,8 +123,6 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Password import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) -import Wire.API.Team.Invitation -import Wire.API.Team.Invitation qualified as Team import Wire.API.Team.Member (legalHoldStatus) import Wire.API.Team.Role import Wire.API.Team.Size @@ -141,7 +137,8 @@ import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess -import Wire.InvitationCodeStore qualified as Team +import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation, StoredInvitationInfo) +import Wire.InvitationCodeStore qualified as InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem @@ -264,12 +261,14 @@ createUser :: Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member UserKeyStore r, + Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member InvitationCodeStore r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -295,13 +294,10 @@ createUser new = do let mbInv = (.invitationId) . fst <$> teamInvitation mbExistingAccount <- lift $ - join - <$> for - mbInv - ( \(Id uuid) -> liftSem $ do - uid <- qualifyLocal' (Id uuid) - getLocalUserAccount uid - ) + join <$> for mbInv do + \invid -> liftSem $ do + luid :: Local UserId <- qualifyLocal' (coerce invid) + User.getLocalUserAccount luid let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -311,13 +307,10 @@ createUser new = do Just existingAccount -> let existingUser = existingAccount.accountUser mbSSOid = - case (teamInvitation, email, existingUser.userManagedBy, userSSOId existingUser) of + case (teamInvitation, email, existingUser.userManagedBy) of -- isJust teamInvitation And ManagedByScim implies that the -- user invitation has been generated by SCIM and there is no IdP - (Just _, _, ManagedByScim, ssoId@(Just (UserScimExternalId _))) -> - -- if the existing user has an external ID, we have to use it because it can differ from the email address - ssoId - (Just _, Just em, ManagedByScim, _) -> + (Just _, Just em, ManagedByScim) -> Just $ UserScimExternalId (fromEmail em) _ -> newUserSSOId new in ( new @@ -342,7 +335,7 @@ createUser new = do pure account - let uid = userId (accountUser account) + let uid = qUnqualified account.accountUser.userQualifiedId createUserTeam <- do activatedTeam <- lift $ do @@ -359,10 +352,9 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do - let em = inv.inviteeEmail - acceptTeamInvitation account inv invInfo (mkEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.team - pure (Just $ CreateUserTeam inv.team nm) + acceptTeamInvitation account inv invInfo (mkEmailKey inv.email) (EmailIdentity inv.email) + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.teamId + pure (Just $ CreateUserTeam inv.teamId nm) Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of @@ -390,17 +382,25 @@ createUser new = do pure email - findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.StoredInvitationInfo, TeamId)) + findTeamInvitation :: + Maybe EmailKey -> + InvitationCode -> + ExceptT + RegisterError + (AppT r) + ( Maybe + (StoredInvitation, StoredInvitationInfo, TeamId) + ) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = - lift (liftSem $ Team.lookupInvitationInfo c) >>= \case - Just ii -> do - inv <- lift . liftSem $ Team.lookupInvitation HideInvitationUrl ii.team ii.invId - case (inv, (.inviteeEmail) <$> inv) of + lift (liftSem $ InvitationCodeStore.lookupInvitationInfo c) >>= \case + Just invitationInfo -> do + inv <- lift . liftSem $ InvitationCodeStore.lookupInvitation invitationInfo.teamId invitationInfo.invitationId + case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - _ <- ensureMemberCanJoin ii.team - pure $ Just (invite, ii, ii.team) + ensureMemberCanJoin invitationInfo.teamId + pure $ Just (invite, invitationInfo, invitationInfo.teamId) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -419,31 +419,33 @@ createUser new = do acceptTeamInvitation :: UserAccount -> - Team.Invitation -> - Team.StoredInvitationInfo -> + StoredInvitation -> + StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () - acceptTeamInvitation account inv ii uk ident = do + acceptTeamInvitation account inv invitationInfo uk ident = do let uid = userId (accountUser account) ok <- lift $ liftSem $ claimKey uk uid unless ok $ throwE RegisterErrorUserKeyExists - let minvmeta :: (Maybe (UserId, UTCTimeMillis)) + let minvmeta :: Maybe (UserId, UTCTimeMillis) minvmeta = (,inv.createdAt) <$> inv.createdBy - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid ii.team minvmeta inv.role + role :: Role + role = fromMaybe defaultRole inv.role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.teamId minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) - liftSem $ do + liftSem do Log.info $ field "user" (toByteString uid) - . field "team" (toByteString ii.team) + . field "team" (toByteString $ invitationInfo.teamId) . msg (val "Accepting invitation") UserPendingActivationStore.remove uid - Team.deleteInvitation inv.team inv.invitationId + InvitationCodeStore.deleteInvitation inv.teamId inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do @@ -497,10 +499,10 @@ createUserInviteViaScim :: ) => NewUserScimInvitation -> ExceptT HttpError (AppT r) UserAccount -createUserInviteViaScim (NewUserScimInvitation tid uid eid loc name email _) = do +createUserInviteViaScim (NewUserScimInvitation tid uid extId loc name email _) = do let emKey = mkEmailKey email verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError - account <- lift . wrapClient $ newAccountInviteViaScim uid eid tid loc name email + account <- lift . wrapClient $ newAccountInviteViaScim uid extId tid loc name email lift . liftSem . Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (val "User.createUserInviteViaScim") -- add the expiry table entry first! (if brig creates an account, and then crashes before @@ -687,7 +689,8 @@ activate :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member UserSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -703,6 +706,7 @@ activateWithCurrency :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => ActivationTarget -> @@ -719,7 +723,7 @@ activateWithCurrency tgt code usr cur = do field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") - event <- wrapClientE $ Data.activateKey key code usr + event <- Data.activateKey key code usr case event of Nothing -> pure ActivationPass Just e -> do @@ -880,13 +884,14 @@ deleteSelfUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) -deleteSelfUser uid pwd = do - account <- lift . liftSem $ getLocalUserAccount uid +deleteSelfUser luid@(tUnqualified -> uid) pwd = do + account <- lift . liftSem $ User.getLocalUserAccount luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -952,6 +957,7 @@ verifyDeleteUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => VerifyDeleteUser -> @@ -961,7 +967,8 @@ verifyDeleteUser d = do let code = verifyDeleteUserCode d c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) - account <- lift . liftSem $ getLocalUserAccount (Id a) + luid <- qualifyLocal $ Id a + account <- lift . liftSem $ User.getLocalUserAccount luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -979,12 +986,13 @@ ensureAccountDeleted :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member UserStore r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> AppT r DeleteUserResult -ensureAccountDeleted uid = do - mbAcc <- liftSem $ getLocalUserAccount uid +ensureAccountDeleted luid@(tUnqualified -> uid) = do + mbAcc <- liftSem $ User.getLocalUserAccount luid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1112,10 +1120,12 @@ enqueueMultiDeleteCallsCounter = } getLegalHoldStatus :: - (Member GalleyAPIAccess r) => - UserId -> + ( Member GalleyAPIAccess r, + Member UserSubsystem r + ) => + Local UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< liftSem (getLocalUserAccount uid) +getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) =<< User.getLocalUserAccount uid getLegalHoldStatus' :: (Member GalleyAPIAccess r) => @@ -1128,32 +1138,6 @@ getLegalHoldStatus' user = teamMember <- GalleyAPIAccess.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember --- | Find user accounts for a given identity, both activated and those --- currently pending activation. -lookupExtendedAccountsByIdentity :: - (Member UserKeyStore r) => - EmailAddress -> - Bool -> - AppT r [ExtendedUserAccount] -lookupExtendedAccountsByIdentity email includePendingInvitations = do - let uk = mkEmailKey email - activeUid <- liftSem $ lookupKey uk - uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) - result <- liftSem $ getLocalExtendedAccounts =<< qualifyLocal (nub $ catMaybes [activeUid, uidFromKey]) - if includePendingInvitations - then pure result - else pure $ filter ((/= PendingInvitation) . accountStatus . account) result - --- | Find user accounts for a given identity, both activated and those --- currently pending activation. -lookupAccountsByIdentity :: - (Member UserKeyStore r) => - EmailAddress -> - Bool -> - AppT r [UserAccount] -lookupAccountsByIdentity email includePendingInvitations = - account <$$> lookupExtendedAccountsByIdentity email includePendingInvitations - isBlacklisted :: (Member BlockListStore r) => EmailAddress -> AppT r Bool isBlacklisted email = do let uk = mkEmailKey email From f7f76cd95f812ffccb8e8cfbc39f89a6f0c2f801 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 5 Sep 2024 15:49:56 +0200 Subject: [PATCH 56/96] Fix a Cassandra query for StoredUser --- libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 5dede3441d4..b72e2029482 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -134,7 +134,7 @@ lookupLocaleImpl u = do selectUser :: PrepQuery R (Identity UserId) (TupleType StoredUser) selectUser = - "SELECT id, name, text_status, picture, email, sso_id, accent_id, assets, \ + "SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, \ \activated, status, expires, language, country, provider, service, \ \handle, team, managed_by, supported_protocols \ \FROM user where id = ?" From 5c500d4ec8dcf7cdb459c0b9a427a4931229ebee Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 9 Sep 2024 08:58:21 +0200 Subject: [PATCH 57/96] Hi ci From 29fcb2e2af56f4ed5fd71506e17e001271ec81ba Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 9 Sep 2024 09:29:19 +0200 Subject: [PATCH 58/96] Apply feedback / cleanup. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 24 +++++-------------- services/brig/src/Brig/Data/Activation.hs | 3 +-- services/brig/test/integration/API/Team.hs | 2 +- 3 files changed, 8 insertions(+), 21 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 1dbd748f240..b33c8282a48 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} module Wire.UserSubsystem where @@ -55,17 +56,14 @@ instance Default UserProfileUpdate where -- | how to get an account for a user data GetBy = MkGetBy - { -- | whether or not to include ending invitations in the lookups - includePendingInvitations :: !Bool, - -- -- | whether or not to include users with unverified identities - -- includePendingActivations :: !Bool, - + { -- | whether or not to include pending invitations in the lookups + includePendingInvitations :: Bool, -- | get accounts by 'UserId's - getByUserIds :: ![UserId], + getByUserIds :: [UserId], -- | get accounts by 'Email's - getByEmail :: ![EmailKey], + getByEmail :: [EmailKey], -- | get accounts by their 'Handle' - getByHandle :: ![Handle] + getByHandle :: [Handle] } deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via GenericUniform GetBy @@ -122,16 +120,6 @@ getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) -getLocalUserAccountUnverified :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) -getLocalUserAccountUnverified uid = - listToMaybe - <$> getAccountsBy - ( qualifyAs uid $ - def - { getByUserIds = [tUnqualified uid] - } - ) - getLocalUserAccount :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) getLocalUserAccount uid = listToMaybe diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 0d0cc6570b4..bb43477b8c5 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -103,7 +103,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do luid <- qualifyLocal uid - a <- lift (liftSem $ User.getLocalUserAccountUnverified luid) >>= maybe (throwE invalidUser) pure + a <- lift (liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of @@ -134,7 +134,6 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do - -- Temporary measure until we create AuthSubsystem wrapClientE (codeDeleteImpl (mkPasswordResetKey uid)) claim key uid lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index bbc862b964b..9cec34039bc 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -732,7 +732,7 @@ testInvitationPaging opts brig = do === statusCode (invs, more) <- (ilInvitations &&& ilHasMore) <$> responseJsonError r if more - then -- TODO: improve + then -- FUTUREWORK: improve readability (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step else pure [invs] let checkSize :: (HasCallStack) => Int -> [Int] -> Http () From db1491a4636d197ddc44f283279cfb2f10455b0e Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 9 Sep 2024 10:02:23 +0200 Subject: [PATCH 59/96] Removed export from Cassandra interpreter, use Effect. --- libs/types-common/src/Data/Code.hs | 3 ++- libs/wire-subsystems/src/Wire/ActivationCodeStore.hs | 1 + .../src/Wire/PasswordResetCodeStore/Cassandra.hs | 1 - services/brig/src/Brig/API/Internal.hs | 5 +++++ services/brig/src/Brig/API/Public.hs | 5 +++++ services/brig/src/Brig/API/User.hs | 4 ++++ services/brig/src/Brig/Data/Activation.hs | 8 +++++--- 7 files changed, 22 insertions(+), 5 deletions(-) diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index ba7dadcf2d3..ebbda4f5e20 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -96,7 +96,8 @@ instance ToHttpApiData Value where -- number of seconds remaining. newtype Timeout = Timeout {timeoutDiffTime :: NominalDiffTime} - deriving newtype (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) + deriving newtype (Enum, Num, Fractional, Real, RealFrac) + deriving stock (Eq, Ord, Show) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Timeout) instance ToSchema Timeout where diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs index 9473bd16f58..8f4052b975c 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -25,6 +25,7 @@ import Wire.API.User.Activation import Wire.UserKeyStore data ActivationCodeStore :: Effect where + -- FUTUREWORK: Check out if we can drop the outside Maybe. LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode)) makeSem ''ActivationCodeStore diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index ef043d14bc8..8b923551bc2 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -19,7 +19,6 @@ module Wire.PasswordResetCodeStore.Cassandra ( passwordResetCodeStoreToCassandra, interpretClientToIO, - codeDeleteImpl, ) where diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 045eecce7cd..c9b8f065a98 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -105,6 +105,7 @@ import Wire.EmailSubsystem (EmailSubsystem) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PropertySubsystem import Wire.Rpc import Wire.Sem.Concurrency @@ -140,6 +141,7 @@ servantSitemap :: Member EmailSending r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, + Member PasswordResetCodeStore r, Member PropertySubsystem r ) => ServerT BrigIRoutes.API (Handler r) @@ -192,6 +194,7 @@ accountAPI :: Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, + Member PasswordResetCodeStore r, Member InvitationCodeStore r ) => ServerT BrigIRoutes.AccountAPI (Handler r) @@ -478,6 +481,7 @@ createUserNoVerify :: Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => NewUser -> @@ -502,6 +506,7 @@ createUserNoVerifySpar :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => NewUserSpar -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 70e2d6ebcbd..ca1c938d7e8 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -153,6 +153,7 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.PropertySubsystem import Wire.Sem.Concurrency @@ -286,6 +287,7 @@ servantSitemap :: Member EmailSending r, Member VerificationCodeSubsystem r, Member PropertySubsystem r, + Member PasswordResetCodeStore r, Member InvitationCodeStore r ) => ServerT BrigAPI (Handler r) @@ -694,6 +696,7 @@ createUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member UserSubsystem r, + Member PasswordResetCodeStore r, Member EmailSending r ) => Public.NewUserPublic -> @@ -1246,6 +1249,7 @@ activate :: Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => Public.ActivationKey -> @@ -1264,6 +1268,7 @@ activateKey :: Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => Public.Activate -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 373d3cba2ae..311f0bddf74 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -140,6 +140,7 @@ import Wire.GalleyAPIAccess as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation, StoredInvitationInfo) import Wire.InvitationCodeStore qualified as InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem import Wire.Sem.Concurrency @@ -268,6 +269,7 @@ createUser :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, + Member PasswordResetCodeStore r, Member InvitationCodeStore r ) => NewUser -> @@ -690,6 +692,7 @@ activate :: Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, + Member PasswordResetCodeStore r, Member UserSubsystem r ) => ActivationTarget -> @@ -706,6 +709,7 @@ activateWithCurrency :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index bb43477b8c5..e2cc9f3c450 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -48,7 +48,8 @@ import Text.Printf (printf) import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password -import Wire.PasswordResetCodeStore.Cassandra +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) +import Wire.PasswordResetCodeStore qualified as Password import Wire.UserKeyStore import Wire.UserSubsystem (UserSubsystem) import Wire.UserSubsystem qualified as User @@ -89,7 +90,8 @@ maxAttempts = 3 -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: forall r. - ( Member UserSubsystem r + ( Member UserSubsystem r, + Member PasswordResetCodeStore r ) => ActivationKey -> ActivationCode -> @@ -134,7 +136,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do - wrapClientE (codeDeleteImpl (mkPasswordResetKey uid)) + lift . liftSem $ Password.codeDelete (mkPasswordResetKey uid) claim key uid lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) for_ oldKey $ lift . adhocUserKeyStoreInterpreter . deleteKey From 163fc18111607615ee65af1b87e7f93c9be52873 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 9 Sep 2024 10:05:30 +0200 Subject: [PATCH 60/96] [chore] Improved order of checks for PR sanitising. --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index a3aac683f65..9a53fc3cb13 100644 --- a/Makefile +++ b/Makefile @@ -162,7 +162,7 @@ lint-all: formatc hlint-check-all lint-common # The extra 'hlint-check-pr' has been witnessed to be necessary due to # some bu in `hlint-inplace-pr`. Details got lost in history. .PHONY: lint-all-shallow -lint-all-shallow: formatf hlint-inplace-pr hlint-check-pr lint-common +lint-all-shallow: lint-common formatf hlint-inplace-pr hlint-check-pr .PHONY: lint-common lint-common: check-local-nix-derivations treefmt-check # weeder (does not work on CI yet) From 4578fe4565485535a86df1afa6a6a7e720b16463 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 9 Sep 2024 11:47:10 +0200 Subject: [PATCH 61/96] Fixed bug in filtering users. --- .../src/Wire/UserSubsystem/Interpreter.hs | 13 ++++++++----- libs/wire-subsystems/test/unit/Wire/MiniBackend.hs | 4 ++-- .../test/unit/Wire/UserSubsystem/InterpreterSpec.hs | 6 +++--- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8a2af0ad847..c8f4c861b34 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -16,7 +16,7 @@ import Data.LegalHold import Data.List.Extra (nubOrd) import Data.Qualified import Data.Time.Clock -import Imports hiding (local) +import Imports import Polysemy import Polysemy.Error hiding (try) import Polysemy.Input @@ -514,12 +514,12 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations filterPendingInvitations = filterM ( \((.account) -> acc) -> - if acc.accountStatus == PendingInvitation - then do + case acc.accountStatus of + PendingInvitation -> case accountIdentityEmail acc of -- TODO: ensure this case is sound -- Some tests fail but they seem to not rely on this - Nothing -> pure includePendingInvitations + Nothing -> pure False Just key -> do -- This is the case of expired invitations for users still pending hasInvitation <- isJust <$> lookupInvitationByEmail key @@ -529,7 +529,10 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations -- job akin to 'pendingUserActivationCleanup' enqueueUserDeletion (userId acc.accountUser) pure (hasInvitation && includePendingInvitations) - else pure True + Active -> pure True + Suspended -> pure True + Deleted -> pure False -- We explicitly filter out deleted users now. + Ephemeral -> pure True ) accountIdentityEmail :: UserAccount -> Maybe EmailAddress diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index a8017ef998f..d5d4a789261 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -95,7 +95,7 @@ newtype NotPendingEmptyIdentityStoredUser = NotPendingEmptyIdentityStoredUser St instance Arbitrary NotPendingEmptyIdentityStoredUser where arbitrary = do user <- arbitrary `suchThat` \user -> isNothing user.identity - notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral]) pure $ NotPendingEmptyIdentityStoredUser (user {status = notPendingStatus}) newtype PendingStoredUser = PendingStoredUser StoredUser @@ -112,7 +112,7 @@ newtype NotPendingStoredUser = NotPendingStoredUser StoredUser instance Arbitrary NotPendingStoredUser where arbitrary = do user <- arbitrary `suchThat` \user -> isJust user.identity - notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral]) pure $ NotPendingStoredUser (user {status = notPendingStatus}) type AllErrors = diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index eb8d650282f..a29419aaf59 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -297,7 +297,7 @@ spec = describe "UserSubsystem.Interpreter" do in result === [] prop "GetBy userId works for pending if explicitly queried" $ - \(PendingStoredUser alice') email teamId invitationInfo localDomain visibility locale -> + \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> let config = UserSubsystemConfig visibility locale alice = alice' @@ -372,7 +372,7 @@ spec = describe "UserSubsystem.Interpreter" do getAccountsBy getBy in result === [] prop "GetBy email pending works if explicit" $ - \(PendingStoredUser alice') teamId email localDomain invitationInfo visibility locale -> + \(PendingNotEmptyIdentityStoredUser alice') teamId email localDomain invitationInfo visibility locale -> let config = UserSubsystemConfig visibility locale emailKey = mkEmailKey email getBy = @@ -432,7 +432,7 @@ spec = describe "UserSubsystem.Interpreter" do in result === [mkAccountFromStored localDomain locale alice] prop "GetBy pending user requires a valid invitation" $ - \(PendingStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> let config = UserSubsystemConfig visibility locale emailKey = mkEmailKey email getBy = From d5b704d02db195e1481d904aa24f9e130e874c5c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 10 Sep 2024 10:48:51 +0200 Subject: [PATCH 62/96] Fix user lookup by passing include pending invitations --- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 16 +++++++++++++--- services/brig/src/Brig/API/Client.hs | 2 +- services/brig/src/Brig/API/Public.hs | 4 ++-- services/brig/src/Brig/API/User.hs | 10 +++++----- services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 8 ++++---- services/spar/test-integration/Util/Core.hs | 10 ++++++++++ 8 files changed, 37 insertions(+), 17 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index b33c8282a48..15efa61782d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -120,12 +120,22 @@ getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) -getLocalUserAccount :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserAccount) -getLocalUserAccount uid = +getLocalUserAccount :: + (Member UserSubsystem r) => + Local UserId -> + -- TODO: Remove boolean blindness + + -- | Include pending invitations or not + Bool -> + Sem r (Maybe UserAccount) +getLocalUserAccount uid includePendingInvitations = listToMaybe <$> getAccountsBy ( qualifyAs uid $ - def {getByUserIds = [tUnqualified uid]} + def + { getByUserIds = [tUnqualified uid], + includePendingInvitations + } ) getLocalExtendedAccounts :: (Member UserSubsystem r) => Local [UserId] -> Sem r [ExtendedUserAccount] diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index d1cfebe9998..ccd4c160520 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -202,7 +202,7 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- (lift . liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + usr <- (lift . liftSem $ User.getLocalUserAccount luid False) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index ca1c938d7e8..a584454047e 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -634,7 +634,7 @@ getRichInfo lself user = do -- other user let fetch luid = ifNothing (errorToWai @'E.UserNotFound) - =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount luid) + =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount luid False) selfUser <- fetch lself otherUser <- fetch luser case (Public.userTeam selfUser, Public.userTeam otherUser) of @@ -1321,7 +1321,7 @@ sendVerificationCode req = do getAccount email = lift . liftSem $ do mbUserId <- lookupKey $ mkEmailKey email mbLUserId <- qualifyLocal' `traverse` mbUserId - join <$> User.getLocalUserAccount `traverse` mbLUserId + join <$> (flip User.getLocalUserAccount False) `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 311f0bddf74..7f7fb212090 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -299,7 +299,7 @@ createUser new = do join <$> for mbInv do \invid -> liftSem $ do luid :: Local UserId <- qualifyLocal' (coerce invid) - User.getLocalUserAccount luid + User.getLocalUserAccount luid True let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -895,7 +895,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser luid@(tUnqualified -> uid) pwd = do - account <- lift . liftSem $ User.getLocalUserAccount luid + account <- lift . liftSem $ User.getLocalUserAccount luid False case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -972,7 +972,7 @@ verifyDeleteUser d = do c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) luid <- qualifyLocal $ Id a - account <- lift . liftSem $ User.getLocalUserAccount luid + account <- lift . liftSem $ User.getLocalUserAccount luid False for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -996,7 +996,7 @@ ensureAccountDeleted :: Local UserId -> AppT r DeleteUserResult ensureAccountDeleted luid@(tUnqualified -> uid) = do - mbAcc <- liftSem $ User.getLocalUserAccount luid + mbAcc <- liftSem $ User.getLocalUserAccount luid False case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1129,7 +1129,7 @@ getLegalHoldStatus :: ) => Local UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) =<< User.getLocalUserAccount uid +getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) =<< User.getLocalUserAccount uid False getLegalHoldStatus' :: (Member GalleyAPIAccess r) => diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index e2cc9f3c450..dc60cde5574 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -105,7 +105,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do luid <- qualifyLocal uid - a <- lift (liftSem $ User.getLocalUserAccount luid) >>= maybe (throwE invalidUser) pure + a <- lift (liftSem $ User.getLocalUserAccount luid False) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index b7effed797b..3d6a9385667 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -74,7 +74,7 @@ onEvent n = handleTimeout $ case n of msg (val "Processing user delete event") ~~ field "user" (toByteString uid) luid <- qualifyLocal' uid - getLocalUserAccount luid >>= mapM_ API.deleteAccount + getLocalUserAccount luid True >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index fa4ca7f292c..694374e56a2 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -139,7 +139,7 @@ verifyCode mbCode action luid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ User.getLocalUserAccount luid + account <- lift . liftSem $ User.getLocalUserAccount luid False let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -155,7 +155,7 @@ verifyCode mbCode action luid = do Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ User.getLocalUserAccount u + mbAccount <- lift . liftSem $ User.getLocalUserAccount u False pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -233,7 +233,7 @@ revokeAccess :: revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do - account <- User.getLocalUserAccount luid + account <- User.getLocalUserAccount luid False pure $ maybe False (Data.isSamlUser . ((.accountUser))) account unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll @@ -331,7 +331,7 @@ isPendingActivation ident = case ident of Nothing -> pure False Just usr -> liftSem do lusr <- qualifyLocal' usr - maybe False (checkAccount k) <$> User.getLocalUserAccount lusr + maybe False (checkAccount k) <$> User.getLocalUserAccount lusr True checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 78a8921c98f..3f56bfac5fc 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -36,6 +36,7 @@ module Util.Core -- * Test helpers it, + fit, pending, pendingWith, shouldRespondWith, @@ -293,6 +294,15 @@ it :: SpecWith TestEnv it msg bdy = Test.Hspec.it msg $ runReaderT bdy +fit :: + (HasCallStack) => + -- or, more generally: + -- MonadIO m, Example (TestEnv -> m ()), Arg (TestEnv -> m ()) ~ TestEnv + String -> + TestSpar () -> + SpecWith TestEnv +fit msg bdy = Test.Hspec.fit msg $ runReaderT bdy + pending :: (HasCallStack, MonadIO m) => m () pending = liftIO Test.Hspec.pending From 78b86609752e7283b59d6aa45b94f20f1a9823fe Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 10 Sep 2024 14:33:04 +0200 Subject: [PATCH 63/96] Revert "WIP: Remove extra Timeout type" This reverts commit ac6e48de6c7b6cb90acd990cb3cab409842925ca. --- libs/types-common/default.nix | 2 ++ libs/types-common/src/Data/Code.hs | 15 ++------- libs/types-common/src/Util/Timeout.hs | 32 +++++++++++++++++++ libs/types-common/types-common.cabal | 2 ++ libs/wire-api/src/Wire/API/User/Auth.hs | 1 + libs/wire-api/src/Wire/API/User/Scim.hs | 1 + .../src/Wire/InvitationCodeStore.hs | 2 +- .../src/Wire/InvitationCodeStore/Cassandra.hs | 2 +- services/brig/src/Brig/API/Client.hs | 1 + services/brig/src/Brig/API/User.hs | 1 + services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/Options.hs | 2 +- services/brig/src/Brig/Run.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 5 +-- services/brig/src/Brig/User/Auth/Cookie.hs | 3 +- services/brig/test/integration/API/Team.hs | 2 +- .../brig/test/integration/API/User/Account.hs | 3 +- .../brig/test/integration/API/User/Auth.hs | 4 +-- .../brig/test/integration/API/User/Client.hs | 3 +- .../test/integration/API/User/Connection.hs | 2 +- .../brig/test/integration/API/User/Handles.hs | 2 +- .../integration/API/User/PasswordReset.hs | 4 +-- .../test/integration/API/User/RichInfo.hs | 2 +- services/galley/src/Galley/API/Update.hs | 1 + 24 files changed, 63 insertions(+), 33 deletions(-) create mode 100644 libs/types-common/src/Util/Timeout.hs diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index 7421aae499c..c4bbd61c01b 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -40,6 +40,7 @@ , quickcheck-instances , random , schema-profunctor +, scientific , servant-server , string-conversions , tagged @@ -96,6 +97,7 @@ mkDerivation { quickcheck-instances random schema-profunctor + scientific servant-server tagged tasty diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index ebbda4f5e20..6bba1c5f087 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -22,11 +22,7 @@ -- with this program. If not, see . -- | Types for verification codes. -module Data.Code - ( module Data.Code, - module Data.Time.Clock, - ) -where +module Data.Code where import Cassandra hiding (Value) import Data.Aeson qualified as A @@ -96,8 +92,7 @@ instance ToHttpApiData Value where -- number of seconds remaining. newtype Timeout = Timeout {timeoutDiffTime :: NominalDiffTime} - deriving newtype (Enum, Num, Fractional, Real, RealFrac) - deriving stock (Eq, Ord, Show) + deriving (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema Timeout) instance ToSchema Timeout where @@ -106,12 +101,6 @@ instance ToSchema Timeout where roundDiffTime :: NominalDiffTime -> Int32 roundDiffTime = round -instance Read Timeout where - readsPrec i s = - case readsPrec i s of - [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] - _ -> [] - -- | A 'Timeout' is rendered as an integer representing the number of seconds remaining. instance ToByteString Timeout where builder (Timeout t) = builder (round t :: Int32) diff --git a/libs/types-common/src/Util/Timeout.hs b/libs/types-common/src/Util/Timeout.hs new file mode 100644 index 00000000000..e09c358e88d --- /dev/null +++ b/libs/types-common/src/Util/Timeout.hs @@ -0,0 +1,32 @@ +module Util.Timeout + ( Timeout (..), + module Data.Time.Clock, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Scientific +import Data.Time.Clock +import Imports + +newtype Timeout = Timeout + { timeoutDiff :: NominalDiffTime + } + deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) + +instance Read Timeout where + readsPrec i s = + case readsPrec i s of + [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] + _ -> [] + +instance FromJSON Timeout where + parseJSON (Number n) = + let defaultV = 3600 + bounded = toBoundedInteger n :: Maybe Int64 + in pure $ + Timeout $ + fromIntegral @Int $ + maybe defaultV fromIntegral bounded + parseJSON v = typeMismatch "activationTimeout" v diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 5fb1c0ca72c..77b3e7e528f 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -38,6 +38,7 @@ library Util.Options Util.Options.Common Util.Test + Util.Timeout Wire.Arbitrary other-modules: Paths_types_common @@ -125,6 +126,7 @@ library , quickcheck-instances >=0.3.16 , random >=1.1 , schema-profunctor + , scientific , servant-server , tagged >=0.8 , tasty >=0.11 diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index e5c7e48ac41..e395fece0e6 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -77,6 +77,7 @@ import Data.Schema import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Lazy.Encoding qualified as LT +import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra hiding (first) import Data.ZAuth.Token (header, time) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 6c3ea06dd1b..21b82fb61ee 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -65,6 +65,7 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.These import Data.These.Combinators +import Data.Time.Clock (UTCTime) import Imports import SAML2.WebSSO qualified as SAML import SAML2.WebSSO.Test.Arbitrary () diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs index 300ab934308..a9183ae2da9 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -21,7 +21,6 @@ module Wire.InvitationCodeStore where import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import Data.Code import Data.Id (InvitationId, TeamId, UserId) import Data.Json.Util (UTCTimeMillis) import Data.Range (Range) @@ -31,6 +30,7 @@ import Polysemy import Polysemy.TinyLog (TinyLog) import System.Logger.Message qualified as Log import URI.ByteString +import Util.Timeout import Wire.API.Team.Invitation (Invitation (inviteeEmail)) import Wire.API.Team.Invitation qualified as Public import Wire.API.Team.Role (Role, defaultRole) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index a29755bdd57..29873ff5bf4 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -1,7 +1,6 @@ module Wire.InvitationCodeStore.Cassandra where import Cassandra -import Data.Code import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as Conduit import Data.Id @@ -14,6 +13,7 @@ import OpenSSL.Random (randBytes) import Polysemy import Polysemy.Embed import UnliftIO.Async (pooledMapConcurrentlyN_) +import Util.Timeout import Wire.API.Team.Role (Role) import Wire.API.User import Wire.InvitationCodeStore diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index ccd4c160520..300f942a80c 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -83,6 +83,7 @@ import Data.Qualified import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error +import Data.Time.Clock (UTCTime) import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 7f7fb212090..c96cdd0e08e 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -107,6 +107,7 @@ import Data.List1 as List1 (List1, singleton) import Data.Misc import Data.Qualified import Data.Range +import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) import Imports hiding (local) import Network.Wai.Utilities diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index dc60cde5574..a8b12021111 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -34,7 +34,6 @@ import Brig.Data.User import Brig.Types.Intra import Cassandra import Control.Error -import Data.Code import Data.Id import Data.Text (pack) import Data.Text.Ascii qualified as Ascii @@ -45,6 +44,7 @@ import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Polysemy import Text.Printf (printf) +import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 721152585ca..31d586cf165 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -32,7 +32,6 @@ import Control.Lens qualified as Lens import Data.Aeson import Data.Aeson.Types qualified as A import Data.Char qualified as Char -import Data.Code import Data.Code qualified as Code import Data.Default import Data.Domain (Domain (..)) @@ -50,6 +49,7 @@ import Network.AMQP.Extended import Network.DNS qualified as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options +import Util.Timeout import Wire.API.Allowlists (AllowlistEmailDomains (..)) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index ef6a9cf2978..eda8c9fe88f 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -46,7 +46,6 @@ import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (randomRIO) import Data.Aeson qualified as Aeson import Data.ByteString.UTF8 qualified as UTF8 -import Data.Code import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) @@ -66,6 +65,7 @@ import Servant qualified import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options +import Util.Timeout import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Public.Brig diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 694374e56a2..fae44bcd6e7 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -50,7 +50,7 @@ import Cassandra import Control.Error hiding (bool) import Control.Lens (to, view) import Data.ByteString.Conversion (toByteString) -import Data.Code as Code +import Data.Code qualified as Code import Data.Default import Data.Handle (Handle) import Data.Id @@ -67,6 +67,7 @@ import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) +import Util.Timeout import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public import Wire.API.User @@ -181,7 +182,7 @@ withRetryLimit action uid = do let bkey = BudgetKey ("login#" <> idToText uid) budget = Budget - (timeoutDiffTime $ Opt.timeout opts) + (timeoutDiff $ Opt.timeout opts) (fromIntegral $ Opt.retryLimit opts) bresult <- action bkey budget case bresult of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 35bee4e9f14..f9f621ae4bb 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -48,15 +48,16 @@ import Control.Error import Control.Lens (to, view) import Control.Monad.Except import Data.ByteString.Conversion -import Data.Code import Data.Id import Data.List qualified as List import Data.Proxy import Data.RetryAfter +import Data.Time.Clock import Imports import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log +import Util.Timeout import Web.Cookie qualified as WebCookie import Wire.API.User.Auth import Wire.SessionStore qualified as Store diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 9cec34039bc..f262d6c8f7c 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -35,7 +35,6 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.ByteString.Conversion import Data.ByteString.Lazy (toStrict) -import Data.Code import Data.Default (def) import Data.Either.Extra (eitherToMaybe) import Data.Id @@ -60,6 +59,7 @@ import URI.ByteString import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcurrently) import Util import Util.AWS as Util +import Util.Timeout import Web.Cookie (parseSetCookie, setCookieName) import Wire.API.Asset import Wire.API.Connection diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index e7e8dbec0df..4772091981c 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -43,7 +43,6 @@ import Data.Aeson.Lens qualified as AesonL import Data.ByteString qualified as C8 import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion -import Data.Code (Timeout, UTCTime, diffUTCTime) import Data.Domain import Data.Handle import Data.Id @@ -60,7 +59,6 @@ import Data.String.Conversions import Data.Text qualified as T import Data.Text qualified as Text import Data.Text.Encoding qualified as T -import Data.Time (getCurrentTime) import Data.UUID qualified as UUID import Data.UUID.V4 qualified as UUID import Federator.MockServer (FederatedRequest (..), MockException (..)) @@ -79,6 +77,7 @@ import Test.Tasty.HUnit import UnliftIO (mapConcurrently_) import Util import Util.AWS as Util +import Util.Timeout import Web.Cookie (parseSetCookie) import Wire.API.Asset hiding (Asset) import Wire.API.Asset qualified as Asset diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index 1da57d53fda..79b6ac62bf8 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -40,7 +40,6 @@ import Data.Aeson as Aeson hiding (json) import Data.ByteString qualified as BS import Data.ByteString.Conversion import Data.ByteString.Lazy qualified as Lazy -import Data.Code (Timeout (..)) import Data.Handle (parseHandle) import Data.Id import Data.Misc (PlainTextPassword6, plainTextPassword6, plainTextPassword6Unsafe) @@ -61,6 +60,7 @@ import Test.Tasty.HUnit import Test.Tasty.HUnit qualified as HUnit import UnliftIO.Async hiding (wait) import Util +import Util.Timeout import Wire.API.Conversation (Conversation (..)) import Wire.API.Password (Password, mkSafePasswordScrypt) import Wire.API.User as Public @@ -1046,7 +1046,7 @@ testSuspendInactiveUsers config brig cookieType endPoint = do do diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index cd0e3fd1816..fb6bf3fc06d 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -40,7 +40,6 @@ import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as M import Data.Aeson.Lens import Data.ByteString.Conversion -import Data.Code (Timeout) import Data.Code qualified as Code import Data.Coerce (coerce) import Data.Default @@ -56,7 +55,6 @@ import Data.Set qualified as Set import Data.String.Conversions import Data.Text.Ascii (AsciiChars (validate), encodeBase64UrlUnpadded, toText) import Data.Text.Encoding qualified as T -import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import Data.UUID (toByteString) import Data.UUID qualified as UUID @@ -71,6 +69,7 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification import Wire.API.MLS.CipherSuite import Wire.API.Routes.Version diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 963d8c4c840..76aebdaff09 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -29,7 +29,6 @@ import Brig.Data.Connection (remoteConnectionInsert) import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion -import Data.Code import Data.Domain import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) @@ -40,6 +39,7 @@ import Network.Wai.Utilities.Error qualified as Error import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Connection import Wire.API.Conversation import Wire.API.Federation.API.Brig diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index cb6381f1bf0..d94f3fbe00f 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -32,7 +32,6 @@ import Control.Monad.Catch (MonadCatch) import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Conversion -import Data.Code (Timeout) import Data.Handle (parseHandle) import Data.Id import Data.List1 qualified as List1 @@ -47,6 +46,7 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification hiding (target) import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.Team.SearchVisibility diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index e77b02d25fc..034c6c40ece 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -23,17 +23,17 @@ module API.User.PasswordReset where import API.User.Util -import Bilge hiding (accept) +import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Options qualified as Opt import Cassandra qualified as DB import Data.Aeson as A import Data.Aeson.KeyMap qualified as KeyMap -import Data.Code (Timeout) import Data.Misc import Imports import Test.Tasty hiding (Timeout) import Util +import Util.Timeout import Wire.API.User import Wire.API.User.Auth diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index 7e4f7b67dcf..2ce2855a1cc 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -28,13 +28,13 @@ import Bilge.Assert import Brig.Options import Brig.Options qualified as Opt import Data.CaseInsensitive qualified as CI -import Data.Code import Data.List1 qualified as List1 import Data.Text qualified as Text import Imports import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.RichInfo diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 55af7c296cc..a05438a3e10 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -83,6 +83,7 @@ import Data.Misc (HttpsUrl) import Data.Qualified import Data.Set qualified as Set import Data.Singletons +import Data.Time import Galley.API.Action import Galley.API.Error import Galley.API.Mapping From 7b93bebb51a27590fecf258ca354ae2b37979bbb Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 10 Sep 2024 17:45:27 +0200 Subject: [PATCH 64/96] [fix] adhere to the old behaviour of the getby query --- .../src/Wire/UserSubsystem/Interpreter.hs | 68 ++++++++----------- 1 file changed, 30 insertions(+), 38 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index c8f4c861b34..e2528ec1574 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -506,53 +506,45 @@ getExtendedAccountsByImpl :: Local GetBy -> Sem r [ExtendedUserAccount] getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do - config <- input - - let storedToExtAcc = mkExtendedAccountFromStored domain config.defaultLocale - - filterPendingInvitations :: [ExtendedUserAccount] -> Sem r [ExtendedUserAccount] - filterPendingInvitations = - filterM - ( \((.account) -> acc) -> - case acc.accountStatus of - PendingInvitation -> - case accountIdentityEmail acc of - -- TODO: ensure this case is sound - -- Some tests fail but they seem to not rely on this - Nothing -> pure False - Just key -> do - -- This is the case of expired invitations for users still pending - hasInvitation <- isJust <$> lookupInvitationByEmail key - unless hasInvitation do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - -- job akin to 'pendingUserActivationCleanup' - enqueueUserDeletion (userId acc.accountUser) - pure (hasInvitation && includePendingInvitations) - Active -> pure True - Suspended -> pure True - Deleted -> pure False -- We explicitly filter out deleted users now. - Ephemeral -> pure True - ) - - accountIdentityEmail :: UserAccount -> Maybe EmailAddress - accountIdentityEmail acc = - case acc.accountUser.userIdentity of - Just (EmailIdentity mail) -> Just mail - Just (SSOIdentity _ (Just mail)) -> Just mail - -- TODO: fix this error - _ -> Nothing -- error "SCIM invited user should have an email" + storedToExtAcc <- do + config <- input + pure $ mkExtendedAccountFromStored domain config.defaultLocale + handleUserIds :: [UserId] <- wither lookupHandle getByHandle accsByIds :: [ExtendedUserAccount] <- getUsers (nubOrd $ handleUserIds <> getByUserIds) <&> map storedToExtAcc - >>= filterPendingInvitations + >>= filterM validatePendingInvitation accsByEmail :: [ExtendedUserAccount] <- flip foldMap getByEmail \ek -> do mactiveUid <- lookupKey ek getUsers (nubOrd . catMaybes $ [mactiveUid]) <&> map storedToExtAcc - >>= filterPendingInvitations + >>= filterM validatePendingInvitation pure (nubOrd $ accsByIds <> accsByEmail) + where + validatePendingInvitation :: ExtendedUserAccount -> Sem r Bool + validatePendingInvitation ExtendedUserAccount {account} = + case account.accountUser.userIdentity of + -- TODO: ensure this case is sound + -- Some tests fail but they seem to not rely on this + Nothing -> pure False + Just ident -> case account.accountStatus of + PendingInvitation -> + if includePendingInvitations + then case emailIdentity ident of + Just email -> do + hasInvitation <- isJust <$> lookupInvitationByEmail email + unless hasInvitation $ do + -- user invited via scim should expire together with its invitation + -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring + enqueueUserDeletion (userId account.accountUser) + pure hasInvitation + Nothing -> error "validatePendingInvitation: should never happen, user invited via scim always has an email" + else pure False + Active -> pure True + Suspended -> pure True + Deleted -> pure True -- TODO(mangoiv): previous comment said "We explicitly filter out deleted users now." Why? + Ephemeral -> pure True From 3254a773258f5dbe8fc694d0a1d5e9680e0eb416 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 10 Sep 2024 23:03:18 +0200 Subject: [PATCH 65/96] Polish getBy query (not changing behavior). --- .../src/Wire/UserSubsystem/Interpreter.hs | 42 ++++++++++++++----- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e2528ec1574..9a739b0070f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -515,36 +515,56 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations accsByIds :: [ExtendedUserAccount] <- getUsers (nubOrd $ handleUserIds <> getByUserIds) <&> map storedToExtAcc - >>= filterM validatePendingInvitation + >>= filterM want accsByEmail :: [ExtendedUserAccount] <- flip foldMap getByEmail \ek -> do mactiveUid <- lookupKey ek getUsers (nubOrd . catMaybes $ [mactiveUid]) <&> map storedToExtAcc - >>= filterM validatePendingInvitation + >>= filterM want pure (nubOrd $ accsByIds <> accsByEmail) where - validatePendingInvitation :: ExtendedUserAccount -> Sem r Bool - validatePendingInvitation ExtendedUserAccount {account} = + -- not wanted: + -- . users without identity + -- . pending users without matching invitation (those are garbage-collected) + -- . TODO: deleted users? + want :: ExtendedUserAccount -> Sem r Bool + want ExtendedUserAccount {account} = case account.accountUser.userIdentity of - -- TODO: ensure this case is sound - -- Some tests fail but they seem to not rely on this Nothing -> pure False Just ident -> case account.accountStatus of PendingInvitation -> if includePendingInvitations then case emailIdentity ident of + -- TODO(fisx): emailIdentity does not return an unvalidated address in case a + -- validated one cannot be found. that's probably wrong? split up into + -- validEmailIdentity, anyEmailIdentity? Just email -> do hasInvitation <- isJust <$> lookupInvitationByEmail email - unless hasInvitation $ do - -- user invited via scim should expire together with its invitation - -- FIXME(mangoiv): this is not the right place to do this, ideally this should be part of a recurring - enqueueUserDeletion (userId account.accountUser) + gcHack hasInvitation (userId account.accountUser) pure hasInvitation - Nothing -> error "validatePendingInvitation: should never happen, user invited via scim always has an email" + Nothing -> error "getExtendedAccountsByImpl: should never happen, user invited via scim always has an email" else pure False Active -> pure True Suspended -> pure True Deleted -> pure True -- TODO(mangoiv): previous comment said "We explicitly filter out deleted users now." Why? Ephemeral -> pure True + + -- user invited via scim expires together with its invitation. the UserSubsystem interface + -- semantics hides the fact that pending users have no TTL field. we chose to emulate this + -- in this convoluted way (by making the invitation expire and then checking if it's still + -- there when looking up pending users), because adding TTLs would have been a much bigger + -- change in the database schema (`enqueueUserDeletion` would need to happen purely based + -- on TTL values in cassandra, and there is too much application logic involved there). + -- + -- we could also delete these users here and run a background process that scans for + -- pending users without invitation. we chose not to because enqueuing the user deletion + -- here is very cheap, and avoids database traffic if the user is looked up again. if the + -- background job is reliably taking care of this, there is no strong reason to keep this + -- function. + -- + -- there are certainly other ways to improve this, but they probably involve a non-trivial + -- database schema re-design. + gcHack :: Bool -> UserId -> Sem r () + gcHack hasInvitation uid = unless hasInvitation (enqueueUserDeletion uid) From eb068f3bc996130004626c25aae7cb3c3975b482 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 11 Sep 2024 08:43:14 +0200 Subject: [PATCH 66/96] hi ci From 66c9548c8fe26d8bcd8fea0748ca54d8662d9baf Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 11 Sep 2024 09:19:33 +0200 Subject: [PATCH 67/96] Attempt to fix tests. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 16 +++++++++----- .../src/Wire/UserSubsystem/Interpreter.hs | 4 ++-- .../Wire/UserSubsystem/InterpreterSpec.hs | 10 --------- services/brig/src/Brig/API/Client.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/Public.hs | 4 ++-- services/brig/src/Brig/API/User.hs | 22 +++++++++++-------- services/brig/src/Brig/Data/Activation.hs | 2 +- .../brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 8 +++---- 10 files changed, 35 insertions(+), 37 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 15efa61782d..8496f78b191 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -58,6 +58,8 @@ instance Default UserProfileUpdate where data GetBy = MkGetBy { -- | whether or not to include pending invitations in the lookups includePendingInvitations :: Bool, + -- | Include users with no identity yet, used for activation + includeNoIdentity :: Bool, -- | get accounts by 'UserId's getByUserIds :: [UserId], -- | get accounts by 'Email's @@ -69,7 +71,7 @@ data GetBy = MkGetBy deriving (Arbitrary) via GenericUniform GetBy instance Default GetBy where - def = MkGetBy False [] [] [] + def = MkGetBy False False [] [] [] data UserSubsystem m a where -- | First arg is for authorization only. @@ -120,21 +122,23 @@ getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) +-- TODO: Remove boolean blindness getLocalUserAccount :: (Member UserSubsystem r) => - Local UserId -> - -- TODO: Remove boolean blindness - -- | Include pending invitations or not Bool -> + -- | Include users without identity + Bool -> + Local UserId -> Sem r (Maybe UserAccount) -getLocalUserAccount uid includePendingInvitations = +getLocalUserAccount includePendingInvitations includeNoIdentity uid = listToMaybe <$> getAccountsBy ( qualifyAs uid $ def { getByUserIds = [tUnqualified uid], - includePendingInvitations + includePendingInvitations, + includeNoIdentity } ) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 9a739b0070f..40b83df8d77 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -505,7 +505,7 @@ getExtendedAccountsByImpl :: ) => Local GetBy -> Sem r [ExtendedUserAccount] -getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do +getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includeNoIdentity, getByEmail, getByHandle, getByUserIds})) = do storedToExtAcc <- do config <- input pure $ mkExtendedAccountFromStored domain config.defaultLocale @@ -532,7 +532,7 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations want :: ExtendedUserAccount -> Sem r Bool want ExtendedUserAccount {account} = case account.accountUser.userIdentity of - Nothing -> pure False + Nothing -> pure includeNoIdentity Just ident -> case account.accountStatus of PendingInvitation -> if includePendingInvitations diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index a29419aaf59..a5d4ad996a3 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -405,16 +405,6 @@ spec = describe "UserSubsystem.Interpreter" do getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] - prop "GetBy userId works even if identity is empty" $ - \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale - getBy = toLocalUnsafe localDomain $ def {getByUserIds = [alice.id]} - localBackend = def {users = [alice]} - result = - runNoFederationStack localBackend Nothing config $ - getAccountsBy getBy - in result === [mkAccountFromStored localDomain locale alice] - prop "GetBy userId if not pending" $ \(NotPendingStoredUser alice) localDomain visibility locale -> let config = UserSubsystemConfig visibility locale diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 300f942a80c..e5a83c008e8 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -203,7 +203,7 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- (lift . liftSem $ User.getLocalUserAccount luid False) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + usr <- (lift . liftSem $ User.getLocalUserAccount False False luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c9b8f065a98..fd4c8108285 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -585,7 +585,7 @@ listActivatedAccountsH dom <- input getExtendedAccountsBy $ dom - $> MkGetBy + $> def { includePendingInvitations = include, getByUserIds = uids, getByEmail = emails, diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index a584454047e..6f1528ed4d9 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -634,7 +634,7 @@ getRichInfo lself user = do -- other user let fetch luid = ifNothing (errorToWai @'E.UserNotFound) - =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount luid False) + =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount False False luid) selfUser <- fetch lself otherUser <- fetch luser case (Public.userTeam selfUser, Public.userTeam otherUser) of @@ -1321,7 +1321,7 @@ sendVerificationCode req = do getAccount email = lift . liftSem $ do mbUserId <- lookupKey $ mkEmailKey email mbLUserId <- qualifyLocal' `traverse` mbUserId - join <$> (flip User.getLocalUserAccount False) `traverse` mbLUserId + join <$> (User.getLocalUserAccount False True) `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index c96cdd0e08e..eb87750de81 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -109,7 +109,7 @@ import Data.Qualified import Data.Range import Data.Time.Clock (UTCTime, addUTCTime) import Data.UUID.V4 (nextRandom) -import Imports hiding (local) +import Imports import Network.Wai.Utilities import Polysemy import Polysemy.Input (Input) @@ -297,10 +297,11 @@ createUser new = do let mbInv = (.invitationId) . fst <$> teamInvitation mbExistingAccount <- lift $ - join <$> for mbInv do - \invid -> liftSem $ do - luid :: Local UserId <- qualifyLocal' (coerce invid) - User.getLocalUserAccount luid True + join + <$> for mbInv do + \invid -> liftSem $ do + luid :: Local UserId <- qualifyLocal' (coerce invid) + User.getLocalUserAccount True False luid let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -896,7 +897,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser luid@(tUnqualified -> uid) pwd = do - account <- lift . liftSem $ User.getLocalUserAccount luid False + account <- lift . liftSem $ User.getLocalUserAccount False False luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -973,7 +974,7 @@ verifyDeleteUser d = do c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) luid <- qualifyLocal $ Id a - account <- lift . liftSem $ User.getLocalUserAccount luid False + account <- lift . liftSem $ User.getLocalUserAccount False True luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -997,7 +998,7 @@ ensureAccountDeleted :: Local UserId -> AppT r DeleteUserResult ensureAccountDeleted luid@(tUnqualified -> uid) = do - mbAcc <- liftSem $ User.getLocalUserAccount luid False + mbAcc <- liftSem $ User.getLocalUserAccount False True luid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1130,7 +1131,10 @@ getLegalHoldStatus :: ) => Local UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) =<< User.getLocalUserAccount uid False +getLegalHoldStatus uid = + liftSem $ + traverse (getLegalHoldStatus' . accountUser) + =<< User.getLocalUserAccount False False uid getLegalHoldStatus' :: (Member GalleyAPIAccess r) => diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index a8b12021111..dbfefa3b70d 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -105,7 +105,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do luid <- qualifyLocal uid - a <- lift (liftSem $ User.getLocalUserAccount luid False) >>= maybe (throwE invalidUser) pure + a <- lift (liftSem $ User.getLocalUserAccount True True luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 3d6a9385667..093b618378d 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -74,7 +74,7 @@ onEvent n = handleTimeout $ case n of msg (val "Processing user delete event") ~~ field "user" (toByteString uid) luid <- qualifyLocal' uid - getLocalUserAccount luid True >>= mapM_ API.deleteAccount + getLocalUserAccount True True luid >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index fae44bcd6e7..0238e2d29a3 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -140,7 +140,7 @@ verifyCode mbCode action luid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ User.getLocalUserAccount luid False + account <- lift . liftSem $ User.getLocalUserAccount False True luid let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -156,7 +156,7 @@ verifyCode mbCode action luid = do Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ User.getLocalUserAccount u False + mbAccount <- lift . liftSem $ User.getLocalUserAccount False True u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -234,7 +234,7 @@ revokeAccess :: revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do - account <- User.getLocalUserAccount luid False + account <- User.getLocalUserAccount False True luid pure $ maybe False (Data.isSamlUser . ((.accountUser))) account unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll @@ -332,7 +332,7 @@ isPendingActivation ident = case ident of Nothing -> pure False Just usr -> liftSem do lusr <- qualifyLocal' usr - maybe False (checkAccount k) <$> User.getLocalUserAccount lusr True + maybe False (checkAccount k) <$> User.getLocalUserAccount True False lusr checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = From 33473b249d2614da6c8426bb366d224b65d1c52c Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 11 Sep 2024 11:03:46 +0200 Subject: [PATCH 68/96] [fix] revert to old behaviour in Brig/API/User - spar was missing a case and hence got returned an email when it should indeed just return the user identity --- services/brig/src/Brig/API/User.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index eb87750de81..173ab6af7b9 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -311,10 +311,13 @@ createUser new = do Just existingAccount -> let existingUser = existingAccount.accountUser mbSSOid = - case (teamInvitation, email, existingUser.userManagedBy) of + case (teamInvitation, email, existingUser.userManagedBy, userSSOId existingUser) of -- isJust teamInvitation And ManagedByScim implies that the -- user invitation has been generated by SCIM and there is no IdP - (Just _, Just em, ManagedByScim) -> + (Just _, _, ManagedByScim, ssoId@(Just (UserScimExternalId _))) -> + -- if the existing user has an external ID, we have to use it because it can differ from the email address + ssoId + (Just _, Just em, ManagedByScim, _) -> Just $ UserScimExternalId (fromEmail em) _ -> newUserSSOId new in ( new From 526d16d96843ae357b11de6c7bdbd13794d4520c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 11 Sep 2024 11:53:02 +0200 Subject: [PATCH 69/96] Fixed invinite loop when deleting users. --- integration/test/Test/Spar.hs | 4 ++-- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 2 ++ .../src/Wire/UserSubsystem/Interpreter.hs | 13 +++++++++++++ services/brig/src/Brig/InternalEvent/Process.hs | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index 12f67d1200e..7c9d2b8bd77 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -29,8 +29,8 @@ testSparUserCreationInvitationTimeout = do res.status `shouldMatchInt` 409 -- However, if we wait until the invitation timeout has passed - -- (assuming it is configured to 10s locally and in CI)... - liftIO $ threadDelay (11_000_000) + -- It's currently configured to 1s local/CI. + liftIO $ threadDelay (2_000_000) -- ...we should be able to create the user again retryT $ bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 8496f78b191..0fbbc6b598f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -80,6 +80,8 @@ data UserSubsystem m a where GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] -- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] + -- | given a local user id, return a UserAccount + GetLocalAccount :: Local UserId -> UserSubsystem m (Maybe UserAccount) -- | Self profile contains things not present in Profile. GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) -- | These give us partial success and hide concurrency in the interpreter. diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 40b83df8d77..efaa1ddb19d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -101,6 +101,7 @@ interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others GetExtendedAccountsBy getBy -> getExtendedAccountsByImpl getBy + GetLocalAccount luid -> getLocalAccountImpl luid GetSelfProfile self -> getSelfProfileImpl self GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update @@ -491,6 +492,18 @@ checkHandlesImpl check num = reverse <$> collectFree [] check num Nothing -> collectFree (h : free) hs (n - 1) Just _ -> collectFree free hs n +getLocalAccountImpl :: + forall r. + ( Member UserStore r, + Member (Input UserSubsystemConfig) r + ) => + Local UserId -> + Sem r (Maybe UserAccount) +getLocalAccountImpl (tSplit -> (domain, uid)) = do + cfg <- input + muser <- getUser uid + pure $ (mkAccountFromStored domain cfg.defaultLocale) <$> muser + -------------------------------------------------------------------------------- -- getting user accounts by different criteria diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 093b618378d..a3ee9b7cdff 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -74,7 +74,7 @@ onEvent n = handleTimeout $ case n of msg (val "Processing user delete event") ~~ field "user" (toByteString uid) luid <- qualifyLocal' uid - getLocalUserAccount True True luid >>= mapM_ API.deleteAccount + getLocalAccount luid >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event From 4215146460f24da0115c1f91de575aeb39f6b16a Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 11 Sep 2024 15:09:35 +0200 Subject: [PATCH 70/96] Fixed semantics, expand for detail -> Previously some functions that we've replaced did not filter users by validity and behaviour was dependent on that. This restores the previous behaviour, expands our helpers from user subystems and moves a type to types-common to avoid passing a meaningless boolean around. --- libs/brig-types/src/Brig/Types/User.hs | 1 - .../src/Data/HavePendingInvitations.hs | 14 ++++++ libs/types-common/types-common.cabal | 1 + libs/wire-api/src/Wire/API/User.hs | 6 --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 27 +++++----- .../src/Wire/UserSubsystem/Interpreter.hs | 11 ++-- .../Wire/UserSubsystem/InterpreterSpec.hs | 50 +++++++++---------- services/brig/src/Brig/API/Client.hs | 3 +- services/brig/src/Brig/API/Internal.hs | 3 +- services/brig/src/Brig/API/Public.hs | 5 +- services/brig/src/Brig/API/User.hs | 10 ++-- services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/Data/User.hs | 1 + services/brig/src/Brig/Provider/API.hs | 2 +- services/brig/src/Brig/Team/Util.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 8 +-- services/brig/src/Brig/User/EJPD.hs | 1 + services/spar/default.nix | 2 + services/spar/spar.cabal | 1 + services/spar/src/Spar/API.hs | 1 + services/spar/src/Spar/Intra/Brig.hs | 1 + services/spar/src/Spar/Intra/BrigApp.hs | 2 +- services/spar/src/Spar/Sem/BrigAccess.hs | 2 +- .../Test/Spar/Scim/UserSpec.hs | 2 +- services/spar/test/Test/Spar/Scim/UserSpec.hs | 2 +- 25 files changed, 88 insertions(+), 72 deletions(-) create mode 100644 libs/types-common/src/Data/HavePendingInvitations.hs diff --git a/libs/brig-types/src/Brig/Types/User.hs b/libs/brig-types/src/Brig/Types/User.hs index f3cc87ba048..75dfe18f59a 100644 --- a/libs/brig-types/src/Brig/Types/User.hs +++ b/libs/brig-types/src/Brig/Types/User.hs @@ -19,7 +19,6 @@ module Brig.Types.User ( ManagedByUpdate (..), RichInfoUpdate (..), PasswordResetPair, - HavePendingInvitations (..), ) where diff --git a/libs/types-common/src/Data/HavePendingInvitations.hs b/libs/types-common/src/Data/HavePendingInvitations.hs new file mode 100644 index 00000000000..03afbe6c77c --- /dev/null +++ b/libs/types-common/src/Data/HavePendingInvitations.hs @@ -0,0 +1,14 @@ +module Data.HavePendingInvitations where + +import Imports +import Wire.Arbitrary + +data HavePendingInvitations + = WithPendingInvitations + | NoPendingInvitations + deriving (Eq, Show, Ord, Generic) + deriving (Arbitrary) via GenericUniform HavePendingInvitations + +fromBool :: Bool -> HavePendingInvitations +fromBool True = WithPendingInvitations +fromBool False = NoPendingInvitations diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 77b3e7e528f..175d3964cdc 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -19,6 +19,7 @@ library Data.Domain Data.ETag Data.Handle + Data.HavePendingInvitations Data.Id Data.Json.Util Data.LegalHold diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 2e63e89dee7..0e65fa6c6d4 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -121,7 +121,6 @@ module Wire.API.User GetPasswordResetCodeResp (..), CheckBlacklistResponse (..), ManagedByUpdate (..), - HavePendingInvitations (..), RichInfoUpdate (..), PasswordResetPair, UpdateSSOIdResponse (..), @@ -308,11 +307,6 @@ instance ToSchema ManagedByUpdate where ManagedByUpdate <$> mbuManagedBy .= field "managed_by" schema -data HavePendingInvitations - = WithPendingInvitations - | NoPendingInvitations - deriving (Eq, Show, Generic) - newtype RichInfoUpdate = RichInfoUpdate {riuRichInfo :: RichInfoAssocList} deriving (Eq, Show, Generic) deriving newtype (Arbitrary) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 0fbbc6b598f..9f04ae15103 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -1,10 +1,15 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -module Wire.UserSubsystem where +module Wire.UserSubsystem + ( module Wire.UserSubsystem, + module Data.HavePendingInvitations, + ) +where import Data.Default import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id import Data.Qualified import Imports @@ -57,9 +62,7 @@ instance Default UserProfileUpdate where -- | how to get an account for a user data GetBy = MkGetBy { -- | whether or not to include pending invitations in the lookups - includePendingInvitations :: Bool, - -- | Include users with no identity yet, used for activation - includeNoIdentity :: Bool, + includePendingInvitations :: HavePendingInvitations, -- | get accounts by 'UserId's getByUserIds :: [UserId], -- | get accounts by 'Email's @@ -71,7 +74,7 @@ data GetBy = MkGetBy deriving (Arbitrary) via GenericUniform GetBy instance Default GetBy where - def = MkGetBy False False [] [] [] + def = MkGetBy NoPendingInvitations [] [] [] data UserSubsystem m a where -- | First arg is for authorization only. @@ -125,22 +128,18 @@ getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) -- TODO: Remove boolean blindness -getLocalUserAccount :: +getLocalAccountBy :: (Member UserSubsystem r) => - -- | Include pending invitations or not - Bool -> - -- | Include users without identity - Bool -> + HavePendingInvitations -> Local UserId -> Sem r (Maybe UserAccount) -getLocalUserAccount includePendingInvitations includeNoIdentity uid = +getLocalAccountBy includePendingInvitations uid = listToMaybe <$> getAccountsBy ( qualifyAs uid $ def { getByUserIds = [tUnqualified uid], - includePendingInvitations, - includeNoIdentity + includePendingInvitations } ) @@ -157,7 +156,7 @@ getLocalUserAccountByUserKey email = <$> getAccountsBy ( qualifyAs email $ def - { includePendingInvitations = True, + { includePendingInvitations = WithPendingInvitations, getByEmail = [tUnqualified email] } ) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index efaa1ddb19d..e4462cbb9b4 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -518,7 +518,7 @@ getExtendedAccountsByImpl :: ) => Local GetBy -> Sem r [ExtendedUserAccount] -getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, includeNoIdentity, getByEmail, getByHandle, getByUserIds})) = do +getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do storedToExtAcc <- do config <- input pure $ mkExtendedAccountFromStored domain config.defaultLocale @@ -534,7 +534,6 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations mactiveUid <- lookupKey ek getUsers (nubOrd . catMaybes $ [mactiveUid]) <&> map storedToExtAcc - >>= filterM want pure (nubOrd $ accsByIds <> accsByEmail) where @@ -545,11 +544,11 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations want :: ExtendedUserAccount -> Sem r Bool want ExtendedUserAccount {account} = case account.accountUser.userIdentity of - Nothing -> pure includeNoIdentity + Nothing -> pure False Just ident -> case account.accountStatus of PendingInvitation -> - if includePendingInvitations - then case emailIdentity ident of + case includePendingInvitations of + WithPendingInvitations -> case emailIdentity ident of -- TODO(fisx): emailIdentity does not return an unvalidated address in case a -- validated one cannot be found. that's probably wrong? split up into -- validEmailIdentity, anyEmailIdentity? @@ -558,7 +557,7 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations gcHack hasInvitation (userId account.accountUser) pure hasInvitation Nothing -> error "getExtendedAccountsByImpl: should never happen, user invited via scim always has an email" - else pure False + NoPendingInvitations -> pure False Active -> pure True Suspended -> pure True Deleted -> pure True -- TODO(mangoiv): previous comment said "We explicitly filter out deleted users now." Why? diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index a5d4ad996a3..0e7335b99fa 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -288,7 +288,7 @@ spec = describe "UserSubsystem.Interpreter" do def { getByUserIds = [alice.id], -- Do not rely on default behaviour - includePendingInvitations = False + includePendingInvitations = NoPendingInvitations } localBackend = def {users = [alice]} result = @@ -309,7 +309,7 @@ spec = describe "UserSubsystem.Interpreter" do toLocalUnsafe localDomain $ def { getByUserIds = [alice.id], - includePendingInvitations = True + includePendingInvitations = WithPendingInvitations } localBackend = def @@ -351,26 +351,26 @@ spec = describe "UserSubsystem.Interpreter" do getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] - prop "GetBy email pending fails even if explicit when no invitation" $ - \(PendingNotEmptyIdentityStoredUser alice') email localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale - emailKey = mkEmailKey email - getBy = - toLocalUnsafe localDomain $ - def - { getByEmail = [emailKey], - includePendingInvitations = True - } - alice = alice' {email = Just email} - localBackend = - def - { users = [alice], - userKeys = Map.singleton emailKey alice.id - } - result = - runNoFederationStack localBackend Nothing config $ - getAccountsBy getBy - in result === [] + -- prop "GetBy email does not filter by validity" $ + -- \alice' email localDomain visibility locale -> + -- let config = UserSubsystemConfig visibility locale + -- emailKey = mkEmailKey email + -- getBy = + -- toLocalUnsafe localDomain $ + -- def + -- { getByEmail = [emailKey] + -- } + -- alice = alice' {email = Just email} + -- localBackend = + -- def + -- { users = [alice], + -- userKeys = Map.singleton emailKey alice.id + -- } + -- result = + -- runNoFederationStack localBackend Nothing config $ + -- getAccountsBy getBy + -- in result === [mkAccountFromStored alice'] + prop "GetBy email pending works if explicit" $ \(PendingNotEmptyIdentityStoredUser alice') teamId email localDomain invitationInfo visibility locale -> let config = UserSubsystemConfig visibility locale @@ -379,7 +379,7 @@ spec = describe "UserSubsystem.Interpreter" do toLocalUnsafe localDomain $ def { getByEmail = [emailKey], - includePendingInvitations = True + includePendingInvitations = WithPendingInvitations } alice = alice' @@ -413,7 +413,7 @@ spec = describe "UserSubsystem.Interpreter" do def { getByUserIds = [alice.id], -- We don't care about user status, only if the email is there. - includePendingInvitations = True + includePendingInvitations = WithPendingInvitations } localBackend = def {users = [alice]} result = @@ -430,7 +430,7 @@ spec = describe "UserSubsystem.Interpreter" do def { getByEmail = [mkEmailKey email], -- We don't care about user status, only if the email is there. - includePendingInvitations = True + includePendingInvitations = WithPendingInvitations } localBackend = def diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index e5a83c008e8..a1af54fbbc4 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -75,6 +75,7 @@ import Data.ByteString (toStrict) import Data.ByteString.Conversion import Data.Code as Code import Data.Domain +import Data.HavePendingInvitations import Data.Id (ClientId, ConnId, UserId) import Data.List.Split (chunksOf) import Data.Map.Strict qualified as Map @@ -203,7 +204,7 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- (lift . liftSem $ User.getLocalUserAccount False False luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + usr <- (lift . liftSem $ User.getLocalAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index fd4c8108285..6c62d6a4d2d 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -65,6 +65,7 @@ import Data.CommaSeparatedList import Data.Default import Data.Domain (Domain) import Data.Handle +import Data.HavePendingInvitations import Data.Id as Id import Data.Map.Strict qualified as Map import Data.Qualified @@ -578,7 +579,7 @@ listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) (maybe [] (fromCommaSeparatedList . fmap mkEmailKey) -> emails) - (fromMaybe False -> include) = do + (maybe NoPendingInvitations fromBool -> include) = do when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") lift $ liftSem do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 6f1528ed4d9..86f013f209e 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -74,6 +74,7 @@ import Data.Domain import Data.FileEmbed import Data.Handle (Handle) import Data.Handle qualified as Handle +import Data.HavePendingInvitations import Data.Id import Data.Id qualified as Id import Data.List.NonEmpty (nonEmpty) @@ -634,7 +635,7 @@ getRichInfo lself user = do -- other user let fetch luid = ifNothing (errorToWai @'E.UserNotFound) - =<< lift (liftSem $ (.accountUser) <$$> User.getLocalUserAccount False False luid) + =<< lift (liftSem $ (.accountUser) <$$> User.getLocalAccountBy NoPendingInvitations luid) selfUser <- fetch lself otherUser <- fetch luser case (Public.userTeam selfUser, Public.userTeam otherUser) of @@ -1321,7 +1322,7 @@ sendVerificationCode req = do getAccount email = lift . liftSem $ do mbUserId <- lookupKey $ mkEmailKey email mbLUserId <- qualifyLocal' `traverse` mbUserId - join <$> (User.getLocalUserAccount False True) `traverse` mbLUserId + join <$> User.getLocalAccount `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 173ab6af7b9..307b075d0bf 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -301,7 +301,7 @@ createUser new = do <$> for mbInv do \invid -> liftSem $ do luid :: Local UserId <- qualifyLocal' (coerce invid) - User.getLocalUserAccount True False luid + User.getLocalAccountBy WithPendingInvitations luid let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -900,7 +900,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser luid@(tUnqualified -> uid) pwd = do - account <- lift . liftSem $ User.getLocalUserAccount False False luid + account <- lift . liftSem $ User.getLocalAccountBy NoPendingInvitations luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -977,7 +977,7 @@ verifyDeleteUser d = do c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) luid <- qualifyLocal $ Id a - account <- lift . liftSem $ User.getLocalUserAccount False True luid + account <- lift . liftSem $ User.getLocalAccount luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -1001,7 +1001,7 @@ ensureAccountDeleted :: Local UserId -> AppT r DeleteUserResult ensureAccountDeleted luid@(tUnqualified -> uid) = do - mbAcc <- liftSem $ User.getLocalUserAccount False True luid + mbAcc <- liftSem $ User.getLocalAccount luid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1137,7 +1137,7 @@ getLegalHoldStatus :: getLegalHoldStatus uid = liftSem $ traverse (getLegalHoldStatus' . accountUser) - =<< User.getLocalUserAccount False False uid + =<< User.getLocalAccountBy NoPendingInvitations uid getLegalHoldStatus' :: (Member GalleyAPIAccess r) => diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index dbfefa3b70d..28b757df5b6 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -105,7 +105,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do luid <- qualifyLocal uid - a <- lift (liftSem $ User.getLocalUserAccount True True luid) >>= maybe (throwE invalidUser) pure + a <- lift (liftSem $ User.getLocalAccount luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index dff9b18fd9f..55412d7e069 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -71,6 +71,7 @@ import Control.Lens hiding (from) import Data.Conduit (ConduitM) import Data.Domain import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Misc diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 44eb3c26b56..6a36c4f5a1a 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -43,7 +43,6 @@ import Brig.Provider.DB qualified as DB import Brig.Provider.Email import Brig.Provider.RPC qualified as RPC import Brig.Team.Util -import Brig.Types.User import Brig.ZAuth qualified as ZAuth import Cassandra (MonadClient) import Control.Error (throwE) @@ -58,6 +57,7 @@ import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList)) import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as C import Data.Hashable (hash) +import Data.HavePendingInvitations import Data.Id import Data.LegalHold import Data.List qualified as List diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 6ab5eab896d..a838a3c5fe8 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -20,9 +20,9 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App import Brig.Data.User qualified as Data -import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error import Control.Lens +import Data.HavePendingInvitations import Data.Id import Data.Set qualified as Set import Imports diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 0238e2d29a3..be8646b193b 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -140,7 +140,7 @@ verifyCode mbCode action luid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ User.getLocalUserAccount False True luid + account <- lift . liftSem $ User.getLocalAccount luid let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -156,7 +156,7 @@ verifyCode mbCode action luid = do Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ User.getLocalUserAccount False True u + mbAccount <- lift . liftSem $ User.getLocalAccount u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -234,7 +234,7 @@ revokeAccess :: revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do - account <- User.getLocalUserAccount False True luid + account <- User.getLocalAccount luid pure $ maybe False (Data.isSamlUser . ((.accountUser))) account unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll @@ -332,7 +332,7 @@ isPendingActivation ident = case ident of Nothing -> pure False Just usr -> liftSem do lusr <- qualifyLocal' usr - maybe False (checkAccount k) <$> User.getLocalUserAccount True False lusr + maybe False (checkAccount k) <$> User.getLocalAccount lusr checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 880fc7d4618..23d4095270f 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -32,6 +32,7 @@ import Control.Lens (view, (^.)) import Data.Aeson qualified as A import Data.ByteString.Conversion import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as T diff --git a/services/spar/default.nix b/services/spar/default.nix index 4115e8cb670..8bada720bae 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -78,6 +78,7 @@ , wai-utilities , warp , wire-api +, wire-subsystems , xml-conduit , yaml , zauth @@ -138,6 +139,7 @@ mkDerivation { wai-utilities warp wire-api + wire-subsystems yaml ]; executableHaskellDepends = [ diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 5c7ba1d5247..66eb6939cdd 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -198,6 +198,7 @@ library , wai-utilities , warp , wire-api + , wire-subsystems , yaml default-language: Haskell2010 diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index c1c307e341c..6ac9a07efae 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -50,6 +50,7 @@ import Cassandra as Cas import Control.Lens hiding ((.=)) import qualified Data.ByteString as SBS import Data.ByteString.Builder (toLazyByteString) +import Data.HavePendingInvitations import Data.Id import Data.Proxy import Data.Range diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index c11d4dd03f0..31333cf34f1 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -68,6 +68,7 @@ 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 (..)) ---------------------------------------------------------------------- diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 83c377ff6fb..c40d2921ef4 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -43,12 +43,12 @@ module Spar.Intra.BrigApp where import Brig.Types.Intra -import Brig.Types.User import Control.Lens import Control.Monad.Except import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import Data.Handle (Handle, parseHandle) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId) import Data.Text.Encoding import Data.Text.Encoding.Error diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 53041076773..46d208d1b10 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -44,9 +44,9 @@ module Spar.Sem.BrigAccess where import Brig.Types.Intra -import Brig.Types.User import Data.Code as Code import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId) import Data.Misc (PlainTextPassword6) import Imports diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 145df9c60b1..f055bc467f5 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -30,7 +30,6 @@ where import Bilge import Bilge.Assert -import Brig.Types.User as Brig import qualified Control.Exception import Control.Lens import Control.Monad.Except (MonadError (throwError)) @@ -46,6 +45,7 @@ import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Data.Handle (Handle, fromHandle, parseHandle, parseHandleEither) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId, randomId) import Data.Ix (inRange) import Data.LanguageCodes (ISO639_1 (..)) diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index ebc26096d0f..5c51ed624de 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -2,9 +2,9 @@ module Test.Spar.Scim.UserSpec where import Arbitrary () import Brig.Types.Intra -import Brig.Types.User import Control.Monad.Except (runExceptT) import Data.Handle (parseHandle) +import Data.HavePendingInvitations import Data.Id import Imports import Polysemy From bb4ca462f71edaa67cbf4ea151d8d0d04d0cf606 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 11 Sep 2024 16:16:28 +0200 Subject: [PATCH 71/96] Fix self/delete. --- integration/test/Testlib/ModService.hs | 10 +++++----- services/brig/src/Brig/API/User.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 341c770e5fc..4df45b82d05 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -215,11 +215,11 @@ startDynamicBackend resource beOverrides = do cannonCfg = setField "logLevel" ("Warn" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), - gundeckCfg = setField "logLevel" ("Warn" :: String), - nginzCfg = setField "logLevel" ("Warn" :: String), - backgroundWorkerCfg = setField "logLevel" ("Warn" :: String), - sternCfg = setField "logLevel" ("Warn" :: String), - federatorInternalCfg = setField "logLevel" ("Warn" :: String) + gundeckCfg = setField "logLevel" ("Fatal" :: String), + nginzCfg = setField "logLevel" ("Fatal" :: String), + backgroundWorkerCfg = setField "logLevel" ("Fatal" :: String), + sternCfg = setField "logLevel" ("Fatal" :: String), + federatorInternalCfg = setField "logLevel" ("Fatal" :: String) } updateServiceMapInConfig :: BackendResource -> Service -> Value -> App Value diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 307b075d0bf..34d8290eb4f 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -900,7 +900,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser luid@(tUnqualified -> uid) pwd = do - account <- lift . liftSem $ User.getLocalAccountBy NoPendingInvitations luid + account <- lift . liftSem $ User.getLocalAccount luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of From 5f93ba744a0c7b07df080982552a6af8a3cd84e8 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 09:44:56 +0200 Subject: [PATCH 72/96] Added property tests for getBy semantics. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 18 +- .../src/Wire/UserSubsystem/Interpreter.hs | 4 +- .../Wire/UserSubsystem/InterpreterSpec.hs | 229 ++++++++++++++---- services/brig/src/Brig/API/Internal.hs | 2 +- 4 files changed, 194 insertions(+), 59 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 9f04ae15103..db91f3031e9 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -61,11 +61,14 @@ instance Default UserProfileUpdate where -- | how to get an account for a user data GetBy = MkGetBy - { -- | whether or not to include pending invitations in the lookups + { -- | whether or not to include pending invitations when getting + -- users by ids. Does not apply to emails. includePendingInvitations :: HavePendingInvitations, - -- | get accounts by 'UserId's - getByUserIds :: [UserId], - -- | get accounts by 'Email's + -- | get accounts by 'UserId', filters out accounts + -- missing user identity, optionally by pending invitations. + getByUserId :: [UserId], + -- | get accounts by 'Email', does not filter by missing user identity, + -- or expired invitations, unlike by id and handle getByEmail :: [EmailKey], -- | get accounts by their 'Handle' getByHandle :: [Handle] @@ -82,8 +85,9 @@ data UserSubsystem m a where -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] -- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria + -- see GetBy's documentation for more information on what gets filtered. GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] - -- | given a local user id, return a UserAccount + -- | given a local user id, return a UserAccount, does not filter out by missing user identity or status GetLocalAccount :: Local UserId -> UserSubsystem m (Maybe UserAccount) -- | Self profile contains things not present in Profile. GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) @@ -138,7 +142,7 @@ getLocalAccountBy includePendingInvitations uid = <$> getAccountsBy ( qualifyAs uid $ def - { getByUserIds = [tUnqualified uid], + { getByUserId = [tUnqualified uid], includePendingInvitations } ) @@ -147,7 +151,7 @@ getLocalExtendedAccounts :: (Member UserSubsystem r) => Local [UserId] -> Sem r getLocalExtendedAccounts uids = do getExtendedAccountsBy ( qualifyAs uids $ - def {getByUserIds = tUnqualified uids} + def {getByUserId = tUnqualified uids} ) getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e4462cbb9b4..a382e159d58 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -518,7 +518,7 @@ getExtendedAccountsByImpl :: ) => Local GetBy -> Sem r [ExtendedUserAccount] -getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserIds})) = do +getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserId})) = do storedToExtAcc <- do config <- input pure $ mkExtendedAccountFromStored domain config.defaultLocale @@ -526,7 +526,7 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations handleUserIds :: [UserId] <- wither lookupHandle getByHandle accsByIds :: [ExtendedUserAccount] <- - getUsers (nubOrd $ handleUserIds <> getByUserIds) + getUsers (nubOrd $ handleUserIds <> getByUserId) <&> map storedToExtAcc >>= filterM want diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 0e7335b99fa..a60a7cadcd6 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -279,18 +279,38 @@ spec = describe "UserSubsystem.Interpreter" do ) ] - describe "getAccountsBy" do + -- TODO: parameterise these tests, too much copy paste. + describe "GetBy" do prop "GetBy userId when pending fails if not explicitly allowed" $ - \(PendingStoredUser alice) localDomain visibility locale -> + \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId + -- For simplicity, so we don't have to match the email with invitation + } getBy = toLocalUnsafe localDomain $ def - { getByUserIds = [alice.id], - -- Do not rely on default behaviour + { getByUserId = [alice.id], includePendingInvitations = NoPendingInvitations } - localBackend = def {users = [alice]} + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } result = runNoFederationStack localBackend Nothing config $ getAccountsBy getBy @@ -308,7 +328,7 @@ spec = describe "UserSubsystem.Interpreter" do getBy = toLocalUnsafe localDomain $ def - { getByUserIds = [alice.id], + { getByUserId = [alice.id], includePendingInvitations = WithPendingInvitations } localBackend = @@ -330,16 +350,87 @@ spec = describe "UserSubsystem.Interpreter" do runNoFederationStack localBackend Nothing config $ getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] + prop "GetBy handle when pending fails if not explicitly allowed" $ + \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = NoPendingInvitations + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] - prop "GetBy email not pending" $ - \(NotPendingStoredUser alice') email localDomain visibility locale -> + prop "GetBy handle works for pending if explicitly queried" $ + \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + -- For simplicity, so we don't have to match the email with invitation + } getBy = toLocalUnsafe localDomain $ def - { getByEmail = [emailKey] + { getByHandle = [handl], + includePendingInvitations = WithPendingInvitations } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy email does not filter by pending, missing identity or expired invitations" $ + \(alice' :: StoredUser) email localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByEmail = [emailKey] + } alice = alice' {email = Just email} localBackend = def @@ -351,46 +442,50 @@ spec = describe "UserSubsystem.Interpreter" do getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] - -- prop "GetBy email does not filter by validity" $ - -- \alice' email localDomain visibility locale -> - -- let config = UserSubsystemConfig visibility locale - -- emailKey = mkEmailKey email - -- getBy = - -- toLocalUnsafe localDomain $ - -- def - -- { getByEmail = [emailKey] - -- } - -- alice = alice' {email = Just email} - -- localBackend = - -- def - -- { users = [alice], - -- userKeys = Map.singleton emailKey alice.id - -- } - -- result = - -- runNoFederationStack localBackend Nothing config $ - -- getAccountsBy getBy - -- in result === [mkAccountFromStored alice'] - - prop "GetBy email pending works if explicit" $ - \(PendingNotEmptyIdentityStoredUser alice') teamId email localDomain invitationInfo visibility locale -> + prop "GetBy userId does not return missing identity users, pending invitation off" $ + \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = NoPendingInvitations + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy userId does not return missing identity users, pending invtation on" $ + \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = WithPendingInvitations + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy pending user by id works if there is a valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> let config = UserSubsystemConfig visibility locale emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ def - { getByEmail = [emailKey], + { getByUserId = [alice.id], includePendingInvitations = WithPendingInvitations } - alice = - alice' - { email = Just email, - teamId = Just teamId - } localBackend = def { users = [alice], userKeys = Map.singleton emailKey alice.id, - -- Pending users always require a valid invitation invitations = Map.singleton (teamId, invitationInfo.invitationId) @@ -400,36 +495,41 @@ spec = describe "UserSubsystem.Interpreter" do } ) } + alice = alice' {email = Just email, teamId = Just teamId} result = runNoFederationStack localBackend Nothing config $ getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] - prop "GetBy userId if not pending" $ - \(NotPendingStoredUser alice) localDomain visibility locale -> + prop "GetBy pending user by id fails if there is no valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId localDomain visibility locale -> let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ def - { getByUserIds = [alice.id], - -- We don't care about user status, only if the email is there. + { getByUserId = [alice.id], includePendingInvitations = WithPendingInvitations } - localBackend = def {users = [alice]} + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + alice = alice' {email = Just email, teamId = Just teamId} result = runNoFederationStack localBackend Nothing config $ getAccountsBy getBy - in result === [mkAccountFromStored localDomain locale alice] + in result === [] - prop "GetBy pending user requires a valid invitation" $ - \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> + prop "GetBy pending user handle id works if there is a valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> let config = UserSubsystemConfig visibility locale emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ def - { getByEmail = [mkEmailKey email], - -- We don't care about user status, only if the email is there. + { getByHandle = [handl], includePendingInvitations = WithPendingInvitations } localBackend = @@ -445,12 +545,43 @@ spec = describe "UserSubsystem.Interpreter" do } ) } - alice = alice' {email = Just email, teamId = Just teamId} + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + } result = runNoFederationStack localBackend Nothing config $ getAccountsBy getBy in result === [mkAccountFromStored localDomain locale alice] + prop "GetBy pending user by handle fails if there is no valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + describe "user managed by scim doesn't allow certain update operations, but allows others" $ do prop "happy" $ \(NotPendingStoredUser alice) localDomain update config -> diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 6c62d6a4d2d..d929c277f31 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -588,7 +588,7 @@ listActivatedAccountsH dom $> def { includePendingInvitations = include, - getByUserIds = uids, + getByUserId = uids, getByEmail = emails, getByHandle = handles } From cebf28cd64ac2d2422c27dfebc3b3d85c1635f2a Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 10:48:49 +0200 Subject: [PATCH 73/96] Extracted by emails from GetBy, more tests! --- .../AuthenticationSubsystem/Interpreter.hs | 19 +++++++----- .../wire-subsystems/src/Wire/UserSubsystem.hs | 29 +++++++------------ .../src/Wire/UserSubsystem/Interpreter.hs | 26 ++++++++++++----- .../Wire/MockInterpreters/UserSubsystem.hs | 16 ++-------- .../Wire/UserSubsystem/InterpreterSpec.hs | 14 +++------ services/brig/src/Brig/API/Internal.hs | 22 +++++++------- 6 files changed, 59 insertions(+), 67 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 94024d5b4cf..fa339e8d33d 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -49,7 +49,8 @@ import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.SessionStore import Wire.UserKeyStore -import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey) +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User interpretAuthenticationSubsystem :: forall r. @@ -141,20 +142,22 @@ lookupActiveUserIdByUserKey target = userId <$$> lookupActiveUserByUserKey target lookupActiveUserByUserKey :: - (Member UserSubsystem r, Member (Input (Local ())) r) => + ( Member UserSubsystem r, + Member (Input (Local ())) r + ) => EmailKey -> Sem r (Maybe User) lookupActiveUserByUserKey target = do localUnit <- input - let ltarget = qualifyAs localUnit target - mUser <- getLocalUserAccountByUserKey ltarget + let ltarget = qualifyAs localUnit [emailKeyOrig target] + mUser <- User.getLocalExtendedAccountsByEmail ltarget case mUser of - Just user -> do + [user] -> do pure $ - if user.accountStatus == Active - then Just user.accountUser + if user.account.accountStatus == Active + then Just user.account.accountUser else Nothing - Nothing -> pure Nothing + _ -> pure Nothing internalLookupPasswordResetCodeImpl :: ( Member PasswordResetCodeStore r, diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index db91f3031e9..e93d4ba9334 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -17,7 +17,7 @@ import Polysemy import Wire.API.Federation.Error import Wire.API.User import Wire.Arbitrary -import Wire.UserKeyStore +import Wire.UserKeyStore (EmailKey, emailKeyOrig) -- | Who is performing this update operation? (Single source of truth: users managed by SCIM -- can't be updated by clients and vice versa.) @@ -67,9 +67,6 @@ data GetBy = MkGetBy -- | get accounts by 'UserId', filters out accounts -- missing user identity, optionally by pending invitations. getByUserId :: [UserId], - -- | get accounts by 'Email', does not filter by missing user identity, - -- or expired invitations, unlike by id and handle - getByEmail :: [EmailKey], -- | get accounts by their 'Handle' getByHandle :: [Handle] } @@ -77,23 +74,27 @@ data GetBy = MkGetBy deriving (Arbitrary) via GenericUniform GetBy instance Default GetBy where - def = MkGetBy NoPendingInvitations [] [] [] + def = MkGetBy NoPendingInvitations [] [] +-- TODO: consider if we want to remove Local from the names since they're already part of the type data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] + -- | These give us partial success and hide concurrency in the interpreter. + -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? + GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] -- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria -- see GetBy's documentation for more information on what gets filtered. GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] + -- | given a list of email address, returns all associated user accounts, + -- does not filter out by missing user identity or status + GetLocalExtendedAccountsByEmail :: Local [EmailAddress] -> UserSubsystem m [ExtendedUserAccount] -- | given a local user id, return a UserAccount, does not filter out by missing user identity or status GetLocalAccount :: Local UserId -> UserSubsystem m (Maybe UserAccount) -- | Self profile contains things not present in Profile. GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) - -- | These give us partial success and hide concurrency in the interpreter. - -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? - GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). Empty fields are ignored (not deleted). UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m () -- | parse and lookup a handle, return what the operation has found @@ -131,7 +132,6 @@ getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) --- TODO: Remove boolean blindness getLocalAccountBy :: (Member UserSubsystem r) => HavePendingInvitations -> @@ -155,12 +155,5 @@ getLocalExtendedAccounts uids = do ) getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) -getLocalUserAccountByUserKey email = - listToMaybe - <$> getAccountsBy - ( qualifyAs email $ - def - { includePendingInvitations = WithPendingInvitations, - getByEmail = [tUnqualified email] - } - ) +getLocalUserAccountByUserKey q@(tUnqualified -> ek) = + listToMaybe . fmap (.account) <$> getLocalExtendedAccountsByEmail (qualifyAs q [emailKeyOrig ek]) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index a382e159d58..949bcf23610 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -100,6 +100,7 @@ interpretUserSubsystem :: interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others + GetLocalExtendedAccountsByEmail emails -> getLocalExtendedAccountsByEmailImpl emails GetExtendedAccountsBy getBy -> getExtendedAccountsByImpl getBy GetLocalAccount luid -> getLocalAccountImpl luid GetSelfProfile self -> getSelfProfileImpl self @@ -504,6 +505,21 @@ getLocalAccountImpl (tSplit -> (domain, uid)) = do muser <- getUser uid pure $ (mkAccountFromStored domain cfg.defaultLocale) <$> muser +getLocalExtendedAccountsByEmailImpl :: + forall r. + ( Member UserStore r, + Member UserKeyStore r, + Member (Input UserSubsystemConfig) r + ) => + Local [EmailAddress] -> + Sem r [ExtendedUserAccount] +getLocalExtendedAccountsByEmailImpl (tSplit -> (domain, emails)) = do + config <- input + nubOrd <$> flip foldMap emails \ek -> do + mactiveUid <- lookupKey (mkEmailKey ek) + getUsers (nubOrd . catMaybes $ [mactiveUid]) + <&> map (mkExtendedAccountFromStored domain config.defaultLocale) + -------------------------------------------------------------------------------- -- getting user accounts by different criteria @@ -513,12 +529,11 @@ getExtendedAccountsByImpl :: Member DeleteQueue r, Member (Input UserSubsystemConfig) r, Member InvitationCodeStore r, - Member UserKeyStore r, Member TinyLog r ) => Local GetBy -> Sem r [ExtendedUserAccount] -getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByEmail, getByHandle, getByUserId})) = do +getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByHandle, getByUserId})) = do storedToExtAcc <- do config <- input pure $ mkExtendedAccountFromStored domain config.defaultLocale @@ -530,12 +545,7 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations <&> map storedToExtAcc >>= filterM want - accsByEmail :: [ExtendedUserAccount] <- flip foldMap getByEmail \ek -> do - mactiveUid <- lookupKey ek - getUsers (nubOrd . catMaybes $ [mactiveUid]) - <&> map storedToExtAcc - - pure (nubOrd $ accsByIds <> accsByEmail) + pure (nubOrd $ accsByIds) where -- not wanted: -- . users without identity diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 12e81438778..23e45ea5e41 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -4,25 +4,15 @@ import Data.Qualified import Imports import Polysemy import Wire.API.User -import Wire.UserKeyStore import Wire.UserSubsystem +-- HINT: This is used to test AuthenticationSubsystem, not to test itself! userSubsystemTestInterpreter :: [ExtendedUserAccount] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter initialUsers = interpret \case - GetExtendedAccountsBy (tSplit -> (_dom, getBy)) -> + GetLocalExtendedAccountsByEmail (tUnqualified -> emails) -> pure $ filter - ( \u -> - mailKeyFrom u - `elem` getBy.getByEmail - ) + (\u -> userEmail u.account.accountUser `elem` (Just <$> emails)) initialUsers _ -> error $ "userSubsystemTestInterpreter: implement on demand" - -mailKeyFrom :: ExtendedUserAccount -> EmailKey -mailKeyFrom acc = - case acc.account.accountUser.userIdentity of - Just (EmailIdentity mail) -> mkEmailKey mail - Just (SSOIdentity _ (Just mail)) -> mkEmailKey mail - _ -> error "Why are we testing users without emails for this?" diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index a60a7cadcd6..c9495eaac2a 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -280,7 +280,7 @@ spec = describe "UserSubsystem.Interpreter" do ] -- TODO: parameterise these tests, too much copy paste. - describe "GetBy" do + describe "getAccountsBy" do prop "GetBy userId when pending fails if not explicitly allowed" $ \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> let config = UserSubsystemConfig visibility locale @@ -425,22 +425,16 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy email does not filter by pending, missing identity or expired invitations" $ \(alice' :: StoredUser) email localDomain visibility locale -> let config = UserSubsystemConfig visibility locale - emailKey = mkEmailKey email - getBy = - toLocalUnsafe localDomain $ - def - { getByEmail = [emailKey] - } alice = alice' {email = Just email} localBackend = def { users = [alice], - userKeys = Map.singleton emailKey alice.id + userKeys = Map.singleton (mkEmailKey email) alice.id } result = runNoFederationStack localBackend Nothing config $ - getAccountsBy getBy - in result === [mkAccountFromStored localDomain locale alice] + getLocalExtendedAccountsByEmail (toLocalUnsafe localDomain [email]) + in result === [mkExtendedAccountFromStored localDomain locale alice] prop "GetBy userId does not return missing identity users, pending invitation off" $ \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d929c277f31..8eeca86af89 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -578,20 +578,22 @@ listActivatedAccountsH :: listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) - (maybe [] (fromCommaSeparatedList . fmap mkEmailKey) -> emails) + (maybe [] fromCommaSeparatedList -> emails) (maybe NoPendingInvitations fromBool -> include) = do when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") lift $ liftSem do - dom <- input - getExtendedAccountsBy $ - dom - $> def - { includePendingInvitations = include, - getByUserId = uids, - getByEmail = emails, - getByHandle = handles - } + loc <- input + byEmails <- getLocalExtendedAccountsByEmail $ loc $> emails + others <- + getExtendedAccountsBy $ + loc + $> def + { includePendingInvitations = include, + getByUserId = uids, + getByHandle = handles + } + pure $ others <> byEmails getActivationCode :: EmailAddress -> Handler r GetActivationCodeResp getActivationCode email = do From 8b3393b496df8f822c75184fb3ad6722127da8f5 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:03:32 +0200 Subject: [PATCH 74/96] rm overly ambitious TODO. --- libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 29873ff5bf4..1cf8b57167d 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -49,7 +49,6 @@ insertInvitationImpl (MkInsertInvitation invId teamId role (toUTCTimeMillis -> n name = name, code = code } - -- TODO: see how we can improve this retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum From b72071689330511fb8fe65e72d2a968f3d6916ff Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:03:46 +0200 Subject: [PATCH 75/96] rm trailing whitespace. --- .../src/Wire/InvitationCodeStore/Cassandra.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 1cf8b57167d..98fe33e32a0 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -93,12 +93,12 @@ lookupInvitationsPaginatedImpl mSize tid miid = do cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) cqlSelect = [sql| - SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC |] cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) cqlSelectFrom = - [sql| - SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC |] countInvitationsImpl :: TeamId -> Client (Int64) @@ -115,7 +115,7 @@ lookupInvitationInfoImpl code = where cql :: PrepQuery R (Identity InvitationCode) (TupleType StoredInvitationInfo) cql = - [sql| + [sql| SELECT team, id, code FROM team_invitation_info WHERE code = ? |] @@ -124,7 +124,7 @@ lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (p where cql :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) cql = - [sql| + [sql| SELECT team, invitation, code FROM team_invitation_email WHERE email = ? |] @@ -135,7 +135,7 @@ lookupInvitationImpl tid iid = where cql :: PrepQuery R (TeamId, InvitationId) (TupleType StoredInvitation) cql = - [sql| + [sql| SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? |] @@ -158,25 +158,25 @@ deleteInvitationImpl teamId invId = do cqlInvitation :: PrepQuery W (TeamId, InvitationId) () cqlInvitation = [sql| - DELETE FROM team_invitation where team = ? AND id = ? + DELETE FROM team_invitation where team = ? AND id = ? |] cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () cqlInvitationInfo = [sql| - DELETE FROM team_invitation_info WHERE code = ? + DELETE FROM team_invitation_info WHERE code = ? |] cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () cqlInvitationEmail = [sql| - DELETE FROM team_invitation_email WHERE email = ? AND team = ? + DELETE FROM team_invitation_email WHERE email = ? AND team = ? |] cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) cqlInvitationCodeEmail = [sql| - SELECT code, email FROM team_invitation WHERE team = ? AND id = ? + SELECT code, email FROM team_invitation WHERE team = ? AND id = ? |] deleteInvitationsImpl :: TeamId -> Client () From 872329f50cba763c0d00fd36db813aa95c6440e5 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:03:57 +0200 Subject: [PATCH 76/96] rm self-evident FIXME. --- services/brig/src/Brig/Team/API.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 8fde3e6e95a..a7e285ad822 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -386,7 +386,6 @@ getInvitationByCode c = do inv <- lift . liftSem $ Store.lookupInvitationByCode c maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv --- FIXME(mangoiv): This should not be in terms of store headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult headInvitationByEmail email = lift $ From ebebba8723fcdcb0635b84e048560c68356d9c73 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:14:36 +0200 Subject: [PATCH 77/96] Give better names to two UserSubsystem operations. --- .../src/Wire/AuthenticationSubsystem/Interpreter.hs | 2 +- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 7 +++---- .../src/Wire/UserSubsystem/Interpreter.hs | 12 ++++++------ .../test/unit/Wire/MockInterpreters/UserSubsystem.hs | 2 +- .../test/unit/Wire/UserSubsystem/InterpreterSpec.hs | 2 +- services/brig/src/Brig/API/Client.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/Public.hs | 2 +- services/brig/src/Brig/API/User.hs | 6 +++--- services/brig/src/Brig/Data/Activation.hs | 2 +- services/brig/src/Brig/InternalEvent/Process.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 8 ++++---- 12 files changed, 24 insertions(+), 25 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index fa339e8d33d..2d28021a6a1 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -150,7 +150,7 @@ lookupActiveUserByUserKey :: lookupActiveUserByUserKey target = do localUnit <- input let ltarget = qualifyAs localUnit [emailKeyOrig target] - mUser <- User.getLocalExtendedAccountsByEmail ltarget + mUser <- User.getExtendedAccountsByEmailNoFilter ltarget case mUser of [user] -> do pure $ diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index e93d4ba9334..ebc8f93cd0b 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -76,7 +76,6 @@ data GetBy = MkGetBy instance Default GetBy where def = MkGetBy NoPendingInvitations [] [] --- TODO: consider if we want to remove Local from the names since they're already part of the type data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] @@ -90,9 +89,9 @@ data UserSubsystem m a where GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] -- | given a list of email address, returns all associated user accounts, -- does not filter out by missing user identity or status - GetLocalExtendedAccountsByEmail :: Local [EmailAddress] -> UserSubsystem m [ExtendedUserAccount] + GetExtendedAccountsByEmailNoFilter :: Local [EmailAddress] -> UserSubsystem m [ExtendedUserAccount] -- | given a local user id, return a UserAccount, does not filter out by missing user identity or status - GetLocalAccount :: Local UserId -> UserSubsystem m (Maybe UserAccount) + GetAccountNoFilter :: Local UserId -> UserSubsystem m (Maybe UserAccount) -- | Self profile contains things not present in Profile. GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). Empty fields are ignored (not deleted). @@ -156,4 +155,4 @@ getLocalExtendedAccounts uids = do getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) getLocalUserAccountByUserKey q@(tUnqualified -> ek) = - listToMaybe . fmap (.account) <$> getLocalExtendedAccountsByEmail (qualifyAs q [emailKeyOrig ek]) + listToMaybe . fmap (.account) <$> getExtendedAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek]) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 949bcf23610..a0b593998dc 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -100,9 +100,9 @@ interpretUserSubsystem :: interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others - GetLocalExtendedAccountsByEmail emails -> getLocalExtendedAccountsByEmailImpl emails GetExtendedAccountsBy getBy -> getExtendedAccountsByImpl getBy - GetLocalAccount luid -> getLocalAccountImpl luid + GetExtendedAccountsByEmailNoFilter emails -> getExtendedAccountsByEmailNoFilterImpl emails + GetAccountNoFilter luid -> getAccountNoFilterImpl luid GetSelfProfile self -> getSelfProfileImpl self GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update @@ -493,19 +493,19 @@ checkHandlesImpl check num = reverse <$> collectFree [] check num Nothing -> collectFree (h : free) hs (n - 1) Just _ -> collectFree free hs n -getLocalAccountImpl :: +getAccountNoFilterImpl :: forall r. ( Member UserStore r, Member (Input UserSubsystemConfig) r ) => Local UserId -> Sem r (Maybe UserAccount) -getLocalAccountImpl (tSplit -> (domain, uid)) = do +getAccountNoFilterImpl (tSplit -> (domain, uid)) = do cfg <- input muser <- getUser uid pure $ (mkAccountFromStored domain cfg.defaultLocale) <$> muser -getLocalExtendedAccountsByEmailImpl :: +getExtendedAccountsByEmailNoFilterImpl :: forall r. ( Member UserStore r, Member UserKeyStore r, @@ -513,7 +513,7 @@ getLocalExtendedAccountsByEmailImpl :: ) => Local [EmailAddress] -> Sem r [ExtendedUserAccount] -getLocalExtendedAccountsByEmailImpl (tSplit -> (domain, emails)) = do +getExtendedAccountsByEmailNoFilterImpl (tSplit -> (domain, emails)) = do config <- input nubOrd <$> flip foldMap emails \ek -> do mactiveUid <- lookupKey (mkEmailKey ek) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 23e45ea5e41..45dc93a379a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -10,7 +10,7 @@ import Wire.UserSubsystem userSubsystemTestInterpreter :: [ExtendedUserAccount] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter initialUsers = interpret \case - GetLocalExtendedAccountsByEmail (tUnqualified -> emails) -> + GetExtendedAccountsByEmailNoFilter (tUnqualified -> emails) -> pure $ filter (\u -> userEmail u.account.accountUser `elem` (Just <$> emails)) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index c9495eaac2a..ccbe5c4eda3 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -433,7 +433,7 @@ spec = describe "UserSubsystem.Interpreter" do } result = runNoFederationStack localBackend Nothing config $ - getLocalExtendedAccountsByEmail (toLocalUnsafe localDomain [email]) + getExtendedAccountsByEmailNoFilter (toLocalUnsafe localDomain [email]) in result === [mkExtendedAccountFromStored localDomain locale alice] prop "GetBy userId does not return missing identity users, pending invitation off" $ diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index a1af54fbbc4..cc513f7bfa8 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -204,7 +204,7 @@ addClientWithReAuthPolicy :: NewClient -> ExceptT ClientError (AppT r) Client addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do - usr <- (lift . liftSem $ User.getLocalAccount luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + usr <- (lift . liftSem $ User.getAccountNoFilter luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 8eeca86af89..f304f6432d4 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -584,7 +584,7 @@ listActivatedAccountsH throwStd (notFound "no user keys") lift $ liftSem do loc <- input - byEmails <- getLocalExtendedAccountsByEmail $ loc $> emails + byEmails <- getExtendedAccountsByEmailNoFilter $ loc $> emails others <- getExtendedAccountsBy $ loc diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 86f013f209e..554eceb5b85 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -1322,7 +1322,7 @@ sendVerificationCode req = do getAccount email = lift . liftSem $ do mbUserId <- lookupKey $ mkEmailKey email mbLUserId <- qualifyLocal' `traverse` mbUserId - join <$> User.getLocalAccount `traverse` mbLUserId + join <$> User.getAccountNoFilter `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 34d8290eb4f..4f76936fae7 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -900,7 +900,7 @@ deleteSelfUser :: Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser luid@(tUnqualified -> uid) pwd = do - account <- lift . liftSem $ User.getLocalAccount luid + account <- lift . liftSem $ User.getAccountNoFilter luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -977,7 +977,7 @@ verifyDeleteUser d = do c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) luid <- qualifyLocal $ Id a - account <- lift . liftSem $ User.getLocalAccount luid + account <- lift . liftSem $ User.getAccountNoFilter luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -1001,7 +1001,7 @@ ensureAccountDeleted :: Local UserId -> AppT r DeleteUserResult ensureAccountDeleted luid@(tUnqualified -> uid) = do - mbAcc <- liftSem $ User.getLocalAccount luid + mbAcc <- liftSem $ User.getAccountNoFilter luid case mbAcc of Nothing -> pure NoUser Just acc -> do diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 28b757df5b6..25745846b69 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -105,7 +105,7 @@ activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) activate (key, uid) = do luid <- qualifyLocal uid - a <- lift (liftSem $ User.getLocalAccount luid) >>= maybe (throwE invalidUser) pure + a <- lift (liftSem $ User.getAccountNoFilter luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index a3ee9b7cdff..8fa8e91ac7e 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -74,7 +74,7 @@ onEvent n = handleTimeout $ case n of msg (val "Processing user delete event") ~~ field "user" (toByteString uid) luid <- qualifyLocal' uid - getLocalAccount luid >>= mapM_ API.deleteAccount + getAccountNoFilter luid >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index be8646b193b..e550df6f2d0 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -140,7 +140,7 @@ verifyCode mbCode action luid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - account <- lift . liftSem $ User.getLocalAccount luid + account <- lift . liftSem $ User.getAccountNoFilter luid let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -156,7 +156,7 @@ verifyCode mbCode action luid = do Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- lift . liftSem $ User.getLocalAccount u + mbAccount <- lift . liftSem $ User.getAccountNoFilter u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -234,7 +234,7 @@ revokeAccess :: revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") isSaml <- lift . liftSem $ do - account <- User.getLocalAccount luid + account <- User.getAccountNoFilter luid pure $ maybe False (Data.isSamlUser . ((.accountUser))) account unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll @@ -332,7 +332,7 @@ isPendingActivation ident = case ident of Nothing -> pure False Just usr -> liftSem do lusr <- qualifyLocal' usr - maybe False (checkAccount k) <$> User.getLocalAccount lusr + maybe False (checkAccount k) <$> User.getAccountNoFilter lusr checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = From a18ffd6e5aa7838d8f6c6976bf4a09ecedbd5a6f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:26:50 +0200 Subject: [PATCH 78/96] nit-pick. --- .../src/Wire/UserSubsystem/Interpreter.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index a0b593998dc..d91c6c33dd0 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -538,14 +538,13 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations config <- input pure $ mkExtendedAccountFromStored domain config.defaultLocale - handleUserIds :: [UserId] <- wither lookupHandle getByHandle + handleUserIds :: [UserId] <- + wither lookupHandle getByHandle accsByIds :: [ExtendedUserAccount] <- - getUsers (nubOrd $ handleUserIds <> getByUserId) - <&> map storedToExtAcc - >>= filterM want + getUsers (nubOrd $ handleUserIds <> getByUserId) <&> map storedToExtAcc - pure (nubOrd $ accsByIds) + filterM want (nubOrd $ accsByIds) where -- not wanted: -- . users without identity From cf7ec8b3f20dfdc8056d23127982e94af806247d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 11:47:44 +0200 Subject: [PATCH 79/96] resolve FUTUREWORK. --- services/brig/src/Brig/API/Internal.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f304f6432d4..03c9af86610 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -286,9 +286,13 @@ authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) :<|> Named @"login-code" getLoginCode - -- We qualify in place to avoid changing the internal API too much - -- FUTUREWORK? - :<|> Named @"reauthenticate" (\uid reauth -> qualifyLocal uid >>= \luid -> reauthenticate luid reauth) + :<|> Named @"reauthenticate" + ( \uid reauth -> + -- changing this end-point would involve providing a `Local` type from a user id that is + -- captured from the path, not pulled from the http header. this is certainly feasible, + -- but running qualifyLocal here is easier. + qualifyLocal uid >>= \luid -> reauthenticate luid reauth + ) federationRemotesAPI :: (Member FederationConfigStore r) => ServerT BrigIRoutes.FederationRemotesAPI (Handler r) federationRemotesAPI = From f9e829bfdf39de1712b7bfe22247e7bdea02be86 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 12:54:58 +0200 Subject: [PATCH 80/96] Fix / polish haddock in UserSubsystem. --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 45 ++++++++++--------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index ebc8f93cd0b..20d194f5eb5 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -19,8 +19,8 @@ import Wire.API.User import Wire.Arbitrary import Wire.UserKeyStore (EmailKey, emailKeyOrig) --- | Who is performing this update operation? (Single source of truth: users managed by SCIM --- can't be updated by clients and vice versa.) +-- | Who is performing this update operation / who is allowed to? (Single source of truth: +-- users managed by SCIM can't be updated by clients and vice versa.) data UpdateOriginType = -- | Call originates from the SCIM api in spar. UpdateOriginScim @@ -32,7 +32,7 @@ data UpdateOriginType -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). -- -- This is isomorphic to 'StoredUserUpdate', but we keep the two types separate because they --- belong to different abstractions / levels (UserSubsystem vs. UserStore), and they may +-- belong to different abstraction levels (UserSubsystem vs. UserStore), and they may -- change independently in the future ('UserStoreUpdate' may grow more fields for other -- operations). data UserProfileUpdate = MkUserProfileUpdate @@ -59,13 +59,11 @@ instance Default UserProfileUpdate where supportedProtocols = Nothing } --- | how to get an account for a user +-- | Parameters for `getExternalAccountsBy` operation below. data GetBy = MkGetBy - { -- | whether or not to include pending invitations when getting - -- users by ids. Does not apply to emails. + { -- | whether or not to include pending invitations when getting users by ids. includePendingInvitations :: HavePendingInvitations, - -- | get accounts by 'UserId', filters out accounts - -- missing user identity, optionally by pending invitations. + -- | get accounts by 'UserId'. getByUserId :: [UserId], -- | get accounts by their 'Handle' getByHandle :: [Handle] @@ -80,35 +78,38 @@ data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] -- | These give us partial success and hide concurrency in the interpreter. - -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? + -- (Nit-pick: a better return type for this might be `([Qualified ([UserId], + -- FederationError)], [UserProfile])`, and then we'd probably need a function of type + -- `([Qualified ([UserId], FederationError)], [UserProfile]) -> ([(Qualified UserId, + -- FederationError)], [UserProfile])` to maintain API compatibility.) GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] - -- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria - -- see GetBy's documentation for more information on what gets filtered. + -- | Get the union of all user accounts matching the `GetBy` argument *and* having a non-empty UserIdentity. GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] - -- | given a list of email address, returns all associated user accounts, - -- does not filter out by missing user identity or status + -- | Get user accounts matching the `[EmailAddress]` argument (accounts with missing + -- identity and accounts with status /= active included). GetExtendedAccountsByEmailNoFilter :: Local [EmailAddress] -> UserSubsystem m [ExtendedUserAccount] - -- | given a local user id, return a UserAccount, does not filter out by missing user identity or status + -- | Get user account by local user id (accounts with missing identity and accounts with + -- status /= active included). GetAccountNoFilter :: Local UserId -> UserSubsystem m (Maybe UserAccount) - -- | Self profile contains things not present in Profile. + -- | Get `SelfProfile` (it contains things not present in `UserProfile`). GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). Empty fields are ignored (not deleted). UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m () - -- | parse and lookup a handle, return what the operation has found + -- | Parse and lookup a handle. CheckHandle :: Text {- use Handle here? -} -> UserSubsystem m CheckHandleResp - -- | checks a number of 'Handle's for availability and returns at most 'Word' amount of them + -- | Check a number of 'Handle's for availability and returns at most 'Word' amount of them CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] - -- | parses a handle, this may fail so it's effectful + -- | Parse and update a handle. Parsing may fail so this is effectful. UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m () - -- | returns the user's locale or the default locale if the users exists + -- | Return the user's locale (or the default locale if the users exists and has none). LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) - -- | checks if an email is blocked + -- | Check if an email is blocked. IsBlocked :: EmailAddress -> UserSubsystem m Bool - -- | removes an email from the block list + -- | Remove an email from the block list. BlockListDelete :: EmailAddress -> UserSubsystem m () - -- | adds an email to the block list + -- | Add an email to the block list. BlockListInsert :: EmailAddress -> UserSubsystem m () -- | the return type of 'CheckHandle' From 16858c654239dae56d8d7eea77c23916f6a67256 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 13:11:36 +0200 Subject: [PATCH 81/96] Tweak legacy integration test. --- services/galley/test/integration/API.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 1ecd7e4eab9..059322e5cd8 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -130,7 +130,7 @@ tests s = test s "metrics" metrics, test s "fetch conversation by qualified ID (v2)" testGetConvQualifiedV2, test s "create Proteus conversation" postProteusConvOk, - test s "create conversation with remote users some unreachable" (postConvWithUnreachableRemoteUsers $ Set.fromList [rb1, rb2, rb3, rb4]), + test s "create conversation with remote users, some unreachable" (postConvWithUnreachableRemoteUsers $ Set.fromList [rb1, rb2, rb3, rb4]), test s "get empty conversations" getConvsOk, test s "get conversations by ids" getConvsOk2, test s "fail to get >500 conversations with v2 API" getConvsFailMaxSizeV2, @@ -367,8 +367,10 @@ postConvWithUnreachableRemoteUsers rbs = do users <- connectBackend alice rb pure (users, participating rb users) pure $ foldr (\(a, p) acc -> bimap ((<>) a) ((<>) p) acc) ([], []) v - liftIO $ - assertBool "No unreachable backend in the test" (allRemotes /= participatingRemotes) + liftIO $ do + let notParticipatingRemotes = allRemotes \\ participatingRemotes + assertBool "No reachable backend in the test" (not (null participatingRemotes)) + assertBool "No unreachable backend in the test" (not (null notParticipatingRemotes)) let convName = "some chat" otherLocals = [qAlex] From 962203cb08d4fa968331e458c153dcd5bf891cdc Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 13:22:22 +0200 Subject: [PATCH 82/96] Mark (occasionally) failing test case. --- services/galley/test/integration/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 059322e5cd8..8a7894ff2ac 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -407,7 +407,7 @@ postConvWithUnreachableRemoteUsers rbs = do "Alice does have a group conversation, while she should not!" [] groupConvs - WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] + WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] -- TODO: sometimes, (at least?) one of these users gets a "connection accepted" event. -- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies whether a message actually gets sent all the way to From b8cf6bccaa9951f5060137d7ff88ed78df87a3e2 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 14:31:25 +0200 Subject: [PATCH 83/96] Make function pure. --- services/brig/src/Brig/User/Auth.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index e550df6f2d0..03b4fd7895a 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -302,7 +302,7 @@ resolveLoginId :: LoginId -> ExceptT LoginError (AppT r) UserId resolveLoginId li = do - usr <- validateLoginId li >>= lift . liftSem . either lookupKey lookupHandle + usr <- lift . liftSem . either lookupKey lookupHandle $ validateLoginId li case usr of Nothing -> do pending <- lift $ isPendingActivation li @@ -312,9 +312,9 @@ resolveLoginId li = do else LoginFailed Just uid -> pure uid -validateLoginId :: (Applicative m) => LoginId -> m (Either EmailKey Handle) -validateLoginId (LoginByEmail email) = (pure . Left . mkEmailKey) email -validateLoginId (LoginByHandle h) = (pure . Right) h +validateLoginId :: LoginId -> Either EmailKey Handle +validateLoginId (LoginByEmail email) = (Left . mkEmailKey) email +validateLoginId (LoginByHandle h) = Right h isPendingActivation :: forall r. From c3639ad328f60aa97f0d58d1c8930a03fd8e2c81 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 14:45:18 +0200 Subject: [PATCH 84/96] Replaced coerce with unsafe perform IO. --- .../test/unit/Wire/MockInterpreters/InvitationCodeStore.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 5133bceed6c..23f34594b3a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -6,10 +6,10 @@ import Data.Id (InvitationId, TeamId) import Data.Json.Util (toUTCTimeMillis) import Data.Map (elems, (!?)) import Data.Map qualified as M +import GHC.IO.Unsafe (unsafePerformIO) import Imports import Polysemy import Polysemy.State (State, get, gets, modify') -import Unsafe.Coerce (unsafeCoerce) import Wire.API.User (InvitationCode (..)) import Wire.InvitationCodeStore import Wire.InvitationCodeStore.Cassandra (mkInvitationCode) @@ -22,7 +22,8 @@ inMemoryInvitationCodeStoreInterpreter :: InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case InsertInvitation (MkInsertInvitation invitationId teamId role' createdAt' createdBy email name) _timeout -> do - code <- unsafeCoerce mkInvitationCode + -- Currently unused. + let code = unsafePerformIO mkInvitationCode -- Should confirm that this works as intended (new code on every run) let role = Just role' createdAt = toUTCTimeMillis createdAt' inv = MkStoredInvitation {..} From 012ee660b7f8f8ff5bfa51259b9883cf081a4888 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 14:47:43 +0200 Subject: [PATCH 85/96] Revert accidental change to log levels. --- integration/test/Testlib/ModService.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 4df45b82d05..341c770e5fc 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -215,11 +215,11 @@ startDynamicBackend resource beOverrides = do cannonCfg = setField "logLevel" ("Warn" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), - gundeckCfg = setField "logLevel" ("Fatal" :: String), - nginzCfg = setField "logLevel" ("Fatal" :: String), - backgroundWorkerCfg = setField "logLevel" ("Fatal" :: String), - sternCfg = setField "logLevel" ("Fatal" :: String), - federatorInternalCfg = setField "logLevel" ("Fatal" :: String) + gundeckCfg = setField "logLevel" ("Warn" :: String), + nginzCfg = setField "logLevel" ("Warn" :: String), + backgroundWorkerCfg = setField "logLevel" ("Warn" :: String), + sternCfg = setField "logLevel" ("Warn" :: String), + federatorInternalCfg = setField "logLevel" ("Warn" :: String) } updateServiceMapInConfig :: BackendResource -> Service -> Value -> App Value From e79db04d31328278e00e9ce794d16a1dae40ed44 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 14:57:46 +0200 Subject: [PATCH 86/96] Simplify UserStore. --- libs/wire-subsystems/src/Wire/UserStore.hs | 4 ++- .../src/Wire/UserStore/Cassandra.hs | 31 ++++++------------- .../unit/Wire/MockInterpreters/UserStore.hs | 1 - 3 files changed, 12 insertions(+), 24 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 99fb8d1ce1e..6429d60c597 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -46,7 +46,6 @@ data StoredUserUpdateError = StoredUserUpdateHandleExists -- | Effect containing database logic around 'StoredUser'. (Example: claim handle lock is -- database logic; validate handle is application logic.) data UserStore m a where - GetUser :: UserId -> UserStore m (Maybe StoredUser) GetUsers :: [UserId] -> UserStore m [StoredUser] UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) @@ -67,6 +66,9 @@ data UserStore m a where makeSem ''UserStore +getUser :: (Member UserStore r) => UserId -> Sem r (Maybe StoredUser) +getUser uid = listToMaybe <$> getUsers [uid] + updateUserHandle :: (Member UserStore r, Member (Error StoredUserUpdateError) r) => UserId -> diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index b72e2029482..9ff0e903abf 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -17,7 +17,6 @@ interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> Interpret interpretUserStoreCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case - GetUser uid -> getUserImpl uid GetUsers uids -> embed $ getUsersImpl uids UpdateUser uid update -> embed $ updateUserImpl uid update UpdateUserHandleEither uid update -> embed $ updateUserHandleEitherImpl uid update @@ -31,12 +30,7 @@ interpretUserStoreCassandra casClient = getUsersImpl :: [UserId] -> Client [StoredUser] getUsersImpl usrs = map asRecord - <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) - -getUserImpl :: (Member (Embed Client) r) => UserId -> Sem r (Maybe StoredUser) -getUserImpl uid = embed $ do - mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) - pure $ asRecord <$> mUserTuple + <$> retry x1 (query selectUsers (params LocalQuorum (Identity usrs))) updateUserImpl :: UserId -> StoredUserUpdate -> Client () updateUserImpl uid update = @@ -132,12 +126,14 @@ lookupLocaleImpl u = do -------------------------------------------------------------------------------- -- Queries -selectUser :: PrepQuery R (Identity UserId) (TupleType StoredUser) -selectUser = - "SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, service, \ - \handle, team, managed_by, supported_protocols \ - \FROM user where id = ?" +selectUsers :: PrepQuery R (Identity [UserId]) (TupleType StoredUser) +selectUsers = + [sql| + SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, + activated, status, expires, language, country, provider, + service, handle, team, managed_by, supported_protocols + FROM user WHERE id IN ? + |] userDisplayNameUpdate :: PrepQuery W (Name, UserId) () userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" @@ -186,12 +182,3 @@ activatedSelect = "SELECT activated FROM user WHERE id = ?" localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) localeSelect = "SELECT language, country FROM user WHERE id = ?" - -accountsSelect :: PrepQuery R (Identity [UserId]) (TupleType StoredUser) -accountsSelect = - [sql| - SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, - activated, status, expires, language, country, provider, - service, handle, team, managed_by, supported_protocols - FROM user WHERE id IN ? - |] diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index b28ea9a5a99..bb3ad07afc6 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -16,7 +16,6 @@ inMemoryUserStoreInterpreter :: (Member (State [StoredUser]) r) => InterpreterFor UserStore r inMemoryUserStoreInterpreter = interpret $ \case - GetUser uid -> gets $ find (\user -> user.id == uid) GetUsers uids -> gets $ filter (\user -> user.id `elem` uids) UpdateUser uid update -> modify (map doUpdate) where From 948fd9b14a2085c9c5459b27ebebfd8226cd0d91 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 14:58:35 +0200 Subject: [PATCH 87/96] Remove spurious FUTUREWORK. --- libs/wire-subsystems/src/Wire/ActivationCodeStore.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs index 8f4052b975c..9473bd16f58 100644 --- a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -25,7 +25,6 @@ import Wire.API.User.Activation import Wire.UserKeyStore data ActivationCodeStore :: Effect where - -- FUTUREWORK: Check out if we can drop the outside Maybe. LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode)) makeSem ''ActivationCodeStore From d73f38d3535adea492f3f0040d74d30c4e2e6bb4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 15:02:27 +0200 Subject: [PATCH 88/96] No! --- .../test/unit/Wire/UserSubsystem/InterpreterSpec.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index ccbe5c4eda3..52dfb9b8faa 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -279,7 +279,6 @@ spec = describe "UserSubsystem.Interpreter" do ) ] - -- TODO: parameterise these tests, too much copy paste. describe "getAccountsBy" do prop "GetBy userId when pending fails if not explicitly allowed" $ \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> From 342ece2358e08894aefc62a2ed9fa194944ab32d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 15:04:44 +0200 Subject: [PATCH 89/96] Extend prop test coverage. --- .../test/unit/Wire/UserSubsystem/InterpreterSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 52dfb9b8faa..a7975a867a1 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -769,7 +769,7 @@ spec = describe "UserSubsystem.Interpreter" do describe "getLocalUserAccountByUserKey" $ do prop "gets users iff they are indexed by the UserKeyStore" $ - \(config :: UserSubsystemConfig) (localDomain :: Domain) (NotPendingStoredUser storedUser) (userKey :: EmailKey) -> + \(config :: UserSubsystemConfig) (localDomain :: Domain) (storedUser :: StoredUser) (userKey :: EmailKey) -> let localBackend = def { users = [storedUser], From 7f7eaa9bed4e491e5b1795b03c7ce3932fd560f0 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 15:20:30 +0200 Subject: [PATCH 90/96] rm bogus FUTUREWORK. --- services/brig/test/integration/API/Team.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index f262d6c8f7c..daac2f2e6eb 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -732,8 +732,7 @@ testInvitationPaging opts brig = do === statusCode (invs, more) <- (ilInvitations &&& ilHasMore) <$> responseJsonError r if more - then -- FUTUREWORK: improve readability - (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step + then (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step else pure [invs] let checkSize :: (HasCallStack) => Int -> [Int] -> Http () checkSize pageSize expectedSizes = From 3eb60cacad383f3d28d4cb663edda25717920f7e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 15:22:06 +0200 Subject: [PATCH 91/96] Haddocks. --- libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs index 98fe33e32a0..f8a3bc4a688 100644 --- a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -188,5 +188,7 @@ deleteInvitationsImpl teamId = cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" +-- | This function doesn't really belong here, and may want to have return type `Sem (Random : +-- ...)` instead of `IO`. Meh. mkInvitationCode :: IO InvitationCode mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 From fa76f75fe8c3c5c0df9d575103afc400616a2cd6 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 15:26:23 +0200 Subject: [PATCH 92/96] Weed out the weeed --- libs/imports/src/Imports.hs | 4 ---- libs/wire-api/src/Wire/API/User.hs | 9 +-------- libs/wire-api/src/Wire/API/User/EmailAddress.hs | 8 -------- libs/wire-api/src/Wire/API/User/Scim.hs | 8 -------- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 7 ------- services/spar/spar.cabal | 1 - services/spar/src/Spar/Intra/BrigApp.hs | 3 --- services/spar/test-integration/Util/Core.hs | 12 +----------- services/spar/test-integration/Util/Scim.hs | 13 ------------- weeder.toml | 1 + 10 files changed, 3 insertions(+), 63 deletions(-) diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index e2ddf387e25..aee8b7c0e9c 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -111,7 +111,6 @@ module Imports -- * Extra Helpers whenM, unlessM, - catMaybesToList, -- * Functor (<$$>), @@ -385,6 +384,3 @@ infix 4 <$$> (<$$$>) = fmap . fmap . fmap infix 4 <$$$> - -catMaybesToList :: Maybe (Maybe a) -> [a] -catMaybesToList = catMaybes . maybeToList diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 0e65fa6c6d4..2ff0c3eb3e0 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -59,7 +59,6 @@ module Wire.API.User CreateUserSparInternalResponses, newUserFromSpar, urefToExternalId, - urefToEmail, ExpiresIn, newUserTeam, newUserEmail, @@ -153,7 +152,7 @@ import Cassandra qualified as C import Control.Applicative import Control.Arrow ((&&&)) import Control.Error.Safe (rightMay) -import Control.Lens (makePrisms, over, view, (.~), (?~), (^.)) +import Control.Lens (makePrisms, over, view, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..), withText) import Data.Aeson.Types qualified as A import Data.Attoparsec.ByteString qualified as Parser @@ -191,7 +190,6 @@ import GHC.TypeLits import Generics.SOP qualified as GSOP import Imports import SAML2.WebSSO qualified as SAML -import SAML2.WebSSO.Types.Email qualified as SAMLEmail import Servant (FromHttpApiData (..), ToHttpApiData (..), type (.++)) import Test.QuickCheck qualified as QC import URI.ByteString (serializeURIRef) @@ -844,11 +842,6 @@ instance (res ~ RegisterInternalResponses) => AsUnion res (Either RegisterError urefToExternalId :: SAML.UserRef -> Maybe Text urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject -urefToEmail :: SAML.UserRef -> Maybe EmailAddress -urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of - SAML.UNameIDEmail email -> emailAddressText . SAMLEmail.render . CI.original $ email - _ -> Nothing - data CreateUserSparError = CreateUserSparHandleError ChangeHandleError | CreateUserSparRegistrationError RegisterError diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index 7c5bc2dacc7..ffde490b59e 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -6,7 +6,6 @@ module Wire.API.User.EmailAddress emailAddressText, module Text.Email.Parser, emailToSAMLNameID, - emailFromSAMLNameID, emailFromSAML, ) where @@ -16,9 +15,7 @@ where ----- import Cassandra.CQL qualified as C -import Control.Lens ((^.)) import Data.ByteString.Conversion hiding (toByteString) -import Data.CaseInsensitive qualified as CI import Data.Data (Proxy (..)) import Data.OpenApi hiding (Schema, ToSchema) import Data.Schema @@ -116,11 +113,6 @@ arbitraryValidMail = do && notAt x && isValid (fromString ("me@" <> x)) -emailFromSAMLNameID :: SAML.NameID -> Maybe EmailAddress -emailFromSAMLNameID nid = case nid ^. SAML.nameID of - SAML.UNameIDEmail eml -> Just . emailFromSAML . CI.original $ eml - _ -> Nothing - -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this -- function total without all that praying and hoping. emailToSAMLNameID :: EmailAddress -> Either String SAML.NameID diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 21b82fb61ee..dd7f4ad8993 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -380,17 +380,9 @@ arbitraryValidScimIdNoNameIDQualifiers = do . (SAML.uidSubject . SAML.nameIDSPProvidedID .~ Nothing) . (SAML.uidSubject . SAML.nameIDSPNameQ .~ Nothing) --- | Take apart a 'ValidScimId', use both 'SAML.UserRef', 'Email' if applicable, and --- merge the result with a given function. -runValidScimIdBoth :: (a -> a -> a) -> (SAML.UserRef -> a) -> (EmailAddress -> a) -> ValidScimId -> a -runValidScimIdBoth merge doURefl doEmail = these doEmail doURefl (\em uref -> doEmail em `merge` doURefl uref) . validScimIdAuthInfo - veidUref :: ValidScimId -> Maybe SAML.UserRef veidUref = justThere . validScimIdAuthInfo -isSAMLUser :: ValidScimId -> Bool -isSAMLUser = isJust . justThere . validScimIdAuthInfo - makeLenses ''ValidScimUser makeLenses ''ValidScimId diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 20d194f5eb5..b8c6256122f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -147,13 +147,6 @@ getLocalAccountBy includePendingInvitations uid = } ) -getLocalExtendedAccounts :: (Member UserSubsystem r) => Local [UserId] -> Sem r [ExtendedUserAccount] -getLocalExtendedAccounts uids = do - getExtendedAccountsBy - ( qualifyAs uids $ - def {getByUserId = tUnqualified uids} - ) - getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) getLocalUserAccountByUserKey q@(tUnqualified -> ek) = listToMaybe . fmap (.account) <$> getExtendedAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek]) diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 66eb6939cdd..2435d71165b 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -352,7 +352,6 @@ executable spar-integration , cassava , cookie , crypton - , email-validate , exceptions , extended , hscim diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index c40d2921ef4..ec8ed68ed78 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -23,7 +23,6 @@ module Spar.Intra.BrigApp ( veidToUserSSOId, urefToExternalId, - urefToEmail, veidFromBrigUser, veidFromUserSSOId, mkUserName, @@ -37,8 +36,6 @@ module Spar.Intra.BrigApp -- * re-exports, mostly for historical reasons and lazyness emailFromSAML, - emailToSAMLNameID, - emailFromSAMLNameID, ) where diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 3f56bfac5fc..e041c3d0b1c 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -36,7 +36,6 @@ module Util.Core -- * Test helpers it, - fit, pending, pendingWith, shouldRespondWith, @@ -186,7 +185,7 @@ import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified System.Logger.Extended as Log import System.Random (randomRIO) -import Test.Hspec hiding (fit, it, pending, pendingWith, xit) +import Test.Hspec hiding (it, pending, pendingWith, xit) import qualified Test.Hspec import qualified Text.XML as XML import qualified Text.XML.Cursor as XML @@ -294,15 +293,6 @@ it :: SpecWith TestEnv it msg bdy = Test.Hspec.it msg $ runReaderT bdy -fit :: - (HasCallStack) => - -- or, more generally: - -- MonadIO m, Example (TestEnv -> m ()), Arg (TestEnv -> m ()) ~ TestEnv - String -> - TestSpar () -> - SpecWith TestEnv -fit msg bdy = Test.Hspec.fit msg $ runReaderT bdy - pending :: (HasCallStack, MonadIO m) => m () pending = liftIO Test.Hspec.pending diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index a077454467d..bf2b7ebe9ae 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -46,7 +46,6 @@ import qualified Spar.Intra.BrigApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Test.QuickCheck (arbitrary, generate) -import qualified Text.Email.Parser as Email import qualified Text.XML.DSig as SAML import Util.Core import Util.Types @@ -61,7 +60,6 @@ import qualified Web.Scim.Schema.Meta as Scim import qualified Web.Scim.Schema.PatchOp as Scim.PatchOp import qualified Web.Scim.Schema.User as Scim import qualified Web.Scim.Schema.User as Scim.User -import qualified Web.Scim.Schema.User.Email as Email import qualified Web.Scim.Schema.User.Email as Scim.Email import qualified Web.Scim.Schema.User.Phone as Phone import qualified Wire.API.Team.Member as Member @@ -203,17 +201,6 @@ randomScimUserWithNick = do nick ) -randomScimEmail :: (MonadRandom m) => m Email.Email -randomScimEmail = do - let typ :: Maybe Text = Nothing - primary :: Maybe Scim.ScimBool = Nothing -- TODO: where should we catch users with more than one - -- primary email? - value <- do - localpart <- cs <$> replicateM 15 (getRandomR ('a', 'z')) - domainpart <- (<> ".com") . cs <$> replicateM 15 (getRandomR ('a', 'z')) - pure . Email.EmailAddress $ Email.unsafeEmailAddress localpart domainpart - pure Email.Email {..} - randomScimPhone :: (MonadRandom m) => m Phone.Phone randomScimPhone = do let typ :: Maybe Text = Nothing diff --git a/weeder.toml b/weeder.toml index 54609bfe871..66ab0310a78 100644 --- a/weeder.toml +++ b/weeder.toml @@ -20,6 +20,7 @@ roots = [ # may of the entries here are about general-purpose module "^API.Team.Util.*$", # FUTUREWORK: Consider whether unused utility functions should be kept. "^Bilge.*$", "^Cassandra.Helpers.toOptionFieldName", + "^Cassandra.QQ.sql$", "^Data.ETag._OpaqueDigest", "^Data.ETag._StrictETag", "^Data.ETag._WeakETag", From f7034e6e737af54cce96e934ccbdd26213bf5b3f Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 12 Sep 2024 15:28:13 +0200 Subject: [PATCH 93/96] Regen nix. --- services/spar/default.nix | 2 -- 1 file changed, 2 deletions(-) diff --git a/services/spar/default.nix b/services/spar/default.nix index 8bada720bae..8e5b8b51e4f 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -20,7 +20,6 @@ , cookie , crypton , crypton-x509 -, email-validate , exceptions , extended , gitignoreSource @@ -159,7 +158,6 @@ mkDerivation { containers cookie crypton - email-validate exceptions extended hscim From c0aef874a195c2295033f8426b9202370f1d75f6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 15:41:48 +0200 Subject: [PATCH 94/96] rm some highly dubious weed. --- .../unit/Wire/MockInterpreters/InvitationCodeStore.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 23f34594b3a..5e4769022ae 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -6,7 +6,6 @@ import Data.Id (InvitationId, TeamId) import Data.Json.Util (toUTCTimeMillis) import Data.Map (elems, (!?)) import Data.Map qualified as M -import GHC.IO.Unsafe (unsafePerformIO) import Imports import Polysemy import Polysemy.State (State, get, gets, modify') @@ -21,14 +20,7 @@ inMemoryInvitationCodeStoreInterpreter :: ) => InterpreterFor InvitationCodeStore r inMemoryInvitationCodeStoreInterpreter = interpret \case - InsertInvitation (MkInsertInvitation invitationId teamId role' createdAt' createdBy email name) _timeout -> do - -- Currently unused. - let code = unsafePerformIO mkInvitationCode -- Should confirm that this works as intended (new code on every run) - let role = Just role' - createdAt = toUTCTimeMillis createdAt' - inv = MkStoredInvitation {..} - modify' $ \s -> M.insert (inv.teamId, inv.invitationId) inv s - pure inv + InsertInvitation _a _timeout -> error "InsertInvitation" LookupInvitation tid iid -> gets (!? (tid, iid)) LookupInvitationInfo iid -> gets (!? iid) LookupInvitationCodesByEmail em -> From 2879694e9e8d6d67551a49acbf300f683d1f453d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 16:09:26 +0200 Subject: [PATCH 95/96] Fix compiler warnings. --- .../test/unit/Wire/MockInterpreters/InvitationCodeStore.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs index 5e4769022ae..18f00055865 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -3,15 +3,13 @@ module Wire.MockInterpreters.InvitationCodeStore where import Data.Id (InvitationId, TeamId) -import Data.Json.Util (toUTCTimeMillis) import Data.Map (elems, (!?)) import Data.Map qualified as M import Imports import Polysemy -import Polysemy.State (State, get, gets, modify') +import Polysemy.State (State, get, gets) import Wire.API.User (InvitationCode (..)) import Wire.InvitationCodeStore -import Wire.InvitationCodeStore.Cassandra (mkInvitationCode) inMemoryInvitationCodeStoreInterpreter :: forall r. From 6b5637c0c99e8d4e839909bd2a5ce6c4c4d4a8f2 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 12 Sep 2024 17:12:36 +0200 Subject: [PATCH 96/96] hi ci