From daca032ba197dfbe8ee228a6a9b0e8fec0f95bf6 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 23 Sep 2024 11:40:57 +0000 Subject: [PATCH 01/40] wip: move accept team invitation to user subsystem --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 + .../src/Wire/UserSubsystem/Error.hs | 20 ++++++ .../src/Wire/UserSubsystem/Interpreter.hs | 63 ++++++++++++++++++- services/brig/src/Brig/API/User.hs | 6 +- services/brig/src/Brig/Team/API.hs | 58 +---------------- 5 files changed, 87 insertions(+), 62 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 95cfcc4ad6e..656483fe86e 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -17,6 +17,7 @@ import Data.Range import Data.Set qualified as Set import Imports import Polysemy +import Data.Misc import Polysemy.Error import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) @@ -140,6 +141,7 @@ data UserSubsystem m a where -- | This function exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () + AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 22b1a8e44ec..a056336e9a7 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -1,6 +1,8 @@ module Wire.UserSubsystem.Error where import Imports +import Network.HTTP.Types (status404) +import Network.Wai.Utilities qualified as Wai import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.Error @@ -17,6 +19,15 @@ data UserSubsystemError | UserSubsystemInvalidHandle | UserSubsystemProfileNotFound | UserSubsystemInsufficientTeamPermissions + | UserSubsystemCannotJoinMultipleTeams + | UserSubsystemTooManyTeamMembers + | UserSubsystemMissingAuth + | UserSubsystemBadCredentials + | UserSubsystemMissingIdentity + | UserSubsystemInvalidActivationCodeWrongUser + | UserSubsystemInvalidActivationCodeWrongCode + | UserSubsystemInvalidInvitationCode + | UserSubsystemInvitationNotFound deriving (Eq, Show) userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError @@ -30,5 +41,14 @@ userSubsystemErrorToHttpError = UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim UserSubsystemInsufficientTeamPermissions -> errorToWai @'E.InsufficientTeamPermissions + UserSubsystemCannotJoinMultipleTeams -> errorToWai @E.CannotJoinMultipleTeams + UserSubsystemTooManyTeamMembers -> errorToWai @E.TooManyTeamMembers + UserSubsystemMissingAuth -> errorToWai @E.MissingAuth + UserSubsystemBadCredentials -> errorToWai @E.BadCredentials + UserSubsystemMissingIdentity -> errorToWai @E.MissingIdentity + UserSubsystemInvalidActivationCodeWrongUser -> errorToWai @E.InvalidActivationCodeWrongUser + UserSubsystemInvalidActivationCodeWrongCode -> errorToWai @E.InvalidActivationCodeWrongCode + UserSubsystemInvalidInvitationCode -> errorToWai @E.InvalidInvitationCode + UserSubsystemInvitationNotFound -> Wai.mkError status404 "not-found" "Something went wrong, while looking up the invitation" instance Exception UserSubsystemError diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index a824fe73c92..35a1f4df8ae 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -16,6 +16,7 @@ import Data.Id import Data.Json.Util import Data.LegalHold import Data.List.Extra (nubOrd) +import Data.Misc (PlainTextPassword6) import Data.Qualified import Data.Range import Data.Time.Clock @@ -31,11 +32,13 @@ import System.Logger.Message qualified as Log import Wire.API.Federation.API import Wire.API.Federation.API.Brig qualified as FedBrig import Wire.API.Federation.Error +import Wire.API.Password (verifyPassword) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Permission qualified as Permission +import Wire.API.Team.Role (defaultRole) import Wire.API.Team.SearchVisibility import Wire.API.User as User import Wire.API.User.Search @@ -51,7 +54,8 @@ import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.IndexedUserStore.Bulk.ElasticSearch (teamSearchVisibilityInbound) -import Wire.InvitationCodeStore (InvitationCodeStore, lookupInvitationByEmail) +import Wire.InvitationCodeStore +import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.Sem.Concurrency import Wire.Sem.Metrics import Wire.Sem.Metrics qualified as Metrics @@ -95,7 +99,8 @@ runUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member (TinyLog) r, - Member InvitationCodeStore r + Member InvitationCodeStore r, + Member PasswordStore r ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r @@ -121,7 +126,8 @@ interpretUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member InvitationCodeStore r, - Member TinyLog r + Member TinyLog r, + Member PasswordStore r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case @@ -148,6 +154,7 @@ interpretUserSubsystem = interpret \case browseTeamImpl uid browseTeamFilters mMaxResults mPagingState InternalUpdateSearchIndex uid -> syncUserIndex uid + AcceptTeamInvitation luid pwd code -> acceptTeamInvitationImpl luid pwd code isBlockedImpl :: (Member BlockListStore r) => EmailAddress -> Sem r Bool isBlockedImpl = BlockList.exists . mkEmailKey @@ -855,3 +862,53 @@ getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations -- database schema re-design. gcHack :: Bool -> UserId -> Sem r () gcHack hasInvitation uid = unless hasInvitation (enqueueUserDeletion uid) + +acceptTeamInvitationImpl :: + ( Member (Input UserSubsystemConfig) r, + Member UserStore r, + Member GalleyAPIAccess r, + Member (Error UserSubsystemError) r, + Member InvitationCodeStore r, + Member IndexedUserStore r, + Member Metrics r, + Member Events r, + Member PasswordStore r + ) => + Local UserId -> + PlainTextPassword6 -> + InvitationCode -> + Sem r () +acceptTeamInvitationImpl luid pw code = do + (mek, mTid) <- do + mSelfProfile <- getSelfProfileImpl luid + let mek = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) + mTid = mSelfProfile >>= userTeam . selfUser + pure (mek, mTid) + checkPassword + (inv :: StoredInvitation, tid) <- (error "todo findTeamInvitation") mek code + let minvmeta = (,inv.createdAt) <$> inv.createdBy + uid = tUnqualified luid + for_ mTid $ \userTid -> + unless (tid == userTid) $ + throw UserSubsystemCannotJoinMultipleTeams + added <- GalleyAPIAccess.addTeamMember uid tid minvmeta (fromMaybe defaultRole inv.role) + unless added $ throw UserSubsystemTooManyTeamMembers + _ <- (error "todo updateUserTeam") uid tid + deleteInvitation inv.teamId inv.invitationId + syncUserIndex uid + generateUserEvent uid Nothing (teamUpdated uid tid) + where + checkPassword = do + p <- + (lookupHashedPassword . tUnqualified $ luid) + >>= maybe (throw UserSubsystemMissingAuth) pure + unless (verifyPassword pw p) $ + throw UserSubsystemBadCredentials + +-- toInvitationError :: RegisterError -> UserSubsystemError +-- toInvitationError = \case +-- RegisterErrorMissingIdentity -> UserSubsystemMissingIdentity +-- RegisterErrorInvalidActivationCodeWrongUser -> UserSubsystemInvalidActivationCodeWrongUser +-- RegisterErrorInvalidActivationCodeWrongCode -> UserSubsystemInvalidActivationCodeWrongCode +-- RegisterErrorInvalidInvitationCode -> UserSubsystemInvalidInvitationCode +-- _ -> UserSubsystemInvitationNotFound diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 6f94a7e6fd7..de980001c6b 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -403,7 +403,7 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do - acceptTeamInvitation account inv invInfo (mkEmailKey inv.email) (EmailIdentity inv.email) + acceptInvitationToTeam 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 @@ -432,14 +432,14 @@ createUser new = do verifyUniquenessAndCheckBlacklist k !>> identityErrorToRegisterError pure email - acceptTeamInvitation :: + acceptInvitationToTeam :: UserAccount -> StoredInvitation -> StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () - acceptTeamInvitation account inv invitationInfo uk ident = do + acceptInvitationToTeam account inv invitationInfo uk ident = do let uid = userId (accountUser account) ok <- lift $ liftSem $ claimKey uk uid unless ok $ diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index cf4f98dbce2..f8f2ed55637 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,7 +32,6 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App as App -import Brig.Data.User as User import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options import Brig.Team.Email @@ -44,7 +43,7 @@ import Control.Monad.Trans.Except (mapExceptT) import Data.ByteString.Conversion (toByteString, toByteString') import Data.Id import Data.List1 qualified as List1 -import Data.Qualified (Local, tUnqualified) +import Data.Qualified (Local) import Data.Range import Data.Text.Ascii import Data.Text.Encoding (encodeUtf8) @@ -64,7 +63,6 @@ import URI.ByteString (Absolute, URIRef, laxURIParserOptions, parseURI) import Util.Logging (logFunction, logTeam) import Wire.API.Error import Wire.API.Error.Brig qualified as E -import Wire.API.Password import Wire.API.Routes.Internal.Brig (FoundInvitationCode (FoundInvitationCode)) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Named @@ -79,23 +77,19 @@ import Wire.API.Team.Role import Wire.API.Team.Role qualified as Public import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public -import Wire.API.UserEvent import Wire.BlockListStore import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem.Template import Wire.Error import Wire.Events (Events) -import Wire.Events qualified as Events import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) import Wire.InvitationCodeStore qualified as Store import Wire.InvitationCodeStore.Cassandra qualified as Store (mkInvitationCode) -import Wire.PasswordStore import Wire.Sem.Concurrency import Wire.UserKeyStore import Wire.UserSubsystem -import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error servantAPI :: @@ -106,9 +100,7 @@ servantAPI :: Member EmailSending r, Member (Input (Local ())) r, Member TinyLog r, - Member PasswordStore r, Member (Input TeamTemplates) r, - Member Events r, Member (Error UserSubsystemError) r ) => ServerT TeamsAPI (Handler r) @@ -123,7 +115,7 @@ servantAPI = :<|> Named @"get-team-invitation-info" getInvitationByCode :<|> Named @"head-team-invitations" (lift . liftSem . headInvitationByEmail) :<|> Named @"get-team-size" teamSizePublic - :<|> Named @"accept-team-invitation" acceptTeamInvitationByPersonalUser + :<|> Named @"accept-team-invitation" (\luid req -> lift $ liftSem $ acceptTeamInvitation luid req.password req.code) teamSizePublic :: ( Member GalleyAPIAccess r, @@ -567,49 +559,3 @@ changeTeamAccountStatuses tid s = do where toList1 (x : xs) = pure $ List1.list1 x xs toList1 [] = throwStd (notFound "Team not found or no members") - -acceptTeamInvitationByPersonalUser :: - forall r. - ( Member UserSubsystem r, - Member GalleyAPIAccess r, - Member InvitationCodeStore r, - Member PasswordStore r, - Member Events r - ) => - Local UserId -> - AcceptTeamInvitation -> - (Handler r) () -acceptTeamInvitationByPersonalUser luid req = do - (mek, mTid) <- do - mSelfProfile <- lift $ liftSem $ getSelfProfile luid - let mek = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) - mTid = mSelfProfile >>= userTeam . selfUser - pure (mek, mTid) - checkPassword - (inv, (.teamId) -> tid) <- API.findTeamInvitation mek req.code !>> toInvitationError - let minvmeta = (,inv.createdAt) <$> inv.createdBy - uid = tUnqualified luid - for_ mTid $ \userTid -> - unless (tid == userTid) $ - throwStd (errorToWai @'E.CannotJoinMultipleTeams) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid minvmeta (fromMaybe defaultRole inv.role) - unless added $ throwStd (errorToWai @'E.TooManyTeamMembers) - lift $ do - wrapClient $ User.updateUserTeam uid tid - liftSem $ Store.deleteInvitation inv.teamId inv.invitationId - liftSem $ User.internalUpdateSearchIndex uid - liftSem $ Events.generateUserEvent uid Nothing (teamUpdated uid tid) - where - checkPassword = do - p <- - lift (liftSem . lookupHashedPassword . tUnqualified $ luid) - >>= maybe (throwStd (errorToWai @'E.MissingAuth)) pure - unless (verifyPassword req.password p) $ - throwStd (errorToWai @'E.BadCredentials) - toInvitationError :: RegisterError -> HttpError - toInvitationError = \case - RegisterErrorMissingIdentity -> StdError (errorToWai @'E.MissingIdentity) - RegisterErrorInvalidActivationCodeWrongUser -> StdError (errorToWai @'E.InvalidActivationCodeWrongUser) - RegisterErrorInvalidActivationCodeWrongCode -> StdError (errorToWai @'E.InvalidActivationCodeWrongCode) - RegisterErrorInvalidInvitationCode -> StdError (errorToWai @'E.InvalidInvitationCode) - _ -> StdError (notFound "Something went wrong, while looking up the invitation") From 7d198dc0976d68190242f0bd0bdb7d414e4130b8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 23 Sep 2024 12:40:57 +0000 Subject: [PATCH 02/40] update user team moved to user store --- libs/wire-subsystems/src/Wire/UserStore.hs | 1 + libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs | 7 +++++++ libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 2 +- services/brig/src/Brig/API/Public.hs | 3 ++- services/brig/src/Brig/API/User.hs | 3 ++- services/brig/src/Brig/Data/User.hs | 7 ------- 6 files changed, 13 insertions(+), 10 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 1c33abd7e42..55373c0a37d 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -66,6 +66,7 @@ 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)) + UpdateUserTeam :: UserId -> TeamId -> UserStore m () makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index f6c71536c65..66d35568d27 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -30,6 +30,7 @@ interpretUserStoreCassandra casClient = LookupStatus uid -> lookupStatusImpl uid IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid + UpdateUserTeam uid tid -> updateUserTeamImpl uid tid getUsersImpl :: [UserId] -> Client [StoredUser] getUsersImpl usrs = @@ -162,6 +163,12 @@ lookupLocaleImpl :: UserId -> Client (Maybe (Maybe Language, Maybe Country)) lookupLocaleImpl u = do retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) +updateUserTeamImpl :: UserId -> TeamId -> Client () +updateUserTeamImpl u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, u)) + where + userTeamUpdate :: PrepQuery W (TeamId, UserId) () + userTeamUpdate = "UPDATE user SET team = ? WHERE id = ?" + -------------------------------------------------------------------------------- -- Queries diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 35a1f4df8ae..aeb887500aa 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -893,7 +893,7 @@ acceptTeamInvitationImpl luid pw code = do throw UserSubsystemCannotJoinMultipleTeams added <- GalleyAPIAccess.addTeamMember uid tid minvmeta (fromMaybe defaultRole inv.role) unless added $ throw UserSubsystemTooManyTeamMembers - _ <- (error "todo updateUserTeam") uid tid + updateUserTeam uid tid deleteInvitation inv.teamId inv.invitationId syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d413d2493e2..44d923c5984 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -711,7 +711,8 @@ upgradePersonalToTeam :: Member (Input UTCTime) r, Member NotificationSubsystem r, Member TinyLog r, - Member UserSubsystem r + Member UserSubsystem r, + Member UserStore r ) => Local UserId -> Public.BindingNewTeamUser -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index de980001c6b..1f63ba901a6 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -260,6 +260,7 @@ upgradePersonalToTeam :: forall r. ( Member GalleyAPIAccess r, Member EmailSubsystem r, + Member UserStore r, Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, @@ -292,7 +293,7 @@ upgradePersonalToTeam luid bNewTeam = do let newTeam = bNewTeam.bnuTeam pure $ CreateUserTeam tid (fromRange newTeam.newTeamName) - wrapClient $ updateUserTeam uid tid + liftSem $ updateUserTeam uid tid liftSem $ Intra.sendUserEvent uid Nothing (teamUpdated uid tid) initAccountFeatureConfig uid diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index bf26066e582..eb814e1c590 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -53,7 +53,6 @@ module Brig.Data.User updateStatus, updateRichInfo, updateFeatureConferenceCalling, - updateUserTeam, -- * Deletions deleteEmail, @@ -383,12 +382,6 @@ lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) -updateUserTeam :: (MonadClient m) => UserId -> TeamId -> m () -updateUserTeam u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, u)) - where - userTeamUpdate :: PrepQuery W (TeamId, UserId) () - userTeamUpdate = "UPDATE user SET team = ? WHERE id = ?" - lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus)) lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity u))) where From 11f515506e9bfd8d92d0b09e89fd0868e9ddae05 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 23 Sep 2024 13:29:09 +0000 Subject: [PATCH 03/40] wip: move findTeamInvitation to subsystems --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 4 +- .../src/Wire/UserSubsystem/Error.hs | 2 + .../src/Wire/UserSubsystem/Interpreter.hs | 37 ++++++++++++++++++- 3 files changed, 41 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 656483fe86e..a08e22628a8 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -12,12 +12,12 @@ import Data.Domain import Data.Handle (Handle) import Data.HavePendingInvitations import Data.Id +import Data.Misc import Data.Qualified import Data.Range import Data.Set qualified as Set import Imports import Polysemy -import Data.Misc import Polysemy.Error import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) @@ -29,6 +29,7 @@ import Wire.API.User.Search import Wire.Arbitrary import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore import Wire.UserKeyStore (EmailKey, emailKeyOrig) import Wire.UserSearch.Types import Wire.UserSubsystem.Error (UserSubsystemError (..)) @@ -142,6 +143,7 @@ data UserSubsystem m a where -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () + InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m (StoredInvitation, StoredInvitationInfo) -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index a056336e9a7..7bca7a943db 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -28,6 +28,7 @@ data UserSubsystemError | UserSubsystemInvalidActivationCodeWrongCode | UserSubsystemInvalidInvitationCode | UserSubsystemInvitationNotFound + | UserSubsystemUserNotAllowedToJoinTeam Wai.Error deriving (Eq, Show) userSubsystemErrorToHttpError :: UserSubsystemError -> HttpError @@ -50,5 +51,6 @@ userSubsystemErrorToHttpError = UserSubsystemInvalidActivationCodeWrongCode -> errorToWai @E.InvalidActivationCodeWrongCode UserSubsystemInvalidInvitationCode -> errorToWai @E.InvalidInvitationCode UserSubsystemInvitationNotFound -> Wai.mkError status404 "not-found" "Something went wrong, while looking up the invitation" + UserSubsystemUserNotAllowedToJoinTeam e -> e instance Exception UserSubsystemError diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index aeb887500aa..c0cdc35de69 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -40,6 +40,7 @@ import Wire.API.Team.Member import Wire.API.Team.Permission qualified as Permission import Wire.API.Team.Role (defaultRole) import Wire.API.Team.SearchVisibility +import Wire.API.Team.Size (TeamSize (TeamSize)) import Wire.API.User as User import Wire.API.User.Search import Wire.API.UserEvent @@ -75,7 +76,8 @@ import Witherable (wither) data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, defaultLocale :: Locale, - searchSameTeamOnly :: Bool + searchSameTeamOnly :: Bool, + maxTeamSize :: Word32 } deriving (Show, Generic) deriving (Arbitrary) via (GenericUniform UserSubsystemConfig) @@ -155,6 +157,39 @@ interpretUserSubsystem = interpret \case InternalUpdateSearchIndex uid -> syncUserIndex uid AcceptTeamInvitation luid pwd code -> acceptTeamInvitationImpl luid pwd code + InternalFindTeamInvitation mEmailKey code -> internalFindTeamInvitationImpl mEmailKey code + +internalFindTeamInvitationImpl :: + ( Member InvitationCodeStore r, + Member (Error UserSubsystemError) r, + Member (Input UserSubsystemConfig) r, + Member (GalleyAPIAccess) r + ) => + Maybe EmailKey -> + InvitationCode -> + Sem r (StoredInvitation, StoredInvitationInfo) +internalFindTeamInvitationImpl Nothing _ = throw UserSubsystemMissingIdentity +internalFindTeamInvitationImpl (Just e) c = + lookupInvitationInfo c >>= \case + Just invitationInfo -> do + inv <- lookupInvitation invitationInfo.teamId invitationInfo.invitationId + case (inv, (.email) <$> inv) of + (Just invite, Just em) + | e == mkEmailKey em -> do + ensureMemberCanJoin invitationInfo.teamId + pure (invite, invitationInfo) + _ -> throw UserSubsystemInvalidInvitationCode + Nothing -> throw UserSubsystemInvalidInvitationCode + where + ensureMemberCanJoin tid = do + maxSize <- maxTeamSize <$> input + (TeamSize teamSize) <- (error "todo impl team size in search subsystem") tid + when (teamSize >= fromIntegral maxSize) $ + throw UserSubsystemTooManyTeamMembers + -- FUTUREWORK: The above can easily be done/tested in the intra call. + -- Remove after the next release. + mAddUserError <- checkUserCanJoinTeam tid + maybe (pure ()) (throw . UserSubsystemUserNotAllowedToJoinTeam) mAddUserError isBlockedImpl :: (Member BlockListStore r) => EmailAddress -> Sem r Bool isBlockedImpl = BlockList.exists . mkEmailKey From 94724d62d1ecb3dde1545d6a3299f626c7abaac6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 23 Sep 2024 16:01:27 +0200 Subject: [PATCH 04/40] Provide unsafeFromPassword (it's safe, but we don't want to use it). --- libs/wire-api/src/Wire/API/Password.hs | 4 +++ .../Wire/UserSubsystem/InterpreterSpec.hs | 32 +++++++++---------- 2 files changed, 20 insertions(+), 16 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Password.hs b/libs/wire-api/src/Wire/API/Password.hs index c7aa15111ff..c54f647d5ad 100644 --- a/libs/wire-api/src/Wire/API/Password.hs +++ b/libs/wire-api/src/Wire/API/Password.hs @@ -27,6 +27,7 @@ module Wire.API.Password verifyPassword, verifyPasswordWithStatus, unsafeMkPassword, + unsafeFromPassword, hashPasswordArgon2idWithSalt, hashPasswordArgon2idWithOptions, PasswordReqBody (..), @@ -69,6 +70,9 @@ instance Cql Password where unsafeMkPassword :: Text -> Password unsafeMkPassword = Password +unsafeFromPassword :: Password -> Text +unsafeFromPassword = fromPassword + data PasswordStatus = PasswordStatusOk | PasswordStatusNeedsUpdate diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index ee679f39123..e89ea8cbcc5 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -56,7 +56,7 @@ spec = describe "UserSubsystem.Interpreter" do target1 = mkUserIds remoteDomain1 targetUsers1 target2 = mkUserIds remoteDomain2 targetUsers2 localBackend = def {users = [viewer] <> localTargetUsers} - config = UserSubsystemConfig visibility miniLocale False + config = UserSubsystemConfig visibility miniLocale False 100 retrievedProfiles = runFederationStack localBackend federation Nothing config $ getUserProfiles @@ -84,7 +84,7 @@ spec = describe "UserSubsystem.Interpreter" do mkUserIds domain users = map (flip Qualified domain . (.id)) users onlineUsers = mkUserIds onlineDomain onlineTargetUsers offlineUsers = mkUserIds offlineDomain offlineTargetUsers - config = UserSubsystemConfig visibility miniLocale False + config = UserSubsystemConfig visibility miniLocale False 100 localBackend = def {users = [viewer]} result = run @@ -153,7 +153,7 @@ spec = describe "UserSubsystem.Interpreter" do \viewer targetUsers visibility domain remoteDomain -> do let remoteBackend = def {users = targetUsers} federation = [(remoteDomain, remoteBackend)] - config = UserSubsystemConfig visibility miniLocale False + config = UserSubsystemConfig visibility miniLocale False 100 localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend federation Nothing config $ @@ -174,7 +174,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "Remote users on offline backend always fail to return" $ \viewer (targetUsers :: Set StoredUser) visibility domain remoteDomain -> do let online = mempty - config = UserSubsystemConfig visibility miniLocale False + config = UserSubsystemConfig visibility miniLocale False 100 localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ @@ -194,7 +194,7 @@ spec = describe "UserSubsystem.Interpreter" do allDomains = [domain, remoteDomainA, remoteDomainB] remoteAUsers = map (flip Qualified remoteDomainA . (.id)) targetUsers remoteBUsers = map (flip Qualified remoteDomainB . (.id)) targetUsers - config = UserSubsystemConfig visibility miniLocale False + config = UserSubsystemConfig visibility miniLocale False 100 localBackend = def {users = [viewer]} retrievedProfilesWithErrors :: ([(Qualified UserId, FederationError)], [UserProfile]) = runFederationStack localBackend online Nothing config $ @@ -279,7 +279,7 @@ spec = describe "UserSubsystem.Interpreter" 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 False + let config = UserSubsystemConfig visibility locale False 100 alice = alice' { email = Just email, @@ -314,7 +314,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId works for pending if explicitly queried" $ \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True + let config = UserSubsystemConfig visibility locale True 100 alice = alice' { email = Just email, @@ -348,7 +348,7 @@ spec = describe "UserSubsystem.Interpreter" do 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 True + let config = UserSubsystemConfig visibility locale True 100 alice = alice' { email = Just email, @@ -384,7 +384,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy handle works for pending if explicitly queried" $ \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True + let config = UserSubsystemConfig visibility locale True 100 alice = alice' { email = Just email, @@ -420,7 +420,7 @@ 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 True + let config = UserSubsystemConfig visibility locale True 100 alice = alice' {email = Just email} localBackend = def @@ -434,7 +434,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId does not return missing identity users, pending invitation off" $ \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True + let config = UserSubsystemConfig visibility locale True 100 getBy = toLocalUnsafe localDomain $ def @@ -449,7 +449,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "GetBy userId does not return missing identity users, pending invtation on" $ \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> - let config = UserSubsystemConfig visibility locale True + let config = UserSubsystemConfig visibility locale True 100 getBy = toLocalUnsafe localDomain $ def @@ -464,7 +464,7 @@ spec = describe "UserSubsystem.Interpreter" do 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 True + let config = UserSubsystemConfig visibility locale True 100 emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -493,7 +493,7 @@ spec = describe "UserSubsystem.Interpreter" do 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 True + let config = UserSubsystemConfig visibility locale True 100 emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -514,7 +514,7 @@ spec = describe "UserSubsystem.Interpreter" do 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 True + let config = UserSubsystemConfig visibility locale True 100 emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ @@ -548,7 +548,7 @@ spec = describe "UserSubsystem.Interpreter" do 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 True + let config = UserSubsystemConfig visibility locale True 100 emailKey = mkEmailKey email getBy = toLocalUnsafe localDomain $ From ab795efef5dcb0cca57c0acfeb4d7a4cf1c9e8b3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 23 Sep 2024 16:13:37 +0200 Subject: [PATCH 05/40] Fix --- libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index c0cdc35de69..92ecd22e639 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -128,8 +128,7 @@ interpretUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member InvitationCodeStore r, - Member TinyLog r, - Member PasswordStore r + Member TinyLog r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case From 5e799bf8a4d8ca3608ec695131e96ceee1132a78 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 24 Sep 2024 12:42:45 +0200 Subject: [PATCH 06/40] Deal with intepreters of user and auth subsystems being dependent on each other --- .../AuthenticationSubsystem/Interpreter.hs | 12 +- .../src/Wire/UserSubsystem/Interpreter.hs | 130 ++++++++------ .../InterpreterSpec.hs | 159 ++++++++---------- .../test/unit/Wire/MiniBackend.hs | 89 ++++++---- .../Wire/MockInterpreters/EmailSubsystem.hs | 14 ++ .../PasswordResetCodeStore.hs | 6 + .../Wire/MockInterpreters/PasswordStore.hs | 3 + .../Wire/MockInterpreters/SessionStore.hs | 6 + .../unit/Wire/MockInterpreters/UserStore.hs | 6 + .../Wire/UserSubsystem/InterpreterSpec.hs | 22 ++- .../brig/src/Brig/CanonicalInterpreter.hs | 24 ++- 11 files changed, 275 insertions(+), 196 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 2d28021a6a1..94515b1db6a 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -62,15 +62,17 @@ interpretAuthenticationSubsystem :: Member SessionStore r, Member (Input (Local ())) r, Member (Input (Maybe AllowlistEmailDomains)) r, - Member UserSubsystem r, Member PasswordStore r, Member EmailSubsystem r ) => + InterpreterFor UserSubsystem r -> InterpreterFor AuthenticationSubsystem r -interpretAuthenticationSubsystem = interpret $ \case - CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey - ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword - InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey +interpretAuthenticationSubsystem userSubsystemInterpreter = + interpret $ + userSubsystemInterpreter . \case + CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey + ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword + InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey maxAttempts :: Int32 maxAttempts = 3 diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 92ecd22e639..e554fd9980f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -45,6 +45,7 @@ import Wire.API.User as User import Wire.API.User.Search import Wire.API.UserEvent import Wire.Arbitrary +import Wire.AuthenticationSubsystem import Wire.BlockListStore as BlockList import Wire.DeleteQueue import Wire.Events @@ -83,32 +84,6 @@ data UserSubsystemConfig = UserSubsystemConfig deriving (Arbitrary) via (GenericUniform UserSubsystemConfig) runUserSubsystem :: - ( Member GalleyAPIAccess r, - Member UserStore r, - Member UserKeyStore r, - Member BlockListStore r, - Member (Concurrency 'Unsafe) r, -- FUTUREWORK: subsystems should implement concurrency inside interpreters, not depend on this dangerous effect. - Member (Error FederationError) r, - Member (Error UserSubsystemError) r, - Member (FederationAPIAccess fedM) r, - Member DeleteQueue r, - Member Events r, - Member Now r, - RunClient (fedM 'Brig), - FederationMonad fedM, - Typeable fedM, - Member IndexedUserStore r, - Member FederationConfigStore r, - Member Metrics r, - Member (TinyLog) r, - Member InvitationCodeStore r, - Member PasswordStore r - ) => - UserSubsystemConfig -> - InterpreterFor UserSubsystem r -runUserSubsystem cfg = runInputConst cfg . interpretUserSubsystem . raiseUnder - -interpretUserSubsystem :: ( Member UserStore r, Member UserKeyStore r, Member GalleyAPIAccess r, @@ -117,7 +92,6 @@ interpretUserSubsystem :: Member (Error FederationError) r, Member (Error UserSubsystemError) r, Member (FederationAPIAccess fedM) r, - Member (Input UserSubsystemConfig) r, Member DeleteQueue r, Member Events r, Member Now r, @@ -128,35 +102,77 @@ interpretUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member InvitationCodeStore r, - Member TinyLog r + Member TinyLog r, + Member PasswordStore r ) => + UserSubsystemConfig -> + InterpreterFor AuthenticationSubsystem r -> InterpreterFor UserSubsystem r -interpretUserSubsystem = interpret \case - GetUserProfiles self others -> getUserProfilesImpl self others - GetLocalUserProfiles others -> getLocalUserProfilesImpl others - GetExtendedAccountsBy getBy -> getExtendedAccountsByImpl getBy - 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 - CheckHandle uhandle -> checkHandleImpl uhandle - CheckHandles hdls cnt -> checkHandlesImpl hdls cnt - UpdateHandle uid mconn mb uhandle -> updateHandleImpl uid mconn mb uhandle - LookupLocaleWithDefault luid -> lookupLocaleOrDefaultImpl luid - IsBlocked email -> isBlockedImpl email - BlockListDelete email -> blockListDeleteImpl email - BlockListInsert email -> blockListInsertImpl email - UpdateTeamSearchVisibilityInbound status -> - updateTeamSearchVisibilityInboundImpl status - SearchUsers luid query mDomain mMaxResults -> - searchUsersImpl luid query mDomain mMaxResults - BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> - browseTeamImpl uid browseTeamFilters mMaxResults mPagingState - InternalUpdateSearchIndex uid -> - syncUserIndex uid - AcceptTeamInvitation luid pwd code -> acceptTeamInvitationImpl luid pwd code - InternalFindTeamInvitation mEmailKey code -> internalFindTeamInvitationImpl mEmailKey code +runUserSubsystem cfg authInterpreter = + interpret $ + \case + GetUserProfiles self others -> + runInputConst cfg $ + getUserProfilesImpl self others + GetLocalUserProfiles others -> + runInputConst cfg $ + getLocalUserProfilesImpl others + GetExtendedAccountsBy getBy -> + runInputConst cfg $ + getExtendedAccountsByImpl getBy + GetExtendedAccountsByEmailNoFilter emails -> + runInputConst cfg $ + getExtendedAccountsByEmailNoFilterImpl emails + GetAccountNoFilter luid -> + runInputConst cfg $ + getAccountNoFilterImpl luid + GetSelfProfile self -> + runInputConst cfg $ + getSelfProfileImpl self + GetUserProfilesWithErrors self others -> + runInputConst cfg $ + getUserProfilesWithErrorsImpl self others + UpdateUserProfile self mconn mb update -> + runInputConst cfg $ + updateUserProfileImpl self mconn mb update + CheckHandle uhandle -> + runInputConst cfg $ + checkHandleImpl uhandle + CheckHandles hdls cnt -> + runInputConst cfg $ + checkHandlesImpl hdls cnt + UpdateHandle uid mconn mb uhandle -> + runInputConst cfg $ + updateHandleImpl uid mconn mb uhandle + LookupLocaleWithDefault luid -> + runInputConst cfg $ + lookupLocaleOrDefaultImpl luid + IsBlocked email -> + runInputConst cfg $ + isBlockedImpl email + BlockListDelete email -> + runInputConst cfg $ + blockListDeleteImpl email + BlockListInsert email -> + runInputConst cfg $ + blockListInsertImpl email + UpdateTeamSearchVisibilityInbound status -> + runInputConst cfg $ + updateTeamSearchVisibilityInboundImpl status + SearchUsers luid query mDomain mMaxResults -> + runInputConst cfg $ + searchUsersImpl luid query mDomain mMaxResults + BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> + browseTeamImpl uid browseTeamFilters mMaxResults mPagingState + InternalUpdateSearchIndex uid -> + syncUserIndex uid + AcceptTeamInvitation luid pwd code -> + authInterpreter + . runInputConst cfg + $ acceptTeamInvitationImpl luid pwd code + InternalFindTeamInvitation mEmailKey code -> + runInputConst cfg $ + internalFindTeamInvitationImpl mEmailKey code internalFindTeamInvitationImpl :: ( Member InvitationCodeStore r, @@ -906,7 +922,8 @@ acceptTeamInvitationImpl :: Member IndexedUserStore r, Member Metrics r, Member Events r, - Member PasswordStore r + Member PasswordStore r, + Member AuthenticationSubsystem r ) => Local UserId -> PlainTextPassword6 -> @@ -918,6 +935,9 @@ acceptTeamInvitationImpl luid pw code = do let mek = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) mTid = mSelfProfile >>= userTeam . selfUser pure (mek, mTid) + -- TODO: This exists to make the warnings go away, this is not supposed to be + -- in final code. We have to implement checkPassword in terms of Auth subsystem. + forM_ mek $ createPasswordResetCode checkPassword (inv :: StoredInvitation, tid) <- (error "todo findTeamInvitation") mek code let minvmeta = (,inv.createdAt) <$> inv.createdBy diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 85a9af652a3..83d60544ae8 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -34,10 +34,10 @@ import Wire.Sem.Logger.TinyLog import Wire.Sem.Now (Now) import Wire.SessionStore import Wire.UserKeyStore -import Wire.UserSubsystem type AllEffects = - [ Error AuthenticationSubsystemError, + [ AuthenticationSubsystem, + Error AuthenticationSubsystemError, HashPassword, Now, State UTCTime, @@ -46,26 +46,22 @@ type AllEffects = SessionStore, State (Map UserId [Cookie ()]), PasswordStore, - State (Map UserId Password), PasswordResetCodeStore, State (Map PasswordResetKey (PRQueryData Identity)), TinyLog, EmailSubsystem, - State (Map EmailAddress [SentMail]), - UserSubsystem + State (Map EmailAddress [SentMail]) ] -interpretDependencies :: Domain -> [ExtendedUserAccount] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a -interpretDependencies localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains = +runAllEffects :: Domain -> [ExtendedUserAccount] -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a +runAllEffects localDomain preexistingUsers mAllowedEmailDomains = run - . userSubsystemTestInterpreter preexistingUsers . evalState mempty . emailSubsystemInterpreter . discardTinyLogs . evalState mempty . inMemoryPasswordResetCodeStore - . evalState preexistingPasswords - . inMemoryPasswordStoreInterpreter + . runInMemoryPasswordStoreInterpreter . evalState mempty . inMemorySessionStoreInterpreter . runInputConst (AllowlistEmailDomains <$> mAllowedEmailDomains) @@ -74,6 +70,7 @@ interpretDependencies localDomain preexistingUsers preexistingPasswords mAllowed . interpretNowAsState . staticHashPasswordInterpreter . runError + . interpretAuthenticationSubsystem (userSubsystemTestInterpreter preexistingUsers) spec :: Spec spec = describe "AuthenticationSubsystem.Interpreter" do @@ -84,17 +81,15 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, cookiesAfterReset) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) - mapM_ (uncurry (insertCookie uid)) cookiesWithTTL + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + mapM_ (uncurry (insertCookie uid)) cookiesWithTTL - createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email - resetPassword (PasswordResetEmailIdentity email) code newPassword + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetEmailIdentity email) code newPassword - (,) <$> lookupHashedPassword uid <*> listCookies uid + (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> (fmap (verifyPassword newPassword) newPasswordHash === Just True) .&&. (cookiesAfterReset === []) @@ -105,17 +100,15 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, cookiesAfterReset) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) - mapM_ (uncurry (insertCookie uid)) cookiesWithTTL + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) + mapM_ (uncurry (insertCookie uid)) cookiesWithTTL - createPasswordResetCode (mkEmailKey email) - (passwordResetKey, code) <- expect1ResetPasswordEmail email - resetPassword (PasswordResetIdentityKey passwordResetKey) code newPassword + createPasswordResetCode (mkEmailKey email) + (passwordResetKey, code) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetIdentityKey passwordResetKey) code newPassword - (,) <$> lookupHashedPassword uid <*> listCookies uid + (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> (fmap (verifyPassword newPassword) newPasswordHash === Just True) .&&. (cookiesAfterReset === []) @@ -123,9 +116,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do prop "reset code is not generated when email is not in allow list" $ \email localDomain -> let createPasswordResetCodeResult = - interpretDependencies localDomain [] mempty (Just ["example.com"]) - . interpretAuthenticationSubsystem - $ createPasswordResetCode (mkEmailKey email) + runAllEffects localDomain [] (Just ["example.com"]) $ + createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent in domainPart email /= "example.com" ==> createPasswordResetCodeResult === Right () @@ -135,9 +127,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do let user = userNoEmail {userIdentity = Just $ EmailIdentity email} localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty (Just [decodeUtf8 $ domainPart email]) - . interpretAuthenticationSubsystem - $ createPasswordResetCode (mkEmailKey email) + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] (Just [decodeUtf8 $ domainPart email]) $ + createPasswordResetCode (mkEmailKey email) in counterexample ("expected Right, got: " <> show createPasswordResetCodeResult) $ isRight createPasswordResetCodeResult @@ -146,9 +137,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do let user = userNoEmail {userIdentity = Just $ EmailIdentity email} localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user status) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ createPasswordResetCode (mkEmailKey email) + runAllEffects localDomain [ExtendedUserAccount (UserAccount user status) Nothing] Nothing $ + createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent in status /= Active ==> createPasswordResetCodeResult === Right () @@ -156,9 +146,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do prop "reset code is not generated for when there is no user for the email" $ \email localDomain -> let createPasswordResetCodeResult = - interpretDependencies localDomain [] mempty Nothing - . interpretAuthenticationSubsystem - $ createPasswordResetCode (mkEmailKey email) + runAllEffects localDomain [] Nothing $ + createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent in createPasswordResetCodeResult === Right () @@ -168,18 +157,16 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, mCaughtException) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email - mCaughtExc <- catchExpectedError $ createPasswordResetCode (mkEmailKey email) + mCaughtExc <- catchExpectedError $ createPasswordResetCode (mkEmailKey email) - -- Reset password still works with previously generated reset code - resetPassword (PasswordResetEmailIdentity email) code newPassword + -- Reset password still works with previously generated reset code + resetPassword (PasswordResetEmailIdentity email) code newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + (,mCaughtExc) <$> lookupHashedPassword uid in (fmap (verifyPassword newPassword) newPasswordHash === Just True) .&&. (mCaughtException === Nothing) @@ -189,17 +176,15 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - upsertHashedPassword uid =<< hashPassword oldPassword - createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + upsertHashedPassword uid =<< hashPassword oldPassword + createPasswordResetCode (mkEmailKey email) + (_, code) <- expect1ResetPasswordEmail email - passTime (passwordResetCodeTtl + 1) + passTime (passwordResetCodeTtl + 1) - mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) code newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) code newPassword + (,mCaughtExc) <$> lookupHashedPassword uid in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode .&&. verifyPasswordProp oldPassword passwordInDB @@ -209,12 +194,10 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - upsertHashedPassword uid =<< hashPassword oldPassword - mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + upsertHashedPassword uid =<< hashPassword oldPassword + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword + (,mCaughtExc) <$> lookupHashedPassword uid in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode .&&. verifyPasswordProp oldPassword passwordInDB @@ -224,12 +207,10 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - hashAndUpsertPassword uid oldPassword - mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity wrongEmail) resetCode newPassword - (,mCaughtExc) <$> lookupHashedPassword uid + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + hashAndUpsertPassword uid oldPassword + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity wrongEmail) resetCode newPassword + (,mCaughtExc) <$> lookupHashedPassword uid in email /= wrongEmail ==> resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetKey .&&. verifyPasswordProp oldPassword passwordInDB @@ -240,20 +221,18 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordHashInDB, correctResetCode, wrongResetErrors, resetPassworedWithCorectCodeResult) = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - upsertHashedPassword uid =<< hashPassword oldPassword - createPasswordResetCode (mkEmailKey email) - (_, generatedResetCode) <- expect1ResetPasswordEmail email - - wrongResetErrs <- - replicateM wrongResetAttempts $ - catchExpectedError $ - resetPassword (PasswordResetEmailIdentity email) arbitraryResetCode newPassword - - mFinalResetErr <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) generatedResetCode newPassword - (,generatedResetCode,wrongResetErrs,mFinalResetErr) <$> lookupHashedPassword uid + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + upsertHashedPassword uid =<< hashPassword oldPassword + createPasswordResetCode (mkEmailKey email) + (_, generatedResetCode) <- expect1ResetPasswordEmail email + + wrongResetErrs <- + replicateM wrongResetAttempts $ + catchExpectedError $ + resetPassword (PasswordResetEmailIdentity email) arbitraryResetCode newPassword + + mFinalResetErr <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) generatedResetCode newPassword + (,generatedResetCode,wrongResetErrs,mFinalResetErr) <$> lookupHashedPassword uid expectedFinalResetResult = if wrongResetAttempts >= 3 then Just AuthenticationSubsystemInvalidPasswordResetCode @@ -274,13 +253,11 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right passwordHashInDB = - interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing - . interpretAuthenticationSubsystem - $ do - void $ createPasswordResetCode (mkEmailKey email) - mLookupRes <- internalLookupPasswordResetCode (mkEmailKey email) - for_ mLookupRes $ \(_, code) -> resetPassword (PasswordResetEmailIdentity email) code newPassword - lookupHashedPassword uid + runAllEffects localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] Nothing $ do + void $ createPasswordResetCode (mkEmailKey email) + mLookupRes <- internalLookupPasswordResetCode (mkEmailKey email) + for_ mLookupRes $ \(_, code) -> resetPassword (PasswordResetEmailIdentity email) code newPassword + lookupHashedPassword uid in verifyPasswordProp newPassword passwordHashInDB newtype Upto4 = Upto4 Int diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 415b0117d05..c0d68dadc93 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -48,6 +48,7 @@ import Servant.Client.Core import System.Logger qualified as Log import Test.QuickCheck import Type.Reflection +import Wire.API.Allowlists (AllowlistEmailDomains) import Wire.API.Federation.API import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -57,14 +58,18 @@ import Wire.API.User as User hiding (DeleteUser) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Password import Wire.ActivationCodeStore +import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem.Interpreter import Wire.BlockListStore import Wire.DeleteQueue import Wire.DeleteQueue.InMemory +import Wire.EmailSubsystem (EmailSubsystem) import Wire.Events import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter as FI import Wire.FederationConfigStore import Wire.GalleyAPIAccess +import Wire.HashPassword (HashPassword) import Wire.IndexedUserStore import Wire.InternalEvent hiding (DeleteUser) import Wire.InvitationCodeStore @@ -72,11 +77,13 @@ import Wire.MockInterpreters import Wire.MockInterpreters.ActivationCodeStore (inMemoryActivationCodeStoreInterpreter) import Wire.MockInterpreters.InvitationCodeStore (inMemoryInvitationCodeStoreInterpreter) import Wire.PasswordResetCodeStore +import Wire.PasswordStore import Wire.Sem.Concurrency import Wire.Sem.Concurrency.Sequential import Wire.Sem.Metrics import Wire.Sem.Metrics.IO (ignoreMetrics) import Wire.Sem.Now hiding (get) +import Wire.SessionStore (SessionStore) import Wire.StoredUser import Wire.UserKeyStore import Wire.UserStore @@ -121,13 +128,17 @@ instance Arbitrary NotPendingStoredUser where type AllErrors = [ Error UserSubsystemError, - Error FederationError + Error FederationError, + Error AuthenticationSubsystemError ] -type MiniBackendEffects = - [ UserSubsystem, +type MiniBackendEffects = UserSubsystem ': MiniBackendLowerEffects + +type MiniBackendLowerEffects = + [ EmailSubsystem, GalleyAPIAccess, InvitationCodeStore, + PasswordStore, State (Map (TeamId, InvitationId) StoredInvitation), State (Map InvitationCode StoredInvitationInfo), ActivationCodeStore, @@ -140,6 +151,9 @@ type MiniBackendEffects = State (Map EmailKey UserId), IndexedUserStore, FederationConfigStore, + PasswordResetCodeStore, + SessionStore, + HashPassword, DeleteQueue, Events, State [InternalNotification], @@ -148,6 +162,7 @@ type MiniBackendEffects = Now, Input UserSubsystemConfig, Input (Local ()), + Input (Maybe AllowlistEmailDomains), Metrics, FederationAPIAccess MiniFederationMonad, TinyLog, @@ -371,6 +386,7 @@ interpretNoFederationStackState :: interpretNoFederationStackState = interpretMaybeFederationStackState emptyFederationAPIAcesss interpretMaybeFederationStackState :: + forall r a. (Members AllErrors r) => InterpreterFor (FederationAPIAccess MiniFederationMonad) (Logger (Log.Msg -> Log.Msg) : Concurrency 'Unsafe : r) -> MiniBackend -> @@ -380,33 +396,44 @@ interpretMaybeFederationStackState :: Sem (MiniBackendEffects `Append` r) a -> Sem r (MiniBackend, a) interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMember galleyConfigs cfg = - sequentiallyPerformConcurrency - . noOpLogger - . maybeFederationAPIAccess - . ignoreMetrics - . runInputConst (toLocalUnsafe (Domain "localdomain") ()) - . runInputConst cfg - . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) - . evalState [] - . runState localBackend - . evalState [] - . miniEventInterpreter - . inMemoryDeleteQueueInterpreter - . runFederationConfigStoreInMemory - . inMemoryIndexedUserStoreInterpreter - . liftUserKeyStoreState - . inMemoryUserKeyStoreInterpreter - . liftUserStoreState - . inMemoryUserStoreInterpreter - . liftBlockListStoreState - . inMemoryBlockListStoreInterpreter - . liftActivationCodeStoreState - . inMemoryActivationCodeStoreInterpreter - . liftInvitationInfoStoreState - . liftInvitationCodeStoreState - . inMemoryInvitationCodeStoreInterpreter - . miniGalleyAPIAccess teamMember galleyConfigs - . runUserSubsystem cfg + let authSubsystemInterpreter :: InterpreterFor AuthenticationSubsystem (MiniBackendLowerEffects `Append` r) + authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter + + userSubsystemInterpreter :: InterpreterFor UserSubsystem (MiniBackendLowerEffects `Append` r) + userSubsystemInterpreter = runUserSubsystem cfg authSubsystemInterpreter + in sequentiallyPerformConcurrency + . noOpLogger + . maybeFederationAPIAccess + . ignoreMetrics + . runInputConst Nothing + . runInputConst (toLocalUnsafe (Domain "localdomain") ()) + . runInputConst cfg + . interpretNowConst (UTCTime (ModifiedJulianDay 0) 0) + . evalState [] + . runState localBackend + . evalState [] + . miniEventInterpreter + . inMemoryDeleteQueueInterpreter + . staticHashPasswordInterpreter + . runInMemorySessionStore + . runInMemoryPasswordResetCodeStore + . runFederationConfigStoreInMemory + . inMemoryIndexedUserStoreInterpreter + . liftUserKeyStoreState + . inMemoryUserKeyStoreInterpreter + . liftUserStoreState + . inMemoryUserStoreInterpreter + . liftBlockListStoreState + . inMemoryBlockListStoreInterpreter + . liftActivationCodeStoreState + . inMemoryActivationCodeStoreInterpreter + . liftInvitationInfoStoreState + . liftInvitationCodeStoreState + . runInMemoryPasswordStoreInterpreter + . inMemoryInvitationCodeStoreInterpreter + . miniGalleyAPIAccess teamMember galleyConfigs + . noopEmailSubsystemInterpreter + . userSubsystemInterpreter liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode StoredInvitationInfo) : r) a -> Sem r a liftInvitationInfoStoreState = interpret \case @@ -439,7 +466,7 @@ liftUserStoreState = interpret $ \case Put newUsers -> modify $ \b -> b {users = newUsers} runAllErrorsUnsafe :: forall a. (HasCallStack) => Sem AllErrors a -> a -runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe +runAllErrorsUnsafe = run . runErrorUnsafe . runErrorUnsafe . runErrorUnsafe emptyFederationAPIAcesss :: InterpreterFor (FederationAPIAccess MiniFederationMonad) r emptyFederationAPIAcesss = interpret $ \case diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 48d347e3ff2..7dfa852f119 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -23,3 +23,17 @@ emailSubsystemInterpreter = interpret \case getEmailsSentTo :: (Member (State (Map EmailAddress [SentMail])) r) => EmailAddress -> Sem r [SentMail] getEmailsSentTo email = gets $ Map.findWithDefault [] email + +noopEmailSubsystemInterpreter :: InterpreterFor EmailSubsystem r +noopEmailSubsystemInterpreter = interpret \case + SendPasswordResetMail {} -> pure () + SendVerificationMail {} -> pure () + SendCreateScimTokenVerificationMail {} -> pure () + SendLoginVerificationMail {} -> pure () + SendActivationMail {} -> pure () + SendEmailAddressUpdateMail {} -> pure () + SendNewClientEmail {} -> pure () + SendAccountDeletionEmail {} -> pure () + SendTeamActivationMail {} -> pure () + SendTeamDeletionVerificationMail {} -> pure () + SendUpgradePersonalToTeamConfirmationEmail {} -> pure () diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs index 25d6ab11d89..98bb17286bc 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordResetCodeStore.hs @@ -8,6 +8,12 @@ import Polysemy.State import Wire.API.User.Password import Wire.PasswordResetCodeStore +runInMemoryPasswordResetCodeStore :: forall r. InterpreterFor PasswordResetCodeStore r +runInMemoryPasswordResetCodeStore = + evalState (mempty :: Map PasswordResetKey (PRQueryData Identity)) + . inMemoryPasswordResetCodeStore + . raiseUnder + inMemoryPasswordResetCodeStore :: forall r. (Member (State (Map PasswordResetKey (PRQueryData Identity))) r) => diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs index be4f1a140d3..a90b9184eab 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/PasswordStore.hs @@ -8,6 +8,9 @@ import Polysemy.State import Wire.API.Password import Wire.PasswordStore +runInMemoryPasswordStoreInterpreter :: InterpreterFor PasswordStore r +runInMemoryPasswordStoreInterpreter = evalState (mempty :: Map UserId Password) . inMemoryPasswordStoreInterpreter . raiseUnder + inMemoryPasswordStoreInterpreter :: (Member (State (Map UserId Password)) r) => InterpreterFor PasswordStore r inMemoryPasswordStoreInterpreter = interpret $ \case UpsertHashedPassword uid password -> modify $ Map.insert uid password diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs index 43e2736ba2e..fcfc136d1ba 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/SessionStore.hs @@ -8,6 +8,12 @@ import Polysemy.State import Wire.API.User.Auth import Wire.SessionStore +runInMemorySessionStore :: InterpreterFor SessionStore r +runInMemorySessionStore = + evalState (mempty :: Map UserId [Cookie ()]) + . inMemorySessionStoreInterpreter + . raiseUnder + inMemorySessionStoreInterpreter :: (Member (State (Map UserId [Cookie ()])) r) => InterpreterFor SessionStore r inMemorySessionStoreInterpreter = interpret $ \case InsertCookie uid cookie _ttl -> modify $ Map.insertWith (<>) uid [cookie] diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index db318e5366b..a4c05c44b5c 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 -Wno-ambiguous-fields #-} + module Wire.MockInterpreters.UserStore where import Cassandra.Util @@ -65,6 +67,10 @@ inMemoryUserStoreInterpreter = interpret $ \case LookupStatus uid -> lookupStatusImpl uid IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid + UpdateUserTeam uid tid -> + modify $ + map + (\u -> if u.id == uid then u {teamId = Just tid} :: StoredUser else u) storedUserToIndexUser :: StoredUser -> IndexUser storedUserToIndexUser storedUser = diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index e89ea8cbcc5..fbefec47a3f 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -28,6 +28,7 @@ import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User hiding (DeleteUser) import Wire.API.UserEvent +import Wire.AuthenticationSubsystem.Error import Wire.InvitationCodeStore (StoredInvitation) import Wire.InvitationCodeStore qualified as InvitationStore import Wire.MiniBackend @@ -89,6 +90,7 @@ spec = describe "UserSubsystem.Interpreter" do result = run . runErrorUnsafe @UserSubsystemError + . runErrorUnsafe @AuthenticationSubsystemError . runError @FederationError . interpretFederationStack localBackend online Nothing config $ getUserProfiles @@ -580,6 +582,7 @@ spec = describe "UserSubsystem.Interpreter" do profileErr :: Either UserSubsystemError (Maybe UserProfile) = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do updateUserProfile lusr Nothing UpdateOriginWireClient update {name = Nothing, locale = Nothing} @@ -594,6 +597,7 @@ spec = describe "UserSubsystem.Interpreter" do profileErr :: Either UserSubsystemError (Maybe UserProfile) = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do updateUserProfile lusr Nothing UpdateOriginWireClient def {name = Just name} @@ -608,6 +612,7 @@ spec = describe "UserSubsystem.Interpreter" do profileErr :: Either UserSubsystemError (Maybe UserProfile) = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do updateUserProfile lusr Nothing UpdateOriginWireClient def {locale = Just locale} @@ -623,6 +628,7 @@ spec = describe "UserSubsystem.Interpreter" do profileErr :: Either UserSubsystemError (Maybe UserProfile) = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend @@ -685,6 +691,7 @@ spec = describe "UserSubsystem.Interpreter" do let res :: Either UserSubsystemError () res = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do updateHandle (toLocalUnsafe domain alice.id) Nothing UpdateOriginWireClient (fromHandle newHandle) @@ -698,6 +705,7 @@ spec = describe "UserSubsystem.Interpreter" do not (isBlacklistedHandle (fromJust (parseHandle newHandle))) ==> let res :: Either UserSubsystemError () = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do updateHandle (toLocalUnsafe domain alice.id) Nothing UpdateOriginScim newHandle @@ -720,6 +728,7 @@ spec = describe "UserSubsystem.Interpreter" do (isJust storedUser.identity && not (isBlacklistedHandle newHandle)) ==> let updateResult :: Either UserSubsystemError () = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack (def {users = [storedUser]}) Nothing def config do let luid = toLocalUnsafe dom storedUser.id @@ -733,6 +742,7 @@ spec = describe "UserSubsystem.Interpreter" do isJust storedUser.identity ==> let updateResult :: Either UserSubsystemError () = run . runErrorUnsafe + . runErrorUnsafe @AuthenticationSubsystemError . runError $ interpretNoFederationStack localBackend Nothing def config do let luid = toLocalUnsafe dom storedUser.id @@ -773,9 +783,7 @@ spec = describe "UserSubsystem.Interpreter" do userKeys = Map.singleton userKey storedUser.id } retrievedUser = - run - . runErrorUnsafe - . runErrorUnsafe @UserSubsystemError + runAllErrorsUnsafe . interpretNoFederationStack localBackend Nothing def config $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain userKey) in retrievedUser === Just (mkAccountFromStored localDomain config.defaultLocale storedUser) @@ -789,9 +797,7 @@ spec = describe "UserSubsystem.Interpreter" do } storedUser = storedUserNoEmail {email = Just email} retrievedUser = - run - . runErrorUnsafe - . runErrorUnsafe @UserSubsystemError + runAllErrorsUnsafe . interpretNoFederationStack localBackend Nothing def config $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain (mkEmailKey email)) in retrievedUser === Nothing @@ -804,9 +810,7 @@ spec = describe "UserSubsystem.Interpreter" do userKeys = Map.singleton userKey nonExistentUserId } retrievedUser = - run - . runErrorUnsafe - . runErrorUnsafe @UserSubsystemError + runAllErrorsUnsafe . interpretNoFederationStack localBackend Nothing def config $ getLocalUserAccountByUserKey (toLocalUnsafe localDomain userKey) in retrievedUser === Nothing diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 6f427928974..f30c81e9345 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -28,6 +28,7 @@ import Polysemy.Conc import Polysemy.Embed (runEmbedded) import Polysemy.Error (Error, errorToIOFinal, mapError, runError) import Polysemy.Input (Input, runInputConst, runInputSem) +import Polysemy.Internal.Kind import Polysemy.TinyLog (TinyLog) import Wire.API.Allowlists (AllowlistEmailDomains) import Wire.API.Federation.Client qualified @@ -98,8 +99,13 @@ import Wire.VerificationCodeSubsystem.Interpreter type BrigCanonicalEffects = '[ AuthenticationSubsystem, - UserSubsystem, - EmailSubsystem, + UserSubsystem + ] + `Append` BrigLowerLevelEffects + +-- | These effects have interpreters which don't depend on each other +type BrigLowerLevelEffects = + '[ EmailSubsystem, VerificationCodeSubsystem, PropertySubsystem, DeleteQueue, @@ -163,7 +169,8 @@ runBrigToIO e (AppT ma) = do UserSubsystemConfig { emailVisibilityConfig = e.settings.emailVisibility, defaultLocale = e.settings ^. to Opt.setDefaultUserLocale, - searchSameTeamOnly = fromMaybe False e.settings.searchSameTeamOnly + searchSameTeamOnly = fromMaybe False e.settings.searchSameTeamOnly, + maxTeamSize = e.settings.maxTeamSize } federationApiAccessConfig = FederationAPIAccessConfig @@ -193,6 +200,13 @@ runBrigToIO e (AppT ma) = do indexName = additionalIndexName } } + + -- These interpreters depend on each other, we use let recursion to solve that. + userSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor UserSubsystem r + userSubsystemInterpreter = runUserSubsystem userSubsystemConfig authSubsystemInterpreter + + authSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor AuthenticationSubsystem r + authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency @@ -250,8 +264,8 @@ runBrigToIO e (AppT ma) = do . interpretPropertySubsystem propertySubsystemConfig . interpretVerificationCodeSubsystem . emailSubsystemInterpreter e.userTemplates e.templateBranding - . runUserSubsystem userSubsystemConfig - . interpretAuthenticationSubsystem + . userSubsystemInterpreter + . authSubsystemInterpreter ) ) $ runReaderT ma e From 6b9f6ef8b07c351404b2244d77f32632983179af Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 24 Sep 2024 13:31:18 +0200 Subject: [PATCH 07/40] Minor variable rename --- .../src/Wire/UserSubsystem/Interpreter.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e554fd9980f..f3d4b29cbec 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -930,16 +930,14 @@ acceptTeamInvitationImpl :: InvitationCode -> Sem r () acceptTeamInvitationImpl luid pw code = do - (mek, mTid) <- do - mSelfProfile <- getSelfProfileImpl luid - let mek = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) - mTid = mSelfProfile >>= userTeam . selfUser - pure (mek, mTid) + mSelfProfile <- getSelfProfileImpl luid + let mEmailKey = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) + mTid = mSelfProfile >>= userTeam . selfUser -- TODO: This exists to make the warnings go away, this is not supposed to be -- in final code. We have to implement checkPassword in terms of Auth subsystem. - forM_ mek $ createPasswordResetCode + forM_ mEmailKey $ createPasswordResetCode checkPassword - (inv :: StoredInvitation, tid) <- (error "todo findTeamInvitation") mek code + (inv :: StoredInvitation, tid) <- (error "todo findTeamInvitation") mEmailKey code let minvmeta = (,inv.createdAt) <$> inv.createdBy uid = tUnqualified luid for_ mTid $ \userTid -> From 4c9d9c4a714a78dd25955c73cbf04998fd531b3d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 24 Sep 2024 17:21:14 +0200 Subject: [PATCH 08/40] WIP: Introduce TeamInvitationSubsystem --- libs/types-common/src/Util/Logging.hs | 5 + libs/types-common/types-common.cabal | 1 + .../src/Wire/EmailSubsystem.hs | 3 + .../src/Wire/EmailSubsystem/Interpreter.hs | 88 +++++- .../src/Wire/EmailSubsystem/Template.hs | 57 ++-- .../src/Wire/TeamInvitationSubsystem.hs | 16 ++ .../TeamInvitationSubsystem/Interpreter.hs | 270 ++++++++++++++++++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 22 -- libs/wire-subsystems/wire-subsystems.cabal | 2 + services/brig/src/Brig/Team/Email.hs | 56 ---- 10 files changed, 407 insertions(+), 113 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs create mode 100644 libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs diff --git a/libs/types-common/src/Util/Logging.hs b/libs/types-common/src/Util/Logging.hs index 318785c7578..8a242a3d664 100644 --- a/libs/types-common/src/Util/Logging.hs +++ b/libs/types-common/src/Util/Logging.hs @@ -25,6 +25,7 @@ import Data.Text.Encoding (encodeUtf8) import Imports import System.Logger.Class qualified as Log import System.Logger.Message (Msg) +import Text.Email.Parser sha256String :: Text -> Text sha256String t = @@ -48,3 +49,7 @@ logUser uid = Log.field "user" (T.pack . show $ uid) logTeam :: TeamId -> (Msg -> Msg) logTeam tid = Log.field "team" (T.pack . show $ tid) + +logEmail :: EmailAddress -> (Msg -> Msg) +logEmail email = + Log.field "email_sha256" (sha256String . T.pack . show $ email) diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 53ac138e7f2..528890fe064 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -109,6 +109,7 @@ library , cryptohash-sha1 >=0.11.7.2 , crypton >=0.26 , currency-codes >=3.0.0.1 + , email-validate , generic-random >=1.4.0.0 , hashable >=1.2 , http-api-data diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index e4090103799..9d4ef5bd22c 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -3,6 +3,7 @@ module Wire.EmailSubsystem where import Data.Code qualified as Code +import Data.Id import Imports import Polysemy import Wire.API.Locale @@ -22,5 +23,7 @@ data EmailSubsystem m a where SendTeamActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m () SendTeamDeletionVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m () SendUpgradePersonalToTeamConfirmationEmail :: EmailAddress -> Name -> Text -> Locale -> EmailSubsystem m () + SendTeamInvitationMail :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text + SendTeamInvitationMailPersonalUser :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text makeSem ''EmailSubsystem diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs index a152b166af1..a78e26f3754 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs @@ -7,6 +7,7 @@ module Wire.EmailSubsystem.Interpreter where import Data.Code qualified as Code +import Data.Id import Data.Json.Util import Data.Range (fromRange) import Data.Text qualified as Text @@ -24,19 +25,21 @@ import Wire.EmailSending (EmailSending, sendMail) import Wire.EmailSubsystem import Wire.EmailSubsystem.Template -emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r -emailSubsystemInterpreter tpls branding = interpret \case - SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl tpls branding email key code mLocale - SendVerificationMail email key code mLocale -> sendVerificationMailImpl tpls branding email key code mLocale - SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl tpls branding email code mLocale - SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl tpls branding email code mLocale - SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl tpls branding email code mLocale - SendActivationMail email name key code mLocale -> sendActivationMailImpl tpls branding email name key code mLocale - SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl tpls branding email name key code mLocale - SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl tpls branding email name key code mLocale teamName - SendNewClientEmail email name client locale -> sendNewClientEmailImpl tpls branding email name client locale - SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl tpls branding email name key code locale - SendUpgradePersonalToTeamConfirmationEmail email name teamName locale -> sendUpgradePersonalToTeamConfirmationEmailImpl tpls branding email name teamName locale +emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> Localised TeamTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r +emailSubsystemInterpreter userTpls teamTpls branding = interpret \case + SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl userTpls branding email key code mLocale + SendVerificationMail email key code mLocale -> sendVerificationMailImpl userTpls branding email key code mLocale + SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl userTpls branding email code mLocale + SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl userTpls branding email code mLocale + SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl userTpls branding email code mLocale + SendActivationMail email name key code mLocale -> sendActivationMailImpl userTpls branding email name key code mLocale + SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl userTpls branding email name key code mLocale + SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl userTpls branding email name key code mLocale teamName + SendNewClientEmail email name client locale -> sendNewClientEmailImpl userTpls branding email name client locale + SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl userTpls branding email name key code locale + SendUpgradePersonalToTeamConfirmationEmail email name teamName locale -> sendUpgradePersonalToTeamConfirmationEmailImpl userTpls branding email name teamName locale + SendTeamInvitationMail email tid from code loc -> sendTeamInvitationMailImpl teamTpls branding email tid from code loc + SendTeamInvitationMailPersonalUser email tid from code loc -> sendTeamInvitationMailPersonalUserImpl teamTpls branding email tid from code loc ------------------------------------------------------------------------------- -- Verification Email for @@ -432,6 +435,65 @@ renderUpgradePersonalToTeamConfirmationEmail email name _teamName UpgradePersona replace1 "name" = fromName name replace1 x = x +------------------------------------------------------------------------------- +-- Invitation Email + +sendTeamInvitationMailImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text +sendTeamInvitationMailImpl teamTemplates branding to tid from code loc = do + let tpl = invitationEmail . snd $ forLocale loc teamTemplates + mail = InvitationEmail to tid code from + (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding + sendMail renderedMail + pure renderedInvitaitonUrl + +sendTeamInvitationMailPersonalUserImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text +sendTeamInvitationMailPersonalUserImpl teamTemplates branding to tid from code loc = do + let tpl = existingUserInvitationEmail . snd $ forLocale loc teamTemplates + mail = InvitationEmail to tid code from + (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding + sendMail renderedMail + pure renderedInvitaitonUrl + +data InvitationEmail = InvitationEmail + { invTo :: !EmailAddress, + invTeamId :: !TeamId, + invInvCode :: !InvitationCode, + invInviter :: !EmailAddress + } + +renderInvitationEmail :: InvitationEmail -> InvitationEmailTemplate -> TemplateBranding -> (Mail, Text) +renderInvitationEmail InvitationEmail {..} InvitationEmailTemplate {..} branding = + ( (emptyMail from) + { mailTo = [to], + mailHeaders = + [ ("Subject", toStrict subj), + ("X-Zeta-Purpose", "TeamInvitation"), + ("X-Zeta-Code", Ascii.toText code) + ], + mailParts = [[plainPart txt, htmlPart html]] + }, + invitationUrl + ) + where + (InvitationCode code) = invInvCode + from = Address (Just invitationEmailSenderName) (fromEmail invitationEmailSender) + to = Address Nothing (fromEmail invTo) + txt = renderTextWithBranding invitationEmailBodyText replace branding + html = renderHtmlWithBranding invitationEmailBodyHtml replace branding + subj = renderTextWithBranding invitationEmailSubject replace branding + invitationUrl = renderInvitationUrl invitationEmailUrl invTeamId invInvCode branding + replace "url" = invitationUrl + replace "inviter" = fromEmail invInviter + replace x = x + +renderInvitationUrl :: Template -> TeamId -> InvitationCode -> TemplateBranding -> Text +renderInvitationUrl t tid (InvitationCode c) branding = + toStrict $ renderTextWithBranding t replace branding + where + replace "team" = idToText tid + replace "code" = Ascii.toText c + replace x = x + ------------------------------------------------------------------------------- -- MIME Conversions diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs index f1c7a996f56..ea0339f74ca 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs @@ -18,31 +18,10 @@ -- with this program. If not, see . module Wire.EmailSubsystem.Template - ( Localised (..), - TemplateBranding, - forLocale, - - -- * templates - UserTemplates (..), - ActivationSmsTemplate (..), - VerificationEmailTemplate (..), - ActivationEmailTemplate (..), - TeamActivationEmailTemplate (..), - ActivationCallTemplate (..), - PasswordResetSmsTemplate (..), - PasswordResetEmailTemplate (..), - LoginSmsTemplate (..), - LoginCallTemplate (..), - DeletionSmsTemplate (..), - DeletionEmailTemplate (..), - UpgradePersonalToTeamEmailTemplate (..), - NewClientEmailTemplate (..), - SecondFactorVerificationEmailTemplate (..), + ( module Wire.EmailSubsystem.Template, -- * Re-exports Template, - renderTextWithBranding, - renderHtmlWithBranding, ) where @@ -212,3 +191,37 @@ data SecondFactorVerificationEmailTemplate = SecondFactorVerificationEmailTempla sndFactorVerificationEmailSender :: EmailAddress, sndFactorVerificationEmailSenderName :: Text } + +data InvitationEmailTemplate = InvitationEmailTemplate + { invitationEmailUrl :: !Template, + invitationEmailSubject :: !Template, + invitationEmailBodyText :: !Template, + invitationEmailBodyHtml :: !Template, + invitationEmailSender :: !EmailAddress, + invitationEmailSenderName :: !Text + } + +data CreatorWelcomeEmailTemplate = CreatorWelcomeEmailTemplate + { creatorWelcomeEmailUrl :: !Text, + creatorWelcomeEmailSubject :: !Template, + creatorWelcomeEmailBodyText :: !Template, + creatorWelcomeEmailBodyHtml :: !Template, + creatorWelcomeEmailSender :: !EmailAddress, + creatorWelcomeEmailSenderName :: !Text + } + +data MemberWelcomeEmailTemplate = MemberWelcomeEmailTemplate + { memberWelcomeEmailUrl :: !Text, + memberWelcomeEmailSubject :: !Template, + memberWelcomeEmailBodyText :: !Template, + memberWelcomeEmailBodyHtml :: !Template, + memberWelcomeEmailSender :: !EmailAddress, + memberWelcomeEmailSenderName :: !Text + } + +data TeamTemplates = TeamTemplates + { invitationEmail :: !InvitationEmailTemplate, + existingUserInvitationEmail :: !InvitationEmailTemplate, + creatorWelcomeEmail :: !CreatorWelcomeEmailTemplate, + memberWelcomeEmail :: !MemberWelcomeEmailTemplate + } diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs new file mode 100644 index 00000000000..d20582fdca9 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs @@ -0,0 +1,16 @@ +module Wire.TeamInvitationSubsystem where + +import Data.Id +import Data.Qualified +import Wire.API.Team.Invitation +import Wire.API.User (InvitationCode) +import Wire.API.User.EmailAddress + +data TeamInvitationSubsystem m a where + InviteUser :: Local UserId -> TeamId -> InvitationRequest -> TeamInvitationSubsystem m (Invitation, InvitationLocation) + AcceptInvitation :: UserId -> InvitationId -> InvitationCode -> TeamInvitationSubsystem m () + RevokeInvitation :: TeamId -> InvitationId -> TeamInvitationSubsystem m () + GetInvitationByCode :: InvitationCode -> TeamInvitationSubsystem m Invitation + GetInvitationByEmail :: EmailAddress -> TeamInvitationSubsystem m Invitation + CheckInvitationsByEmail :: EmailAddress -> TeamInvitationSubsystem m HeadInvitationByEmailResult + DeleteAllInvitationsFor :: TeamId -> TeamInvitationSubsystem m () diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs new file mode 100644 index 00000000000..30a220bd522 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -0,0 +1,270 @@ +module Wire.TeamInvitationSubsystem.Interpreter where + +import Control.Arrow ((&&&)) +import Control.Error (MaybeT (..)) +import Data.ByteString.Conversion (toByteString') +import Data.Id +import Data.Qualified +import Data.Set qualified as Set +import Data.Text.Ascii qualified as AsciiText +import Data.Text.Encoding qualified as Text +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog +import System.Logger.Message as Log +import URI.ByteString +import Util.Logging +import Wire.API.Team.Invitation +import Wire.API.Team.Member +import Wire.API.Team.Member qualified as Teams +import Wire.API.Team.Permission +import Wire.API.Team.Role +import Wire.API.User +import Wire.EmailSending (EmailSending) +import Wire.EmailSubsystem +import Wire.GalleyAPIAccess hiding (AddTeamMember) +import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation) +import Wire.InvitationCodeStore qualified as Store +import Wire.Sem.Logger qualified as Log +import Wire.Sem.Random (Random) +import Wire.Sem.Random qualified as Random +import Wire.TeamInvitationSubsystem +import Wire.UserKeyStore +import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey, getSelfProfile, isBlocked) + +data TeamInvitationError + = TeamInvitationNoEmail + | TeamInvitationInsufficientTeamPermissions + | TooManyTeamInvitations + | TeamInvitationBlacklistedEmail + | TeamInvitationEmailTaken + +runTeamInvitationSubsystem :: (Member (Error TeamInvitationError) r) => InterpreterFor TeamInvitationSubsystem r +runTeamInvitationSubsystem = interpret $ \case + InviteUser luid tid request -> inviteUserImpl luid tid request + AcceptInvitation uid invitationId invitationCode -> acceptInvitationImpl uid invitationId invitationCode + RevokeInvitation tid invitationId -> revokeInvitationImpl tid invitationId + GetInvitationByCode invitationCode -> getInvitationByCodeImpl invitationCode + GetInvitationByEmail email -> getInvitationByEmailImpl email + CheckInvitationsByEmail email -> checkInvitationsByEmailImpl email + DeleteAllInvitationsFor tid -> deleteAllInvitationsForImpl tid + +inviteUserImpl :: (Member (Error TeamInvitationError) r, Member GalleyAPIAccess r, Member UserSubsystem r, Member TinyLog r) => Local UserId -> TeamId -> InvitationRequest -> Sem r (Invitation, InvitationLocation) +inviteUserImpl luid tid request = do + let inviteeRole = fromMaybe defaultRole request.role + + let inviteePerms = Teams.rolePermissions inviteeRole + ensurePermissionToAddUser (tUnqualified luid) tid inviteePerms + + inviterEmail <- + note TeamInvitationNoEmail =<< runMaybeT do + self <- MaybeT $ getSelfProfile luid + MaybeT . pure . userEmail $ selfUser self + + let context = + logFunction "Brig.Team.API.createInvitation" + . logTeam tid + . logEmail request.inviteeEmail + + (id &&& loc) . fst + <$> logInvitationRequest + context + (createInvitation' tid Nothing inviteeRole (Just <$> luid) inviterEmail request) + where + loc :: Invitation -> InvitationLocation + loc inv = + InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId + +createInvitation' :: + ( Member GalleyAPIAccess r, + Member UserSubsystem r, + Member UserKeyStore r, + Member InvitationCodeStore r, + Member EmailSending r, + Member TinyLog r, + Member (Error TeamInvitationError) r, + Member Random r + ) => + TeamId -> + Maybe InvitationId -> + Role -> + Local (Maybe UserId) -> + EmailAddress -> + InvitationRequest -> + Sem r (Invitation, InvitationCode) +createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRequest = do + let email = invRequest.inviteeEmail + let uke = qualifyAs mbInviterUid $ mkEmailKey email + blacklistedEm <- isBlocked email + when blacklistedEm $ + throw TeamInvitationBlacklistedEmail + + mEmailOwner <- getLocalUserAccountByUserKey uke + isPersonalUserMigration <- case mEmailOwner of + Nothing -> pure False + Just account -> + if (account.accountStatus == Active && isNothing account.accountUser.userTeam) + then pure True + else throw TeamInvitationEmailTaken + + maxSize <- asks (.settings.maxTeamSize) + pending <- Store.countInvitations tid + when (fromIntegral pending >= maxSize) $ + throw TooManyTeamInvitations + + showInvitationUrl <- GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + + do + iid <- maybe (Id <$> Random.uuid) pure mExpectedInvId + now <- liftIO =<< asks (.currentTime) + timeout <- asks (.settings.teamInvitationTimeout) + code <- mkInvitationCode + newInv <- + let insertInv = + Store.MkInsertInvitation + { invitationId = iid, + teamId = tid, + role = inviteeRole, + createdAt = now, + createdBy = tUnqualified mbInviterUid, + inviteeEmail = email, + inviteeName = invRequest.inviteeName, + code = code + -- mUrl = mUrl + } + in Store.insertInvitation insertInv timeout + + let sendOp = + if isPersonalUserMigration + then sendTeamInvitationMailPersonalUser + else sendTeamInvitationMail + + invitationUrl <- sendOp email tid inviterEmail code invRequest.locale + inv <- toInvitation invitationUrl showInvitationUrl newInv + pure (inv, code) + +mkInvitationCode :: (Member Random r) => Sem r InvitationCode +mkInvitationCode = InvitationCode . AsciiText.encodeBase64Url <$> Random.bytes 24 + +isPersonalUser :: (Member UserSubsystem r) => Local EmailKey -> Sem r Bool +isPersonalUser uke = do + mAccount <- getLocalUserAccountByUserKey uke + pure $ case mAccount of + -- this can e.g. happen if the key is claimed but the account is not yet created + Nothing -> False + Just account -> + account.accountStatus == Active + && isNothing account.accountUser.userTeam + +-- | 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) => + Text -> + ShowOrHideInvitationUrl -> + StoredInvitation -> + Sem r Invitation +toInvitation urlText showUrl storedInv = do + url <- + case showUrl of + HideInvitationUrl -> pure Nothing + ShowInvitationUrl -> parseHttpsUrl urlText + 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 + } + where + parseHttpsUrl :: Text -> Sem r (Maybe (URIRef Absolute)) + parseHttpsUrl url = + either (\e -> Nothing <$ logError url e) (pure . Just) $ + parseURI laxURIParserOptions (Text.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) + +logInvitationRequest :: (Member TinyLog r) => (Msg -> Msg) -> Sem (Error TeamInvitationError : r) (Invitation, InvitationCode) -> Sem r (Invitation, InvitationCode) +logInvitationRequest context action = + runError action >>= \case + Left e -> do + Log.warn $ + msg @String ("Failed to create invitation: " <> show err) + . context + throw e + Right res@(_, code) -> do + Log.info $ + msg @ByteString "Successfully created invitation" + . context + . logInvitationCode code + pure res + +-- flip mapExceptT action \action' -> do +-- eith <- action' +-- case eith of +-- Left err' -> do +-- liftSem $ +-- Log.warn $ +-- context +-- . Log.msg @Text +-- ( "Failed to create invitation, label: " +-- <> (LT.toStrict . errorLabel) err' +-- ) +-- pure (Left err') +-- Right result@(_, code) -> liftSem do +-- Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" +-- pure (Right result) + +acceptInvitationImpl :: UserId -> InvitationId -> InvitationCode -> Sem r () +acceptInvitationImpl = undefined + +revokeInvitationImpl :: TeamId -> InvitationId -> Sem r () +revokeInvitationImpl = undefined + +getInvitationByCodeImpl :: InvitationCode -> Sem r Invitation +getInvitationByCodeImpl = undefined + +getInvitationByEmailImpl :: EmailAddress -> Sem r Invitation +getInvitationByEmailImpl = undefined + +checkInvitationsByEmailImpl :: EmailAddress -> Sem r HeadInvitationByEmailResult +checkInvitationsByEmailImpl = undefined + +deleteAllInvitationsForImpl :: TeamId -> Sem r () +deleteAllInvitationsForImpl = undefined + +-- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). +-- +-- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. +ensurePermissionToAddUser :: + ( Member GalleyAPIAccess r, + Member (Error TeamInvitationError) r + ) => + UserId -> + TeamId -> + Permissions -> + Sem r () +ensurePermissionToAddUser u t inviteePerms = do + minviter <- GalleyAPIAccess.getTeamMember u t + unless (check minviter) $ + throw TeamInvitationInsufficientTeamPermissions + where + check :: Maybe TeamMember -> Bool + check (Just inviter) = + hasPermission inviter AddTeamMember + && all (mayGrantPermission inviter) (Set.toList (inviteePerms.self)) + check Nothing = False + +logInvitationCode :: InvitationCode -> (Msg -> Msg) +logInvitationCode code = field "invitation_code" (AsciiText.toText $ fromInvitationCode code) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index a08e22628a8..dc907022222 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -208,25 +208,3 @@ ensurePermissions u t perms = do check :: Maybe TeamMember -> Bool check (Just m) = all (hasPermission m) perms check Nothing = False - --- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). --- --- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: - ( Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r - ) => - UserId -> - TeamId -> - Permissions -> - Sem r () -ensurePermissionToAddUser u t inviteePerms = do - minviter <- GalleyAPIAccess.getTeamMember u t - unless (check minviter) $ - throw UserSubsystemInsufficientTeamPermissions - where - check :: Maybe TeamMember -> Bool - check (Just inviter) = - hasPermission inviter AddTeamMember - && all (mayGrantPermission inviter) (Set.toList (inviteePerms.self)) - check Nothing = False diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 294ead8c5de..89f8d952da3 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -119,6 +119,8 @@ library Wire.SessionStore Wire.SessionStore.Cassandra Wire.StoredUser + Wire.TeamInvitationSubsystem + Wire.TeamInvitationSubsystem.Interpreter Wire.UserKeyStore Wire.UserKeyStore.Cassandra Wire.UserSearch.Metrics diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 042843132e9..9796f26ce23 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -21,8 +21,6 @@ module Brig.Team.Email ( InvitationEmail (..), CreatorWelcomeEmail (..), MemberWelcomeEmail (..), - sendInvitationMail, - sendInvitationMailPersonalUser, sendMemberWelcomeMail, ) where @@ -39,20 +37,6 @@ import Wire.API.User import Wire.EmailSending import Wire.EmailSubsystem.Template (TemplateBranding, renderHtmlWithBranding, renderTextWithBranding) -sendInvitationMail :: (Member EmailSending r) => EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> (AppT r) () -sendInvitationMail to tid from code loc = do - tpl <- invitationEmail . snd <$> teamTemplatesWithLocale loc - branding <- asks (.templateBranding) - let mail = InvitationEmail to tid code from - liftSem $ sendMail $ renderInvitationEmail mail tpl branding - -sendInvitationMailPersonalUser :: (Member EmailSending r) => EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> (AppT r) () -sendInvitationMailPersonalUser to tid from code loc = do - tpl <- existingUserInvitationEmail . snd <$> teamTemplatesWithLocale loc - branding <- asks (.templateBranding) - let mail = InvitationEmail to tid code from - liftSem $ sendMail $ renderInvitationEmail mail tpl branding - sendMemberWelcomeMail :: (Member EmailSending r) => EmailAddress -> TeamId -> Text -> Maybe Locale -> (AppT r) () sendMemberWelcomeMail to tid teamName loc = do tpl <- memberWelcomeEmail . snd <$> teamTemplatesWithLocale loc @@ -60,46 +44,6 @@ sendMemberWelcomeMail to tid teamName loc = do let mail = MemberWelcomeEmail to tid teamName liftSem $ sendMail $ renderMemberWelcomeMail mail tpl branding -------------------------------------------------------------------------------- --- Invitation Email - -data InvitationEmail = InvitationEmail - { invTo :: !EmailAddress, - invTeamId :: !TeamId, - invInvCode :: !InvitationCode, - invInviter :: !EmailAddress - } - -renderInvitationEmail :: InvitationEmail -> InvitationEmailTemplate -> TemplateBranding -> Mail -renderInvitationEmail InvitationEmail {..} InvitationEmailTemplate {..} branding = - (emptyMail from) - { mailTo = [to], - mailHeaders = - [ ("Subject", toStrict subj), - ("X-Zeta-Purpose", "TeamInvitation"), - ("X-Zeta-Code", Ascii.toText code) - ], - mailParts = [[plainPart txt, htmlPart html]] - } - where - (InvitationCode code) = invInvCode - from = Address (Just invitationEmailSenderName) (fromEmail invitationEmailSender) - to = Address Nothing (fromEmail invTo) - txt = renderTextWithBranding invitationEmailBodyText replace branding - html = renderHtmlWithBranding invitationEmailBodyHtml replace branding - subj = renderTextWithBranding invitationEmailSubject replace branding - replace "url" = renderInvitationUrl invitationEmailUrl invTeamId invInvCode branding - replace "inviter" = fromEmail invInviter - replace x = x - -renderInvitationUrl :: Template -> TeamId -> InvitationCode -> TemplateBranding -> Text -renderInvitationUrl t tid (InvitationCode c) branding = - toStrict $ renderTextWithBranding t replace branding - where - replace "team" = idToText tid - replace "code" = Ascii.toText c - replace x = x - ------------------------------------------------------------------------------- -- Creator Welcome Email From 8cc7807f7e37dae16288a81bc4a40b7be9f4d4da Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 07:50:07 +0000 Subject: [PATCH 09/40] make team invitation subsystem compile --- libs/types-common/src/Util/Timeout.hs | 4 + .../TeamInvitationSubsystem/Interpreter.hs | 86 ++++++++++++------- .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 - 3 files changed, 60 insertions(+), 32 deletions(-) diff --git a/libs/types-common/src/Util/Timeout.hs b/libs/types-common/src/Util/Timeout.hs index e09c358e88d..35dcde3a52f 100644 --- a/libs/types-common/src/Util/Timeout.hs +++ b/libs/types-common/src/Util/Timeout.hs @@ -9,12 +9,16 @@ import Data.Aeson.Types import Data.Scientific import Data.Time.Clock import Imports +import Test.QuickCheck (Arbitrary (arbitrary), choose) newtype Timeout = Timeout { timeoutDiff :: NominalDiffTime } deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) +instance Arbitrary Timeout where + arbitrary = Timeout . fromIntegral <$> choose (60 :: Int, 10 * 24 * 3600) + instance Read Timeout where readsPrec i s = case readsPrec i s of diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 30a220bd522..a006edffe03 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -11,40 +11,62 @@ import Data.Text.Encoding qualified as Text import Imports import Polysemy import Polysemy.Error -import Polysemy.Input +import Polysemy.Input (Input, input, runInputConst) import Polysemy.TinyLog import System.Logger.Message as Log import URI.ByteString import Util.Logging +import Util.Timeout (Timeout (..)) import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Member qualified as Teams import Wire.API.Team.Permission import Wire.API.Team.Role import Wire.API.User -import Wire.EmailSending (EmailSending) +import Wire.Arbitrary import Wire.EmailSubsystem import Wire.GalleyAPIAccess hiding (AddTeamMember) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation) import Wire.InvitationCodeStore qualified as Store import Wire.Sem.Logger qualified as Log +import Wire.Sem.Now (Now) +import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.Sem.Random qualified as Random import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey, getSelfProfile, isBlocked) +data TeamInvitationSubsystemConfig = TeamInvitationSubsystemConfig + { maxTeamSize :: Word32, + teamInvitationTimeout :: Timeout + } + deriving (Show, Generic) + deriving (Arbitrary) via GenericUniform TeamInvitationSubsystemConfig + data TeamInvitationError = TeamInvitationNoEmail | TeamInvitationInsufficientTeamPermissions | TooManyTeamInvitations | TeamInvitationBlacklistedEmail | TeamInvitationEmailTaken + deriving (Show) -runTeamInvitationSubsystem :: (Member (Error TeamInvitationError) r) => InterpreterFor TeamInvitationSubsystem r -runTeamInvitationSubsystem = interpret $ \case - InviteUser luid tid request -> inviteUserImpl luid tid request +runTeamInvitationSubsystem :: + ( Member (Error TeamInvitationError) r, + Member TinyLog r, + Member GalleyAPIAccess r, + Member UserSubsystem r, + Member Random r, + Member InvitationCodeStore r, + Member Now r, + Member EmailSubsystem r + ) => + TeamInvitationSubsystemConfig -> + InterpreterFor TeamInvitationSubsystem r +runTeamInvitationSubsystem cfg = interpret $ \case + InviteUser luid tid request -> runInputConst cfg $ inviteUserImpl luid tid request AcceptInvitation uid invitationId invitationCode -> acceptInvitationImpl uid invitationId invitationCode RevokeInvitation tid invitationId -> revokeInvitationImpl tid invitationId GetInvitationByCode invitationCode -> getInvitationByCodeImpl invitationCode @@ -52,7 +74,21 @@ runTeamInvitationSubsystem = interpret $ \case CheckInvitationsByEmail email -> checkInvitationsByEmailImpl email DeleteAllInvitationsFor tid -> deleteAllInvitationsForImpl tid -inviteUserImpl :: (Member (Error TeamInvitationError) r, Member GalleyAPIAccess r, Member UserSubsystem r, Member TinyLog r) => Local UserId -> TeamId -> InvitationRequest -> Sem r (Invitation, InvitationLocation) +inviteUserImpl :: + ( Member (Error TeamInvitationError) r, + Member GalleyAPIAccess r, + Member UserSubsystem r, + Member TinyLog r, + Member Random r, + Member InvitationCodeStore r, + Member (Input TeamInvitationSubsystemConfig) r, + Member Now r, + Member EmailSubsystem r + ) => + Local UserId -> + TeamId -> + InvitationRequest -> + Sem r (Invitation, InvitationLocation) inviteUserImpl luid tid request = do let inviteeRole = fromMaybe defaultRole request.role @@ -81,12 +117,13 @@ inviteUserImpl luid tid request = do createInvitation' :: ( Member GalleyAPIAccess r, Member UserSubsystem r, - Member UserKeyStore r, Member InvitationCodeStore r, - Member EmailSending r, Member TinyLog r, Member (Error TeamInvitationError) r, - Member Random r + Member Random r, + Member (Input TeamInvitationSubsystemConfig) r, + Member Now r, + Member EmailSubsystem r ) => TeamId -> Maybe InvitationId -> @@ -110,7 +147,7 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe then pure True else throw TeamInvitationEmailTaken - maxSize <- asks (.settings.maxTeamSize) + maxSize <- maxTeamSize <$> input pending <- Store.countInvitations tid when (fromIntegral pending >= maxSize) $ throw TooManyTeamInvitations @@ -119,8 +156,8 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe do iid <- maybe (Id <$> Random.uuid) pure mExpectedInvId - now <- liftIO =<< asks (.currentTime) - timeout <- asks (.settings.teamInvitationTimeout) + now <- Now.get + timeout <- teamInvitationTimeout <$> input code <- mkInvitationCode newInv <- let insertInv = @@ -162,6 +199,7 @@ isPersonalUser uke = do -- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. toInvitation :: + forall r. (Member TinyLog r) => Text -> ShowOrHideInvitationUrl -> @@ -195,12 +233,16 @@ toInvitation urlText showUrl storedInv = do . Log.field "url" url . Log.field "error" (show e) -logInvitationRequest :: (Member TinyLog r) => (Msg -> Msg) -> Sem (Error TeamInvitationError : r) (Invitation, InvitationCode) -> Sem r (Invitation, InvitationCode) +logInvitationRequest :: + (Member TinyLog r, Member (Error TeamInvitationError) r) => + (Msg -> Msg) -> + Sem (Error TeamInvitationError : r) (Invitation, InvitationCode) -> + Sem r (Invitation, InvitationCode) logInvitationRequest context action = runError action >>= \case Left e -> do Log.warn $ - msg @String ("Failed to create invitation: " <> show err) + msg @String ("Failed to create invitation: " <> show e) . context throw e Right res@(_, code) -> do @@ -210,22 +252,6 @@ logInvitationRequest context action = . logInvitationCode code pure res --- flip mapExceptT action \action' -> do --- eith <- action' --- case eith of --- Left err' -> do --- liftSem $ --- Log.warn $ --- context --- . Log.msg @Text --- ( "Failed to create invitation, label: " --- <> (LT.toStrict . errorLabel) err' --- ) --- pure (Left err') --- Right result@(_, code) -> liftSem do --- Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" --- pure (Right result) - acceptInvitationImpl :: UserId -> InvitationId -> InvitationCode -> Sem r () acceptInvitationImpl = undefined diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index dc907022222..59b94f92a73 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -15,7 +15,6 @@ import Data.Id import Data.Misc import Data.Qualified import Data.Range -import Data.Set qualified as Set import Imports import Polysemy import Polysemy.Error @@ -23,7 +22,6 @@ import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) import Wire.API.Team.Feature import Wire.API.Team.Member (IsPerm (..), TeamMember) -import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.Search import Wire.Arbitrary From 18277376dae5ad8517aea42c148a3a02ec357e58 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 09:59:44 +0200 Subject: [PATCH 10/40] get wire-subsystems to compile. --- .../test/unit/Wire/MockInterpreters/EmailSubsystem.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 7dfa852f119..636027753cd 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -37,3 +37,5 @@ noopEmailSubsystemInterpreter = interpret \case SendTeamActivationMail {} -> pure () SendTeamDeletionVerificationMail {} -> pure () SendUpgradePersonalToTeamConfirmationEmail {} -> pure () + SendTeamInvitationMail {} -> pure "" + SendTeamInvitationMailPersonalUser {} -> pure "" From 29222e2e44ddc19ea4656ec9018f9069a9e246a4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 10:54:57 +0200 Subject: [PATCH 11/40] Fix compiler errors. --- libs/wire-api/src/Wire/API/Error/Brig.hs | 3 + .../src/Wire/API/Routes/Public/Brig.hs | 2 +- .../src/Wire/TeamInvitationSubsystem.hs | 5 + .../TeamInvitationSubsystem/Interpreter.hs | 14 +- services/brig/src/Brig/API/Internal.hs | 4 +- services/brig/src/Brig/API/Public.hs | 6 +- .../brig/src/Brig/CanonicalInterpreter.hs | 9 +- services/brig/src/Brig/Team/API.hs | 178 ++---------------- services/brig/src/Brig/Team/Email.hs | 4 +- services/brig/src/Brig/Team/Template.hs | 36 +--- 10 files changed, 50 insertions(+), 211 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index 7846f5c51f5..c83bebbfd93 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -63,6 +63,7 @@ data BrigError | AccountEphemeral | AccountPending | UserKeyExists + | EmailExists | NameManagedByScim | HandleManagedByScim | LocaleManagedByScim @@ -238,6 +239,8 @@ type instance MapError 'AccountPending = 'StaticError 403 "pending-activation" " type instance MapError 'UserKeyExists = 'StaticError 409 "key-exists" "The given e-mail address is in use." +type instance MapError 'EmailExists = 'StaticError 409 "email-exists" "The given e-mail address is in use." + type instance MapError 'NameManagedByScim = 'StaticError 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM, or E2EId is enabled" type instance MapError 'HandleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating handle is not allowed, because it is managed by SCIM, or E2EId is enabled" 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 6e457fefa6d..53ebe332541 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1574,7 +1574,7 @@ type TeamsAPI = :> CanThrow 'TooManyTeamInvitations :> CanThrow 'InsufficientTeamPermissions :> CanThrow 'InvalidInvitationCode - :> ZUser + :> ZLocalUser :> "teams" :> Capture "tid" TeamId :> "invitations" diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs index d20582fdca9..5b66b960df7 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + module Wire.TeamInvitationSubsystem where import Data.Id import Data.Qualified +import Polysemy import Wire.API.Team.Invitation import Wire.API.User (InvitationCode) import Wire.API.User.EmailAddress @@ -14,3 +17,5 @@ data TeamInvitationSubsystem m a where GetInvitationByEmail :: EmailAddress -> TeamInvitationSubsystem m Invitation CheckInvitationsByEmail :: EmailAddress -> TeamInvitationSubsystem m HeadInvitationByEmailResult DeleteAllInvitationsFor :: TeamId -> TeamInvitationSubsystem m () + +makeSem ''TeamInvitationSubsystem diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index a006edffe03..66310d42982 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -17,6 +17,8 @@ import System.Logger.Message as Log import URI.ByteString import Util.Logging import Util.Timeout (Timeout (..)) +import Wire.API.Error +import Wire.API.Error.Brig qualified as E import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Member qualified as Teams @@ -25,6 +27,7 @@ import Wire.API.Team.Role import Wire.API.User import Wire.Arbitrary import Wire.EmailSubsystem +import Wire.Error import Wire.GalleyAPIAccess hiding (AddTeamMember) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation) @@ -45,7 +48,7 @@ data TeamInvitationSubsystemConfig = TeamInvitationSubsystemConfig deriving (Show, Generic) deriving (Arbitrary) via GenericUniform TeamInvitationSubsystemConfig -data TeamInvitationError +data TeamInvitationError -- TODO: rename to TeamInvitationSubsystemError, move to Wire.TeamInvitationSubsystem.Error = TeamInvitationNoEmail | TeamInvitationInsufficientTeamPermissions | TooManyTeamInvitations @@ -53,6 +56,15 @@ data TeamInvitationError | TeamInvitationEmailTaken deriving (Show) +teamInvitationErrorToHttpError :: TeamInvitationError -> HttpError +teamInvitationErrorToHttpError = + StdError . \case + TeamInvitationNoEmail -> errorToWai @E.NoEmail + TeamInvitationInsufficientTeamPermissions -> errorToWai @E.InsufficientTeamPermissions + TooManyTeamInvitations -> errorToWai @E.TooManyTeamInvitations + TeamInvitationBlacklistedEmail -> errorToWai @E.BlacklistedEmail + TeamInvitationEmailTaken -> errorToWai @E.EmailExists + runTeamInvitationSubsystem :: ( Member (Error TeamInvitationError) r, Member TinyLog r, diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 35248ac45ed..8f2bce2f5d3 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -109,6 +109,7 @@ import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PropertySubsystem import Wire.Rpc import Wire.Sem.Concurrency +import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserStore import Wire.UserSubsystem @@ -128,6 +129,7 @@ servantSitemap :: Member GalleyAPIAccess r, Member NotificationSubsystem r, Member UserSubsystem r, + Member TeamInvitationSubsystem r, Member UserStore r, Member InvitationCodeStore r, Member UserKeyStore r, @@ -241,7 +243,7 @@ teamsAPI :: Member (Concurrency 'Unsafe) r, Member TinyLog r, Member InvitationCodeStore r, - Member EmailSending r, + Member TeamInvitationSubsystem r, Member UserSubsystem r, Member Events r, Member (Input TeamTemplates) r, diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 44d923c5984..5fd58036136 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -50,7 +50,6 @@ import Brig.Options hiding (internalEvents) import Brig.Provider.API import Brig.Team.API qualified as Team import Brig.Team.Email qualified as Team -import Brig.Team.Template (TeamTemplates) import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra (UserAccount (UserAccount, accountUser)) import Brig.User.API.Handle qualified as Handle @@ -150,6 +149,7 @@ import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem +import Wire.EmailSubsystem.Template import Wire.Error import Wire.Events (Events) import Wire.FederationConfigStore (FederationConfigStore) @@ -164,6 +164,7 @@ import Wire.Sem.Concurrency import Wire.Sem.Jwk (Jwk) import Wire.Sem.Now (Now) import Wire.Sem.Paging.Cassandra +import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSearch.Types import Wire.UserStore (UserStore) @@ -271,7 +272,6 @@ servantSitemap :: Member (Error UserSubsystemError) r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (Input TeamTemplates) r, Member (UserPendingActivationStore p) r, Member AuthenticationSubsystem r, Member DeleteQueue r, @@ -293,7 +293,9 @@ servantSitemap :: Member TinyLog r, Member UserKeyStore r, Member UserStore r, + Member (Input TeamTemplates) r, Member UserSubsystem r, + Member TeamInvitationSubsystem r, Member VerificationCodeSubsystem r, Member (Concurrency 'Unsafe) r, Member BlockListStore r, diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index f30c81e9345..309b51c1e20 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -85,6 +85,8 @@ import Wire.Sem.Random import Wire.Sem.Random.IO import Wire.SessionStore import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) +import Wire.TeamInvitationSubsystem +import Wire.TeamInvitationSubsystem.Interpreter import Wire.UserKeyStore import Wire.UserKeyStore.Cassandra import Wire.UserStore @@ -99,6 +101,7 @@ import Wire.VerificationCodeSubsystem.Interpreter type BrigCanonicalEffects = '[ AuthenticationSubsystem, + TeamInvitationSubsystem, UserSubsystem ] `Append` BrigLowerLevelEffects @@ -111,6 +114,7 @@ type BrigLowerLevelEffects = DeleteQueue, Wire.Events.Events, Error UserSubsystemError, + Error TeamInvitationError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, Error VerificationCodeSubsystemError, @@ -207,6 +211,7 @@ runBrigToIO e (AppT ma) = do authSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor AuthenticationSubsystem r authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter + ( either throwM pure <=< ( runFinal . unsafelyPerformConcurrency @@ -258,13 +263,15 @@ runBrigToIO e (AppT ma) = do . mapError verificationCodeSubsystemErrorToHttpError . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError + . mapError teamInvitationErrorToHttpError . mapError userSubsystemErrorToHttpError . runEvents . runDeleteQueue e.internalEvents . interpretPropertySubsystem propertySubsystemConfig . interpretVerificationCodeSubsystem - . emailSubsystemInterpreter e.userTemplates e.templateBranding + . emailSubsystemInterpreter e.userTemplates undefined e.templateBranding . userSubsystemInterpreter + . runTeamInvitationSubsystem undefined -- TODO . authSubsystemInterpreter ) ) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index f8f2ed55637..2ad158bc88c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -28,28 +28,23 @@ where import Brig.API.Error import Brig.API.Handler -import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) +import Brig.API.User (createUserInviteViaScim) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App as App import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.Options -import Brig.Team.Email -import Brig.Team.Template import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize import Control.Lens (view, (^.)) import Control.Monad.Trans.Except (mapExceptT) -import Data.ByteString.Conversion (toByteString, toByteString') +import Data.ByteString.Conversion (toByteString) 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.Tuple.Extra import Imports hiding (head) import Network.Wai.Utilities hiding (Error, code, message) import Polysemy @@ -74,11 +69,8 @@ import Wire.API.Team.Member (teamMembers) import Wire.API.Team.Member qualified as Teams import Wire.API.Team.Permission (Perm (AddTeamMember)) import Wire.API.Team.Role -import Wire.API.Team.Role qualified as Public 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.Events (Events) @@ -86,33 +78,28 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) import Wire.InvitationCodeStore qualified as Store -import Wire.InvitationCodeStore.Cassandra qualified as Store (mkInvitationCode) import Wire.Sem.Concurrency +import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSubsystem import Wire.UserSubsystem.Error servantAPI :: ( Member GalleyAPIAccess r, - Member UserKeyStore r, + Member TeamInvitationSubsystem r, Member UserSubsystem r, Member Store.InvitationCodeStore r, - Member EmailSending r, - Member (Input (Local ())) r, Member TinyLog r, Member (Input TeamTemplates) r, Member (Error UserSubsystemError) r ) => ServerT TeamsAPI (Handler r) servantAPI = - Named @"send-team-invitation" createInvitation - :<|> Named @"get-team-invitations" - (\u t inv s -> lift . liftSem $ listInvitations u t inv s) - :<|> Named @"get-team-invitation" - (\u t inv -> lift . liftSem $ getInvitation u t inv) - :<|> Named @"delete-team-invitation" - (\u t inv -> lift . liftSem $ deleteInvitation u t inv) - :<|> Named @"get-team-invitation-info" getInvitationByCode + Named @"send-team-invitation" (\luid tid invreq -> lift . liftSem $ inviteUser luid tid invreq) + :<|> Named @"get-team-invitations" (\u t inv s -> lift . liftSem $ listInvitations u t inv s) + :<|> Named @"get-team-invitation" (\u t inv -> lift . liftSem $ getInvitation u t inv) + :<|> Named @"delete-team-invitation" (\u t inv -> lift . liftSem $ deleteInvitation u t inv) + :<|> Named @"get-team-invitation-info" (lift . liftSem . getInvitationByCode) :<|> Named @"head-team-invitations" (lift . liftSem . headInvitationByEmail) :<|> Named @"get-team-size" teamSizePublic :<|> Named @"accept-team-invitation" (\luid req -> lift $ liftSem $ acceptTeamInvitation luid req.password req.code) @@ -147,55 +134,11 @@ data CreateInvitationInviter = CreateInvitationInviter } deriving (Eq, Show) -createInvitation :: - ( Member GalleyAPIAccess r, - Member UserKeyStore r, - Member InvitationCodeStore r, - Member UserSubsystem r, - Member EmailSending r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input TeamTemplates) r, - Member (Error UserSubsystemError) r - ) => - UserId -> - TeamId -> - Public.InvitationRequest -> - Handler r (Public.Invitation, Public.InvitationLocation) -createInvitation uid tid body = do - let inviteeRole = fromMaybe defaultRole body.role - inviter <- do - let inviteePerms = Teams.rolePermissions inviteeRole - idt <- maybe (throwStd (errorToWai @'E.NoIdentity)) pure =<< lift (fetchUserIdentity uid) - from <- maybe (throwStd (errorToWai @'E.NoEmail)) pure (emailIdentity idt) - lift . liftSem $ ensurePermissionToAddUser uid tid inviteePerms - pure $ CreateInvitationInviter uid from - - let context = - logFunction "Brig.Team.API.createInvitation" - . logTeam tid - . logEmail body.inviteeEmail - - (id &&& loc) . fst - <$> logInvitationRequest - context - (createInvitation' tid Nothing inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body) - where - loc :: Invitation -> InvitationLocation - loc inv = - InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId - createInvitationViaScim :: - ( Member GalleyAPIAccess r, - Member BlockListStore r, + ( Member BlockListStore r, Member UserKeyStore r, - Member InvitationCodeStore r, Member (UserPendingActivationStore p) r, - Member TinyLog r, - Member UserSubsystem r, - Member EmailSending r, - Member (Input (Local ())) r, - Member (Input TeamTemplates) r + Member TinyLog r ) => TeamId -> NewUserScimInvitation -> @@ -241,84 +184,6 @@ logInvitationRequest context action = Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) -createInvitation' :: - ( Member GalleyAPIAccess r, - Member UserSubsystem r, - Member UserKeyStore r, - Member InvitationCodeStore r, - Member EmailSending r, - Member TinyLog r, - Member (Input (Local ())) r, - Member (Input TeamTemplates) r - ) => - TeamId -> - Maybe UserId -> - Public.Role -> - Maybe UserId -> - EmailAddress -> - Public.InvitationRequest -> - Handler r (Public.Invitation, Public.InvitationCode) -createInvitation' tid mUid inviteeRole mbInviterUid fromEmail invRequest = do - let email = invRequest.inviteeEmail - let uke = mkEmailKey email - blacklistedEm <- lift $ liftSem $ isBlocked email - when blacklistedEm $ - throwStd blacklistedEmail - emailTaken <- lift $ liftSem $ isJust <$> lookupKey uke - isPersonalUserMigration <- - if emailTaken - then lift $ liftSem $ isPersonalUser uke - else pure False - when emailTaken $ - unless isPersonalUserMigration $ - throwStd emailExists - - maxSize <- asks (.settings.maxTeamSize) - pending <- lift $ liftSem $ Store.countInvitations tid - when (fromIntegral pending >= maxSize) $ - throwStd (errorToWai @'E.TooManyTeamInvitations) - - showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - - lift $ do - iid <- maybe randomId (pure . Id . toUUID) mUid - now <- liftIO =<< asks (.currentTime) - timeout <- asks (.settings.teamInvitationTimeout) - code <- liftIO $ Store.mkInvitationCode - newInv <- - let insertInv = - Store.MkInsertInvitation - { invitationId = iid, - teamId = tid, - role = inviteeRole, - createdAt = now, - createdBy = mbInviterUid, - inviteeEmail = email, - inviteeName = invRequest.inviteeName, - code = code - -- mUrl = mUrl - } - in liftSem $ Store.insertInvitation insertInv timeout - - let sendOp = - if isPersonalUserMigration - then sendInvitationMailPersonalUser - else sendInvitationMail - - sendOp email tid fromEmail code invRequest.locale - inv <- liftSem $ toInvitation isPersonalUserMigration showInvitationUrl newInv - pure (inv, code) - -isPersonalUser :: (Member UserSubsystem r, Member (Input (Local ())) r) => EmailKey -> Sem r Bool -isPersonalUser uke = do - mAccount <- getLocalUserAccountByUserKey =<< qualifyLocal' uke - pure $ case mAccount of - -- this can e.g. happen if the key is claimed but the account is not yet created - Nothing -> False - Just account -> - account.accountStatus == Active - && isNothing account.accountUser.userTeam - deleteInvitation :: ( Member GalleyAPIAccess r, Member InvitationCodeStore r, @@ -338,8 +203,6 @@ listInvitations :: Member TinyLog r, Member InvitationCodeStore r, Member (Input TeamTemplates) r, - Member (Input (Local ())) r, - Member UserSubsystem r, Member (Error UserSubsystemError) r ) => UserId -> @@ -469,14 +332,6 @@ getInvitation uid tid iid = do maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) -getInvitationByCode :: - (Member Store.InvitationCodeStore r) => - Public.InvitationCode -> - (Handler r) Public.Invitation -getInvitationByCode c = do - inv <- lift . liftSem $ Store.lookupInvitationByCode c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv - headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> @@ -491,17 +346,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. -getInvitationByEmail :: - (Member Store.InvitationCodeStore r, Member TinyLog r) => - EmailAddress -> - (Handler r) Public.Invitation -getInvitationByEmail email = do - inv <- lift . liftSem $ Store.lookupInvitationByEmail email - maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored Nothing) inv - suspendTeam :: ( Member (Embed HttpClientIO) r, Member (Concurrency 'Unsafe) r, diff --git a/services/brig/src/Brig/Team/Email.hs b/services/brig/src/Brig/Team/Email.hs index 9796f26ce23..e6d0cdaeb7f 100644 --- a/services/brig/src/Brig/Team/Email.hs +++ b/services/brig/src/Brig/Team/Email.hs @@ -18,8 +18,7 @@ -- with this program. If not, see . module Brig.Team.Email - ( InvitationEmail (..), - CreatorWelcomeEmail (..), + ( CreatorWelcomeEmail (..), MemberWelcomeEmail (..), sendMemberWelcomeMail, ) @@ -28,7 +27,6 @@ where import Brig.App import Brig.Team.Template import Data.Id (TeamId, idToText) -import Data.Text.Ascii qualified as Ascii import Data.Text.Lazy (toStrict) import Imports import Network.Mail.Mime diff --git a/services/brig/src/Brig/Team/Template.hs b/services/brig/src/Brig/Team/Template.hs index 129ca30ef37..fdcb6d16c22 100644 --- a/services/brig/src/Brig/Team/Template.hs +++ b/services/brig/src/Brig/Team/Template.hs @@ -30,41 +30,7 @@ where import Brig.Options import Brig.Template import Imports -import Wire.API.User.Identity - -data InvitationEmailTemplate = InvitationEmailTemplate - { invitationEmailUrl :: !Template, - invitationEmailSubject :: !Template, - invitationEmailBodyText :: !Template, - invitationEmailBodyHtml :: !Template, - invitationEmailSender :: !EmailAddress, - invitationEmailSenderName :: !Text - } - -data CreatorWelcomeEmailTemplate = CreatorWelcomeEmailTemplate - { creatorWelcomeEmailUrl :: !Text, - creatorWelcomeEmailSubject :: !Template, - creatorWelcomeEmailBodyText :: !Template, - creatorWelcomeEmailBodyHtml :: !Template, - creatorWelcomeEmailSender :: !EmailAddress, - creatorWelcomeEmailSenderName :: !Text - } - -data MemberWelcomeEmailTemplate = MemberWelcomeEmailTemplate - { memberWelcomeEmailUrl :: !Text, - memberWelcomeEmailSubject :: !Template, - memberWelcomeEmailBodyText :: !Template, - memberWelcomeEmailBodyHtml :: !Template, - memberWelcomeEmailSender :: !EmailAddress, - memberWelcomeEmailSenderName :: !Text - } - -data TeamTemplates = TeamTemplates - { invitationEmail :: !InvitationEmailTemplate, - existingUserInvitationEmail :: !InvitationEmailTemplate, - creatorWelcomeEmail :: !CreatorWelcomeEmailTemplate, - memberWelcomeEmail :: !MemberWelcomeEmailTemplate - } +import Wire.EmailSubsystem.Template loadTeamTemplates :: Opts -> IO (Localised TeamTemplates) loadTeamTemplates o = readLocalesDir defLocale (templateDir gOptions) "team" $ \fp -> From 04f67ef7ef52046890fd0999f3b01633cc6c2a48 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 11:02:08 +0200 Subject: [PATCH 12/40] Fix compiler errors. --- services/brig/src/Brig/API/Internal.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 8f2bce2f5d3..9ef296f75e4 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -136,14 +136,11 @@ servantSitemap :: Member Rpc r, Member TinyLog r, Member (UserPendingActivationStore p) r, - Member (Input (Local ())) r, - Member EmailSending r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, Member Events r, Member PasswordResetCodeStore r, Member PropertySubsystem r, - Member (Input TeamTemplates) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -252,7 +249,7 @@ teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = Named @"updateSearchVisibilityInbound" (lift . liftSem . updateTeamSearchVisibilityInbound) - :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail + :<|> Named @"get-invitation-by-email" (lift . liftSem . getInvitationByEmail) :<|> Named @"get-invitation-code" Team.getInvitationCode :<|> Named @"suspend-team" Team.suspendTeam :<|> Named @"unsuspend-team" Team.unsuspendTeam From 546e70f534ed7026e7001389259e40c8bc8e68f6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 11:05:34 +0200 Subject: [PATCH 13/40] Fix compiler errors. --- services/brig/src/Brig/Team/API.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 2ad158bc88c..e19e2de7c02 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -40,6 +40,7 @@ import Control.Monad.Trans.Except (mapExceptT) import Data.ByteString.Conversion (toByteString) import Data.Id import Data.List1 qualified as List1 +import Data.Qualified import Data.Range import Data.Text.Ascii import Data.Text.Encoding (encodeUtf8) @@ -91,6 +92,7 @@ servantAPI :: Member Store.InvitationCodeStore r, Member TinyLog r, Member (Input TeamTemplates) r, + Member (Input (Local ())) r, Member (Error UserSubsystemError) r ) => ServerT TeamsAPI (Handler r) @@ -203,6 +205,8 @@ listInvitations :: Member TinyLog r, Member InvitationCodeStore r, Member (Input TeamTemplates) r, + Member (Input (Local ())) r, + Member UserSubsystem r, Member (Error UserSubsystemError) r ) => UserId -> @@ -225,11 +229,21 @@ listInvitations uid tid startingId mSize = do -- To create the correct team invitation URL, we need to detect whether the invited account already exists. -- Optimization: if url is not to be shown, do not check for existing personal user. toInvitationHack :: ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation - toInvitationHack HideInvitationUrl si = toInvitation False HideInvitationUrl si -- isPersonalUserMigration is always is ignored here + toInvitationHack HideInvitationUrl si = toInvitation False HideInvitationUrl si -- isPersonalUserMigration is always ignored here toInvitationHack ShowInvitationUrl si = do isPersonalUserMigration <- isPersonalUser (mkEmailKey si.email) toInvitation isPersonalUserMigration ShowInvitationUrl si +isPersonalUser :: (Member UserSubsystem r, Member (Input (Local ())) r) => EmailKey -> Sem r Bool +isPersonalUser uke = do + mAccount <- getLocalUserAccountByUserKey =<< qualifyLocal' uke + pure $ case mAccount of + -- this can e.g. happen if the key is claimed but the account is not yet created + Nothing -> False + Just account -> + account.accountStatus == Active + && isNothing account.accountUser.userTeam + -- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. toInvitation :: From 76ac513ee55b1f0a4901a9415b74ddc6d3bd4aeb Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 10:37:15 +0000 Subject: [PATCH 14/40] temp internal operation --- .../src/Wire/TeamInvitationSubsystem.hs | 3 +++ .../src/Wire/TeamInvitationSubsystem/Interpreter.hs | 3 +++ services/brig/src/Brig/API/Internal.hs | 4 +--- services/brig/src/Brig/Team/API.hs | 10 ++++++++-- 4 files changed, 15 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs index 5b66b960df7..5dd802bf874 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs @@ -4,8 +4,10 @@ module Wire.TeamInvitationSubsystem where import Data.Id import Data.Qualified +import Imports import Polysemy import Wire.API.Team.Invitation +import Wire.API.Team.Role import Wire.API.User (InvitationCode) import Wire.API.User.EmailAddress @@ -17,5 +19,6 @@ data TeamInvitationSubsystem m a where GetInvitationByEmail :: EmailAddress -> TeamInvitationSubsystem m Invitation CheckInvitationsByEmail :: EmailAddress -> TeamInvitationSubsystem m HeadInvitationByEmailResult DeleteAllInvitationsFor :: TeamId -> TeamInvitationSubsystem m () + InternalCreateInvitation :: TeamId -> Maybe InvitationId -> Role -> Local (Maybe UserId) -> EmailAddress -> InvitationRequest -> TeamInvitationSubsystem m (Invitation, InvitationCode) makeSem ''TeamInvitationSubsystem diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 66310d42982..e4498755c4d 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -85,6 +85,9 @@ runTeamInvitationSubsystem cfg = interpret $ \case GetInvitationByEmail email -> getInvitationByEmailImpl email CheckInvitationsByEmail email -> checkInvitationsByEmailImpl email DeleteAllInvitationsFor tid -> deleteAllInvitationsForImpl tid + -- \| TODO(leif): add description + InternalCreateInvitation tid mExpectedInvId role mbInviterUid inviterEmail invRequest -> + runInputConst cfg $ createInvitation' tid mExpectedInvId role mbInviterUid inviterEmail invRequest inviteUserImpl :: ( Member (Error TeamInvitationError) r, diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 9ef296f75e4..6bd1a6e37f2 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -41,7 +41,6 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team -import Brig.Team.Template (TeamTemplates) import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -91,7 +90,6 @@ import Wire.API.UserEvent import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.BlockListStore (BlockListStore) import Wire.DeleteQueue (DeleteQueue) -import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) import Wire.Events (Events) import Wire.Events qualified as Events @@ -141,6 +139,7 @@ servantSitemap :: Member Events r, Member PasswordResetCodeStore r, Member PropertySubsystem r, + Member (Input (Local ())) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -243,7 +242,6 @@ teamsAPI :: Member TeamInvitationSubsystem r, Member UserSubsystem r, Member Events r, - Member (Input TeamTemplates) r, Member (Input (Local ())) r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index e19e2de7c02..56316eede2f 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -140,7 +140,9 @@ createInvitationViaScim :: ( Member BlockListStore r, Member UserKeyStore r, Member (UserPendingActivationStore p) r, - Member TinyLog r + Member TinyLog r, + Member TeamInvitationSubsystem r, + Member (Input (Local ())) r ) => TeamId -> NewUserScimInvitation -> @@ -162,9 +164,13 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid _eid loc nam . logTeam tid . logEmail email + iid <- undefined uid + localNothing <- const Nothing <$$> lift (liftSem $ input) void $ logInvitationRequest context $ - createInvitation' tid (Just uid) inviteeRole Nothing fromEmail invreq + lift $ + liftSem $ + internalCreateInvitation tid (Just iid) inviteeRole localNothing fromEmail invreq createUserInviteViaScim newUser From 65e2a266accee83d06f9a1f476220de2df1f442d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 13:35:24 +0200 Subject: [PATCH 15/40] Nit-pick. --- services/brig/src/Brig/Team/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 56316eede2f..4eae55797af 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -165,7 +165,7 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid _eid loc nam . logEmail email iid <- undefined uid - localNothing <- const Nothing <$$> lift (liftSem $ input) + localNothing <- lift . liftSem $ qualifyLocal' Nothing void $ logInvitationRequest context $ lift $ From 8af78266b40629158d3ab954b1ff3220fbf445b3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 13:41:56 +0200 Subject: [PATCH 16/40] Fixup: get invitation id from matching user id in http request body. --- services/brig/src/Brig/Team/API.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 4eae55797af..e39fa39dd6c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -147,7 +147,7 @@ createInvitationViaScim :: TeamId -> NewUserScimInvitation -> (Handler r) UserAccount -createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid _eid loc name email role) = do +createInvitationViaScim tid newUser@(NewUserScimInvitation _tid _uid@(Id (Id -> invId)) _eid loc name email role) = do env <- ask let inviteeRole = role fromEmail = env.emailSender @@ -164,13 +164,12 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid _eid loc nam . logTeam tid . logEmail email - iid <- undefined uid localNothing <- lift . liftSem $ qualifyLocal' Nothing void $ logInvitationRequest context $ lift $ liftSem $ - internalCreateInvitation tid (Just iid) inviteeRole localNothing fromEmail invreq + internalCreateInvitation tid (Just invId) inviteeRole localNothing fromEmail invreq createUserInviteViaScim newUser From 1a53b4f7bd5e8477c666c9face3a095921330e10 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 13:45:15 +0200 Subject: [PATCH 17/40] rm weed. --- libs/wire-api/src/Wire/API/Password.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Password.hs b/libs/wire-api/src/Wire/API/Password.hs index c54f647d5ad..c7aa15111ff 100644 --- a/libs/wire-api/src/Wire/API/Password.hs +++ b/libs/wire-api/src/Wire/API/Password.hs @@ -27,7 +27,6 @@ module Wire.API.Password verifyPassword, verifyPasswordWithStatus, unsafeMkPassword, - unsafeFromPassword, hashPasswordArgon2idWithSalt, hashPasswordArgon2idWithOptions, PasswordReqBody (..), @@ -70,9 +69,6 @@ instance Cql Password where unsafeMkPassword :: Text -> Password unsafeMkPassword = Password -unsafeFromPassword :: Password -> Text -unsafeFromPassword = fromPassword - data PasswordStatus = PasswordStatusOk | PasswordStatusNeedsUpdate From ad540b1e466b4a2102398a55c1375648614742c6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 13:53:51 +0200 Subject: [PATCH 18/40] pass teamInvitationSubsystemConfig with content from Brig.Options. --- services/brig/src/Brig/CanonicalInterpreter.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 92484d79c5e..afc7a66c424 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -176,6 +176,11 @@ runBrigToIO e (AppT ma) = do searchSameTeamOnly = fromMaybe False e.settings.searchSameTeamOnly, maxTeamSize = e.settings.maxTeamSize } + teamInvitationSubsystemConfig = + TeamInvitationSubsystemConfig + { maxTeamSize = e.settings.maxTeamSize, + teamInvitationTimeout = e.settings.teamInvitationTimeout + } federationApiAccessConfig = FederationAPIAccessConfig { ownDomain = e.settings.federationDomain, @@ -269,9 +274,9 @@ runBrigToIO e (AppT ma) = do . runDeleteQueue e.internalEvents . interpretPropertySubsystem propertySubsystemConfig . interpretVerificationCodeSubsystem - . emailSubsystemInterpreter e.userTemplates undefined e.templateBranding + . emailSubsystemInterpreter e.userTemplates e.teamTemplates e.templateBranding . userSubsystemInterpreter - . runTeamInvitationSubsystem undefined -- TODO + . runTeamInvitationSubsystem teamInvitationSubsystemConfig . authSubsystemInterpreter ) ) From 0910bff898f7e60ca650c29bed31efa6027ab082 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 12:50:51 +0000 Subject: [PATCH 19/40] move team size to indexed user store --- .../src/Wire/IndexedUserStore.hs | 2 ++ .../Wire/IndexedUserStore/ElasticSearch.hs | 22 +++++++++++++++++++ .../src/Wire/UserSubsystem/Interpreter.hs | 5 +++-- .../Wire/MockInterpreters/IndexedUserStore.hs | 1 + 4 files changed, 28 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs index 92e3c7ea97e..c3fe401f4f8 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore.hs @@ -7,6 +7,7 @@ import Database.Bloodhound qualified as ES import Database.Bloodhound.Types hiding (SearchResult) import Imports import Polysemy +import Wire.API.Team.Size import Wire.API.User.Search import Wire.UserSearch.Types @@ -39,5 +40,6 @@ data IndexedUserStore m a where Int -> Maybe PagingState -> IndexedUserStore m (SearchResult UserDoc) + GetTeamSize :: TeamId -> IndexedUserStore m TeamSize makeSem ''IndexedUserStore diff --git a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs index f299017ce2b..6f8dd26e89f 100644 --- a/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs +++ b/libs/wire-subsystems/src/Wire/IndexedUserStore/ElasticSearch.hs @@ -18,6 +18,7 @@ import Imports import Network.HTTP.Client import Network.HTTP.Types import Polysemy +import Wire.API.Team.Size (TeamSize (TeamSize)) import Wire.API.User.Search import Wire.IndexedUserStore import Wire.Sem.Metrics (Metrics) @@ -53,6 +54,27 @@ interpretIndexedUserStoreES cfg = searchUsersImpl cfg searcherId mSearcherTeam teamSearchInfo term maxResults PaginateTeamMembers filters maxResults mPagingState -> paginateTeamMembersImpl cfg filters maxResults mPagingState + GetTeamSize tid -> getTeamSizeImpl cfg tid + +getTeamSizeImpl :: + ( Member (Embed IO) r + ) => + IndexedUserStoreConfig -> + TeamId -> + Sem r TeamSize +getTeamSizeImpl cfg tid = do + let indexName = cfg.conn.indexName + countResEither <- embed $ ES.runBH cfg.conn.env $ ES.countByIndex indexName (ES.CountQuery query) + countRes <- either (liftIO . throwIO . IndexLookupError) pure countResEither + pure . TeamSize $ ES.crCount countRes + where + query = + ES.TermQuery + ES.Term + { ES.termField = "team", + ES.termValue = idToText tid + } + Nothing upsertImpl :: forall r. diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index f3d4b29cbec..802fa6dd9d1 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -178,7 +178,8 @@ internalFindTeamInvitationImpl :: ( Member InvitationCodeStore r, Member (Error UserSubsystemError) r, Member (Input UserSubsystemConfig) r, - Member (GalleyAPIAccess) r + Member (GalleyAPIAccess) r, + Member IndexedUserStore r ) => Maybe EmailKey -> InvitationCode -> @@ -198,7 +199,7 @@ internalFindTeamInvitationImpl (Just e) c = where ensureMemberCanJoin tid = do maxSize <- maxTeamSize <$> input - (TeamSize teamSize) <- (error "todo impl team size in search subsystem") tid + (TeamSize teamSize) <- IndexedUserStore.getTeamSize tid when (teamSize >= fromIntegral maxSize) $ throw UserSubsystemTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs index 60a186a6d8c..06d78cfd24b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/IndexedUserStore.hs @@ -13,3 +13,4 @@ inMemoryIndexedUserStoreInterpreter = DoesIndexExist -> pure True SearchUsers {} -> error "IndexedUserStore: unimplemented in memory interpreter" PaginateTeamMembers {} -> error "IndexedUserStore: unimplemented in memory interpreter" + GetTeamSize {} -> error "IndexedUserStore: unimplemented in memory interpreter" From 40c39c074c7f134c6191e65cf93230dfe914f5f6 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 13:01:15 +0000 Subject: [PATCH 20/40] use real implementation --- libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 802fa6dd9d1..f982f54a63d 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -938,7 +938,8 @@ acceptTeamInvitationImpl luid pw code = do -- in final code. We have to implement checkPassword in terms of Auth subsystem. forM_ mEmailKey $ createPasswordResetCode checkPassword - (inv :: StoredInvitation, tid) <- (error "todo findTeamInvitation") mEmailKey code + inv <- fst <$> internalFindTeamInvitationImpl mEmailKey code + let tid = inv.teamId let minvmeta = (,inv.createdAt) <$> inv.createdBy uid = tUnqualified luid for_ mTid $ \userTid -> From bc4e708e3016752aa0e94f6805ec527ec1de13cf Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 13:07:46 +0000 Subject: [PATCH 21/40] added comment --- libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs | 2 ++ .../src/Wire/TeamInvitationSubsystem/Interpreter.hs | 1 - libs/wire-subsystems/src/Wire/UserSubsystem.hs | 4 ++-- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs index 5dd802bf874..d3dd9159177 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs @@ -19,6 +19,8 @@ data TeamInvitationSubsystem m a where GetInvitationByEmail :: EmailAddress -> TeamInvitationSubsystem m Invitation CheckInvitationsByEmail :: EmailAddress -> TeamInvitationSubsystem m HeadInvitationByEmailResult DeleteAllInvitationsFor :: TeamId -> TeamInvitationSubsystem m () + -- | This function exists to support migration in this susbystem, after the + -- migration this would just be an internal detail of the subsystem InternalCreateInvitation :: TeamId -> Maybe InvitationId -> Role -> Local (Maybe UserId) -> EmailAddress -> InvitationRequest -> TeamInvitationSubsystem m (Invitation, InvitationCode) makeSem ''TeamInvitationSubsystem diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index e4498755c4d..bf97e9ac03a 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -85,7 +85,6 @@ runTeamInvitationSubsystem cfg = interpret $ \case GetInvitationByEmail email -> getInvitationByEmailImpl email CheckInvitationsByEmail email -> checkInvitationsByEmailImpl email DeleteAllInvitationsFor tid -> deleteAllInvitationsForImpl tid - -- \| TODO(leif): add description InternalCreateInvitation tid mExpectedInvId role mbInviterUid inviterEmail invRequest -> runInputConst cfg $ createInvitation' tid mExpectedInvId role mbInviterUid inviterEmail invRequest diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 59b94f92a73..d67d751f86a 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -137,10 +137,10 @@ data UserSubsystem m a where Maybe (Range 1 500 Int) -> Maybe PagingState -> UserSubsystem m (SearchResult TeamContact) - -- | This function exists to support migration in this susbystem, after the + AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () + -- | The following "internal" functions exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () - AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m (StoredInvitation, StoredInvitationInfo) -- | the return type of 'CheckHandle' From 54444fff8426484b8cb5a576c5db4be9dcd201a2 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 13:20:02 +0000 Subject: [PATCH 22/40] remove stored invitation info from brig --- .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 +- .../src/Wire/UserSubsystem/Interpreter.hs | 6 +- services/brig/src/Brig/API/User.hs | 56 ++++--------------- 3 files changed, 14 insertions(+), 50 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index d67d751f86a..33a82f0d1b2 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -141,7 +141,7 @@ data UserSubsystem m a where -- | The following "internal" functions exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () - InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m (StoredInvitation, StoredInvitationInfo) + InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index f982f54a63d..d01d62aeb75 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -183,7 +183,7 @@ internalFindTeamInvitationImpl :: ) => Maybe EmailKey -> InvitationCode -> - Sem r (StoredInvitation, StoredInvitationInfo) + Sem r StoredInvitation internalFindTeamInvitationImpl Nothing _ = throw UserSubsystemMissingIdentity internalFindTeamInvitationImpl (Just e) c = lookupInvitationInfo c >>= \case @@ -193,7 +193,7 @@ internalFindTeamInvitationImpl (Just e) c = (Just invite, Just em) | e == mkEmailKey em -> do ensureMemberCanJoin invitationInfo.teamId - pure (invite, invitationInfo) + pure invite _ -> throw UserSubsystemInvalidInvitationCode Nothing -> throw UserSubsystemInvalidInvitationCode where @@ -938,7 +938,7 @@ acceptTeamInvitationImpl luid pw code = do -- in final code. We have to implement checkPassword in terms of Auth subsystem. forM_ mEmailKey $ createPasswordResetCode checkPassword - inv <- fst <$> internalFindTeamInvitationImpl mEmailKey code + inv <- internalFindTeamInvitationImpl mEmailKey code let tid = inv.teamId let minvmeta = (,inv.createdAt) <$> inv.createdBy uid = tUnqualified luid diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ea85745cf14..c2d281249a8 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -65,13 +65,11 @@ module Brig.API.User blacklistInsert, -- * Utilities - fetchUserIdentity, - findTeamInvitation, + fetchUserIdentity ) where import Brig.API.Error qualified as Error -import Brig.API.Handler qualified as API (UserNotAllowedToJoinTeam (..)) import Brig.API.Types import Brig.API.Util import Brig.App as App @@ -90,7 +88,6 @@ import Brig.Options hiding (internalEvents) import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth -import Brig.User.Search.TeamSize qualified as TeamSize import Cassandra hiding (Set) import Control.Error import Control.Lens (preview, to, (^.), _Just) @@ -127,7 +124,6 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) import Wire.API.Team.Member (legalHoldStatus) import Wire.API.Team.Role -import Wire.API.Team.Size import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Client @@ -141,7 +137,7 @@ import Wire.Error import Wire.Events (Events) import Wire.Events qualified as Events import Wire.GalleyAPIAccess as GalleyAPIAccess -import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation, StoredInvitationInfo) +import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation) import Wire.InvitationCodeStore qualified as InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordResetCodeStore (PasswordResetCodeStore) @@ -331,15 +327,15 @@ createUser new = do (mNewTeamUser, teamInvitation, tid) <- case newUserTeam new of Just (NewTeamMember i) -> do - (inv, info) <- findTeamInvitation (mkEmailKey <$> email) i - pure (Nothing, Just (inv, info), Just info.teamId) + inv <- lift $ liftSem $ internalFindTeamInvitation (mkEmailKey <$> email) i + pure (Nothing, Just inv, Just inv.teamId) Just (NewTeamCreator t) -> do (Just t,Nothing,) <$> (Just . Id <$> liftIO nextRandom) Just (NewTeamMemberSSO tid) -> pure (Nothing, Nothing, Just tid) Nothing -> pure (Nothing, Nothing, Nothing) - let mbInv = (.invitationId) . fst <$> teamInvitation + let mbInv = (.invitationId) <$> teamInvitation mbExistingAccount <- lift $ join @@ -403,8 +399,8 @@ createUser new = do _ -> pure Nothing joinedTeamInvite <- case teamInvitation of - Just (inv, invInfo) -> do - acceptInvitationToTeam account inv invInfo (mkEmailKey inv.email) (EmailIdentity inv.email) + Just inv -> do + acceptInvitationToTeam account inv (mkEmailKey inv.email) (EmailIdentity inv.email) Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.teamId pure (Just $ CreateUserTeam inv.teamId nm) Nothing -> pure Nothing @@ -436,11 +432,10 @@ createUser new = do acceptInvitationToTeam :: UserAccount -> StoredInvitation -> - StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () - acceptInvitationToTeam account inv invitationInfo uk ident = do + acceptInvitationToTeam account inv uk ident = do let uid = userId (accountUser account) ok <- lift $ liftSem $ claimKey uk uid unless ok $ @@ -449,7 +444,7 @@ createUser new = do minvmeta = (,inv.createdAt) <$> inv.createdBy role :: Role role = fromMaybe defaultRole inv.role - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.teamId minvmeta role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid inv.teamId minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -459,7 +454,7 @@ createUser new = do liftSem do Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ invitationInfo.teamId) + . field "team" (toByteString $ inv.teamId) . msg (val "Accepting invitation") UserPendingActivationStore.remove uid InvitationCodeStore.deleteInvitation inv.teamId inv.invitationId @@ -500,37 +495,6 @@ createUser new = do !>> activationErrorToRegisterError pure Nothing -findTeamInvitation :: - ( Member GalleyAPIAccess r, - Member InvitationCodeStore r - ) => - Maybe EmailKey -> - InvitationCode -> - ExceptT RegisterError (AppT r) (StoredInvitation, StoredInvitationInfo) -findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity -findTeamInvitation (Just e) c = - 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 invitationInfo.teamId - pure (invite, invitationInfo) - _ -> throwE RegisterErrorInvalidInvitationCode - Nothing -> throwE RegisterErrorInvalidInvitationCode - where - ensureMemberCanJoin :: (Member GalleyAPIAccess r) => TeamId -> ExceptT RegisterError (AppT r) () - ensureMemberCanJoin tid = do - maxSize <- fromIntegral <$> asks (.settings.maxTeamSize) - (TeamSize teamSize) <- TeamSize.teamSize tid - when (teamSize >= maxSize) $ - throwE RegisterErrorTooManyTeamMembers - -- FUTUREWORK: The above can easily be done/tested in the intra call. - -- Remove after the next release. - mAddUserError <- lift $ liftSem $ GalleyAPIAccess.checkUserCanJoinTeam tid - maybe (pure ()) (throwM . API.UserNotAllowedToJoinTeam) mAddUserError - initAccountFeatureConfig :: UserId -> (AppT r) () initAccountFeatureConfig uid = do mStatus <- preview (App.settingsLens . featureFlagsLens . _Just . to conferenceCalling . to forNew . _Just) From 99f6c416b52941d500e2685955aa7b1255f03d18 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 25 Sep 2024 13:28:44 +0000 Subject: [PATCH 23/40] replace team size with subsystem call --- services/brig/brig.cabal | 1 - services/brig/src/Brig/API/Internal.hs | 9 ++-- services/brig/src/Brig/API/Public.hs | 4 +- services/brig/src/Brig/Team/API.hs | 19 ++++---- .../brig/src/Brig/User/Search/TeamSize.hs | 46 ------------------- 5 files changed, 18 insertions(+), 61 deletions(-) delete mode 100644 services/brig/src/Brig/User/Search/TeamSize.hs diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 051f18c405f..bc322581589 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -196,7 +196,6 @@ library Brig.User.EJPD Brig.User.Search.Index Brig.User.Search.SearchIndex - Brig.User.Search.TeamSize Brig.User.Template Brig.Version Brig.ZAuth diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 8f1a0f46775..5d0d8c9dfb5 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -115,6 +115,7 @@ import Wire.UserSubsystem qualified as UserSubsystem import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem +import Wire.IndexedUserStore (getTeamSize, IndexedUserStore) servantSitemap :: forall r p. @@ -139,7 +140,8 @@ servantSitemap :: Member Events r, Member PasswordResetCodeStore r, Member PropertySubsystem r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member IndexedUserStore r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -242,7 +244,8 @@ teamsAPI :: Member TeamInvitationSubsystem r, Member UserSubsystem r, Member Events r, - Member (Input (Local ())) r + Member (Input (Local ())) r, + Member IndexedUserStore r ) => ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = @@ -251,7 +254,7 @@ teamsAPI = :<|> Named @"get-invitation-code" Team.getInvitationCode :<|> Named @"suspend-team" Team.suspendTeam :<|> Named @"unsuspend-team" Team.unsuspendTeam - :<|> Named @"team-size" Team.teamSize + :<|> Named @"team-size" (lift . liftSem . getTeamSize) :<|> Named @"create-invitations-via-scim" Team.createInvitationViaScim userAPI :: (Member UserSubsystem r) => ServerT BrigIRoutes.UserAPI (Handler r) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index cd69d444faa..09c3cd94c3d 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -174,6 +174,7 @@ import Wire.UserSubsystem.Error import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem +import Wire.IndexedUserStore (IndexedUserStore) -- User API ----------------------------------------------------------- @@ -299,7 +300,8 @@ servantSitemap :: Member VerificationCodeSubsystem r, Member (Concurrency 'Unsafe) r, Member BlockListStore r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member IndexedUserStore r ) => ServerT BrigAPI (Handler r) servantSitemap = diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index e39fa39dd6c..204f099e4c6 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -21,7 +21,6 @@ module Brig.Team.API getInvitationCode, suspendTeam, unsuspendTeam, - teamSize, createInvitationViaScim, ) where @@ -34,7 +33,6 @@ import Brig.API.Util (logEmail, logInvitationCode) import Brig.App as App import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Types.Team (TeamSize) -import Brig.User.Search.TeamSize qualified as TeamSize import Control.Lens (view, (^.)) import Control.Monad.Trans.Except (mapExceptT) import Data.ByteString.Conversion (toByteString) @@ -84,6 +82,7 @@ import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSubsystem import Wire.UserSubsystem.Error +import Wire.IndexedUserStore (getTeamSize, IndexedUserStore) servantAPI :: ( Member GalleyAPIAccess r, @@ -93,7 +92,8 @@ servantAPI :: Member TinyLog r, Member (Input TeamTemplates) r, Member (Input (Local ())) r, - Member (Error UserSubsystemError) r + Member (Error UserSubsystemError) r, + Member IndexedUserStore r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -108,18 +108,17 @@ servantAPI = teamSizePublic :: ( Member GalleyAPIAccess r, - Member (Error UserSubsystemError) r + Member (Error UserSubsystemError) r, + Member IndexedUserStore r ) => UserId -> TeamId -> (Handler r) TeamSize -teamSizePublic uid tid = do +teamSizePublic uid tid = + lift . liftSem $ do -- limit this to team admins to reduce risk of involuntary DOS attacks - lift . liftSem $ ensurePermissions uid tid [AddTeamMember] - teamSize tid - -teamSize :: TeamId -> (Handler r) TeamSize -teamSize t = lift $ TeamSize.teamSize t + ensurePermissions uid tid [AddTeamMember] + getTeamSize tid getInvitationCode :: (Member Store.InvitationCodeStore r) => diff --git a/services/brig/src/Brig/User/Search/TeamSize.hs b/services/brig/src/Brig/User/Search/TeamSize.hs deleted file mode 100644 index 6121ec38178..00000000000 --- a/services/brig/src/Brig/User/Search/TeamSize.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE StrictData #-} - --- 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.User.Search.TeamSize - ( teamSize, - ) -where - -import Brig.Types.Team (TeamSize (..)) -import Brig.User.Search.Index -import Control.Monad.Catch (throwM) -import Data.Id -import Database.Bloodhound qualified as ES -import Imports hiding (log, searchable) -import Wire.IndexedUserStore (IndexedUserStoreError (..)) - -teamSize :: (MonadIndexIO m) => TeamId -> m TeamSize -teamSize t = liftIndexIO $ do - indexName <- asks idxName - countResEither <- ES.countByIndex indexName (ES.CountQuery query) - countRes <- either (throwM . IndexLookupError) pure countResEither - pure . TeamSize $ ES.crCount countRes - where - query = - ES.TermQuery - ES.Term - { ES.termField = "team", - ES.termValue = idToText t - } - Nothing From 6a11931c66a0ca6e1e1815ca5680d1330ef843a6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 15:40:00 +0200 Subject: [PATCH 24/40] TODO --- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 33a82f0d1b2..75dba118528 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -137,7 +137,8 @@ data UserSubsystem m a where Maybe (Range 1 500 Int) -> Maybe PagingState -> UserSubsystem m (SearchResult TeamContact) - AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () + AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () -- TODO(fisx): move to TeamInvitationSubsystem? (or move AcceptInvitation to UserSubsystem? :) + -- | The following "internal" functions exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () From ee1ba287a55ad74d1b3b2bf88fdfeba3d180c63f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 15:56:16 +0200 Subject: [PATCH 25/40] Cleanup --- services/brig/src/Brig/Team/API.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 204f099e4c6..b746a788b91 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -75,6 +75,7 @@ import Wire.Error import Wire.Events (Events) import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.IndexedUserStore (IndexedUserStore, getTeamSize) import Wire.InvitationCodeStore (InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) import Wire.InvitationCodeStore qualified as Store import Wire.Sem.Concurrency @@ -82,7 +83,6 @@ import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSubsystem import Wire.UserSubsystem.Error -import Wire.IndexedUserStore (getTeamSize, IndexedUserStore) servantAPI :: ( Member GalleyAPIAccess r, @@ -116,7 +116,7 @@ teamSizePublic :: (Handler r) TeamSize teamSizePublic uid tid = lift . liftSem $ do - -- limit this to team admins to reduce risk of involuntary DOS attacks + -- limit this to team admins to reduce risk of involuntary DOS attacks ensurePermissions uid tid [AddTeamMember] getTeamSize tid From c71eeb5c674ddc8f1a6b3929df636cbb0f96cf35 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 15:56:24 +0200 Subject: [PATCH 26/40] Leave a few TeamInvitationSubsystem operations for next PR. --- .../src/Wire/TeamInvitationSubsystem.hs | 6 ----- .../TeamInvitationSubsystem/Interpreter.hs | 24 ------------------- services/brig/src/Brig/API/Internal.hs | 4 ++-- services/brig/src/Brig/Team/API.hs | 23 ++++++++++++++++-- 4 files changed, 23 insertions(+), 34 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs index d3dd9159177..09cb54a6250 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem.hs @@ -13,12 +13,6 @@ import Wire.API.User.EmailAddress data TeamInvitationSubsystem m a where InviteUser :: Local UserId -> TeamId -> InvitationRequest -> TeamInvitationSubsystem m (Invitation, InvitationLocation) - AcceptInvitation :: UserId -> InvitationId -> InvitationCode -> TeamInvitationSubsystem m () - RevokeInvitation :: TeamId -> InvitationId -> TeamInvitationSubsystem m () - GetInvitationByCode :: InvitationCode -> TeamInvitationSubsystem m Invitation - GetInvitationByEmail :: EmailAddress -> TeamInvitationSubsystem m Invitation - CheckInvitationsByEmail :: EmailAddress -> TeamInvitationSubsystem m HeadInvitationByEmailResult - DeleteAllInvitationsFor :: TeamId -> TeamInvitationSubsystem m () -- | This function exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalCreateInvitation :: TeamId -> Maybe InvitationId -> Role -> Local (Maybe UserId) -> EmailAddress -> InvitationRequest -> TeamInvitationSubsystem m (Invitation, InvitationCode) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index bf97e9ac03a..8ac14e8153e 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -79,12 +79,6 @@ runTeamInvitationSubsystem :: InterpreterFor TeamInvitationSubsystem r runTeamInvitationSubsystem cfg = interpret $ \case InviteUser luid tid request -> runInputConst cfg $ inviteUserImpl luid tid request - AcceptInvitation uid invitationId invitationCode -> acceptInvitationImpl uid invitationId invitationCode - RevokeInvitation tid invitationId -> revokeInvitationImpl tid invitationId - GetInvitationByCode invitationCode -> getInvitationByCodeImpl invitationCode - GetInvitationByEmail email -> getInvitationByEmailImpl email - CheckInvitationsByEmail email -> checkInvitationsByEmailImpl email - DeleteAllInvitationsFor tid -> deleteAllInvitationsForImpl tid InternalCreateInvitation tid mExpectedInvId role mbInviterUid inviterEmail invRequest -> runInputConst cfg $ createInvitation' tid mExpectedInvId role mbInviterUid inviterEmail invRequest @@ -266,24 +260,6 @@ logInvitationRequest context action = . logInvitationCode code pure res -acceptInvitationImpl :: UserId -> InvitationId -> InvitationCode -> Sem r () -acceptInvitationImpl = undefined - -revokeInvitationImpl :: TeamId -> InvitationId -> Sem r () -revokeInvitationImpl = undefined - -getInvitationByCodeImpl :: InvitationCode -> Sem r Invitation -getInvitationByCodeImpl = undefined - -getInvitationByEmailImpl :: EmailAddress -> Sem r Invitation -getInvitationByEmailImpl = undefined - -checkInvitationsByEmailImpl :: EmailAddress -> Sem r HeadInvitationByEmailResult -checkInvitationsByEmailImpl = undefined - -deleteAllInvitationsForImpl :: TeamId -> Sem r () -deleteAllInvitationsForImpl = undefined - -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 5d0d8c9dfb5..c1bead99444 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -101,6 +101,7 @@ import Wire.FederationConfigStore ) import Wire.FederationConfigStore qualified as E import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.IndexedUserStore (IndexedUserStore, getTeamSize) import Wire.InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordResetCodeStore (PasswordResetCodeStore) @@ -115,7 +116,6 @@ import Wire.UserSubsystem qualified as UserSubsystem import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem -import Wire.IndexedUserStore (getTeamSize, IndexedUserStore) servantSitemap :: forall r p. @@ -250,7 +250,7 @@ teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = Named @"updateSearchVisibilityInbound" (lift . liftSem . updateTeamSearchVisibilityInbound) - :<|> Named @"get-invitation-by-email" (lift . liftSem . getInvitationByEmail) + :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail :<|> Named @"get-invitation-code" Team.getInvitationCode :<|> Named @"suspend-team" Team.suspendTeam :<|> Named @"unsuspend-team" Team.unsuspendTeam diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index b746a788b91..6ebb2dbc2a6 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -97,11 +97,11 @@ servantAPI :: ) => ServerT TeamsAPI (Handler r) servantAPI = - Named @"send-team-invitation" (\luid tid invreq -> lift . liftSem $ inviteUser luid tid invreq) + Named @"send-team-invitation" (\luid tid invreq -> lift . liftSem $ inviteUser luid tid invreq) -- TODO: move 'lift . liftSem' to the outside of 'servantAPI' :<|> Named @"get-team-invitations" (\u t inv s -> lift . liftSem $ listInvitations u t inv s) :<|> Named @"get-team-invitation" (\u t inv -> lift . liftSem $ getInvitation u t inv) :<|> Named @"delete-team-invitation" (\u t inv -> lift . liftSem $ deleteInvitation u t inv) - :<|> Named @"get-team-invitation-info" (lift . liftSem . getInvitationByCode) + :<|> Named @"get-team-invitation-info" getInvitationByCode :<|> Named @"head-team-invitations" (lift . liftSem . headInvitationByEmail) :<|> Named @"get-team-size" teamSizePublic :<|> Named @"accept-team-invitation" (\luid req -> lift $ liftSem $ acceptTeamInvitation luid req.password req.code) @@ -350,6 +350,14 @@ getInvitation uid tid iid = do maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) +getInvitationByCode :: + (Member Store.InvitationCodeStore r) => + InvitationCode -> + (Handler r) Public.Invitation +getInvitationByCode c = do + inv <- lift . liftSem $ Store.lookupInvitationByCode c + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv + headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> @@ -364,6 +372,17 @@ 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. +getInvitationByEmail :: + (Member Store.InvitationCodeStore r, Member TinyLog r) => + EmailAddress -> + (Handler r) Public.Invitation +getInvitationByEmail email = do + inv <- lift . liftSem $ Store.lookupInvitationByEmail email + maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored Nothing) inv + suspendTeam :: ( Member (Embed HttpClientIO) r, Member (Concurrency 'Unsafe) r, From 32d30c8fccf837c0cd0a8037574330a2674d11bf Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:05:59 +0200 Subject: [PATCH 27/40] Cleanup. --- services/brig/src/Brig/Team/API.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 6ebb2dbc2a6..08a8f666edb 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -238,16 +238,6 @@ listInvitations uid tid startingId mSize = do isPersonalUserMigration <- isPersonalUser (mkEmailKey si.email) toInvitation isPersonalUserMigration ShowInvitationUrl si -isPersonalUser :: (Member UserSubsystem r, Member (Input (Local ())) r) => EmailKey -> Sem r Bool -isPersonalUser uke = do - mAccount <- getLocalUserAccountByUserKey =<< qualifyLocal' uke - pure $ case mAccount of - -- this can e.g. happen if the key is claimed but the account is not yet created - Nothing -> False - Just account -> - account.accountStatus == Active - && isNothing account.accountUser.userTeam - -- | brig used to not store the role, so for migration we allow this to be empty and fill in the -- default here. toInvitation :: @@ -350,6 +340,16 @@ getInvitation uid tid iid = do maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code pure $ Just (Store.invitationFromStored maybeUrl invitation) +isPersonalUser :: (Member UserSubsystem r, Member (Input (Local ())) r) => EmailKey -> Sem r Bool +isPersonalUser uke = do + mAccount <- getLocalUserAccountByUserKey =<< qualifyLocal' uke + pure $ case mAccount of + -- this can e.g. happen if the key is claimed but the account is not yet created + Nothing -> False + Just account -> + account.accountStatus == Active + && isNothing account.accountUser.userTeam + getInvitationByCode :: (Member Store.InvitationCodeStore r) => InvitationCode -> From 0e230f15b05bdc13de92dd9181bdd49265670383 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:14:42 +0200 Subject: [PATCH 28/40] Move subsystem error type to Subsystem.Error module. --- .../src/Wire/TeamInvitationSubsystem/Error.hs | 24 ++++++++++++++ .../TeamInvitationSubsystem/Interpreter.hs | 33 ++++--------------- libs/wire-subsystems/wire-subsystems.cabal | 1 + .../brig/src/Brig/CanonicalInterpreter.hs | 3 +- 4 files changed, 34 insertions(+), 27 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs new file mode 100644 index 00000000000..f6e698380ef --- /dev/null +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs @@ -0,0 +1,24 @@ +module Wire.TeamInvitationSubsystem.Error where + +import Imports +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.Error + +data TeamInvitationSubsystemError + = TeamInvitationNoEmail + | TeamInvitationInsufficientTeamPermissions + | TooManyTeamInvitations + | TeamInvitationBlacklistedEmail + | TeamInvitationEmailTaken + deriving (Show) + +teamInvitationErrorToHttpError :: TeamInvitationSubsystemError -> HttpError +teamInvitationErrorToHttpError = + StdError . \case + TeamInvitationNoEmail -> errorToWai @E.NoEmail + TeamInvitationInsufficientTeamPermissions -> errorToWai @E.InsufficientTeamPermissions + TooManyTeamInvitations -> errorToWai @E.TooManyTeamInvitations + TeamInvitationBlacklistedEmail -> errorToWai @E.BlacklistedEmail + TeamInvitationEmailTaken -> errorToWai @E.EmailExists + diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 8ac14e8153e..336e73d5f9f 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -17,8 +17,6 @@ import System.Logger.Message as Log import URI.ByteString import Util.Logging import Util.Timeout (Timeout (..)) -import Wire.API.Error -import Wire.API.Error.Brig qualified as E import Wire.API.Team.Invitation import Wire.API.Team.Member import Wire.API.Team.Member qualified as Teams @@ -27,7 +25,6 @@ import Wire.API.Team.Role import Wire.API.User import Wire.Arbitrary import Wire.EmailSubsystem -import Wire.Error import Wire.GalleyAPIAccess hiding (AddTeamMember) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation) @@ -38,6 +35,7 @@ import Wire.Sem.Now qualified as Now import Wire.Sem.Random (Random) import Wire.Sem.Random qualified as Random import Wire.TeamInvitationSubsystem +import Wire.TeamInvitationSubsystem.Error import Wire.UserKeyStore import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey, getSelfProfile, isBlocked) @@ -48,25 +46,8 @@ data TeamInvitationSubsystemConfig = TeamInvitationSubsystemConfig deriving (Show, Generic) deriving (Arbitrary) via GenericUniform TeamInvitationSubsystemConfig -data TeamInvitationError -- TODO: rename to TeamInvitationSubsystemError, move to Wire.TeamInvitationSubsystem.Error - = TeamInvitationNoEmail - | TeamInvitationInsufficientTeamPermissions - | TooManyTeamInvitations - | TeamInvitationBlacklistedEmail - | TeamInvitationEmailTaken - deriving (Show) - -teamInvitationErrorToHttpError :: TeamInvitationError -> HttpError -teamInvitationErrorToHttpError = - StdError . \case - TeamInvitationNoEmail -> errorToWai @E.NoEmail - TeamInvitationInsufficientTeamPermissions -> errorToWai @E.InsufficientTeamPermissions - TooManyTeamInvitations -> errorToWai @E.TooManyTeamInvitations - TeamInvitationBlacklistedEmail -> errorToWai @E.BlacklistedEmail - TeamInvitationEmailTaken -> errorToWai @E.EmailExists - runTeamInvitationSubsystem :: - ( Member (Error TeamInvitationError) r, + ( Member (Error TeamInvitationSubsystemError) r, Member TinyLog r, Member GalleyAPIAccess r, Member UserSubsystem r, @@ -83,7 +64,7 @@ runTeamInvitationSubsystem cfg = interpret $ \case runInputConst cfg $ createInvitation' tid mExpectedInvId role mbInviterUid inviterEmail invRequest inviteUserImpl :: - ( Member (Error TeamInvitationError) r, + ( Member (Error TeamInvitationSubsystemError) r, Member GalleyAPIAccess r, Member UserSubsystem r, Member TinyLog r, @@ -127,7 +108,7 @@ createInvitation' :: Member UserSubsystem r, Member InvitationCodeStore r, Member TinyLog r, - Member (Error TeamInvitationError) r, + Member (Error TeamInvitationSubsystemError) r, Member Random r, Member (Input TeamInvitationSubsystemConfig) r, Member Now r, @@ -242,9 +223,9 @@ toInvitation urlText showUrl storedInv = do . Log.field "error" (show e) logInvitationRequest :: - (Member TinyLog r, Member (Error TeamInvitationError) r) => + (Member TinyLog r, Member (Error TeamInvitationSubsystemError) r) => (Msg -> Msg) -> - Sem (Error TeamInvitationError : r) (Invitation, InvitationCode) -> + Sem (Error TeamInvitationSubsystemError : r) (Invitation, InvitationCode) -> Sem r (Invitation, InvitationCode) logInvitationRequest context action = runError action >>= \case @@ -265,7 +246,7 @@ logInvitationRequest context action = -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. ensurePermissionToAddUser :: ( Member GalleyAPIAccess r, - Member (Error TeamInvitationError) r + Member (Error TeamInvitationSubsystemError) r ) => UserId -> TeamId -> diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 89f8d952da3..011bd1e528c 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -120,6 +120,7 @@ library Wire.SessionStore.Cassandra Wire.StoredUser Wire.TeamInvitationSubsystem + Wire.TeamInvitationSubsystem.Error Wire.TeamInvitationSubsystem.Interpreter Wire.UserKeyStore Wire.UserKeyStore.Cassandra diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index afc7a66c424..4b6af606d58 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -86,6 +86,7 @@ import Wire.Sem.Random.IO import Wire.SessionStore import Wire.SessionStore.Cassandra (interpretSessionStoreCassandra) import Wire.TeamInvitationSubsystem +import Wire.TeamInvitationSubsystem.Error import Wire.TeamInvitationSubsystem.Interpreter import Wire.UserKeyStore import Wire.UserKeyStore.Cassandra @@ -114,7 +115,7 @@ type BrigLowerLevelEffects = DeleteQueue, Wire.Events.Events, Error UserSubsystemError, - Error TeamInvitationError, + Error TeamInvitationSubsystemError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, Error VerificationCodeSubsystemError, From 67fe2cfc066efe361653e7fef9c71cd84ca23454 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:16:07 +0200 Subject: [PATCH 29/40] Postpone TODO. --- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 75dba118528..5ba2119a103 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -137,8 +137,8 @@ data UserSubsystem m a where Maybe (Range 1 500 Int) -> Maybe PagingState -> UserSubsystem m (SearchResult TeamContact) - AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () -- TODO(fisx): move to TeamInvitationSubsystem? (or move AcceptInvitation to UserSubsystem? :) - + -- | (... or does `AcceptTeamInvitation` belong into `TeamInvitationSubsystems`?) + AcceptTeamInvitation :: Local UserId -> PlainTextPassword6 -> InvitationCode -> UserSubsystem m () -- | The following "internal" functions exists to support migration in this susbystem, after the -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () From e0095413d0ca74ab0db6c52396a39c90a38e60fd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:40:49 +0200 Subject: [PATCH 30/40] Move UserSubsystem...checkPassword to AuthenticationSubsystem.verifyPassword. --- .../src/Wire/AuthenticationSubsystem.hs | 3 +++ .../src/Wire/AuthenticationSubsystem/Error.hs | 4 ++++ .../AuthenticationSubsystem/Interpreter.hs | 15 ++++++++++++++- .../src/Wire/UserSubsystem/Error.hs | 4 ---- .../src/Wire/UserSubsystem/Interpreter.hs | 18 ++---------------- .../AuthenticationSubsystem/InterpreterSpec.hs | 10 +++++----- 6 files changed, 28 insertions(+), 26 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs index 9b669979bd8..e4200377d92 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem.hs @@ -18,7 +18,9 @@ module Wire.AuthenticationSubsystem where +import Data.Id import Data.Misc +import Data.Qualified import Imports import Polysemy import Wire.API.User @@ -26,6 +28,7 @@ import Wire.API.User.Password import Wire.UserKeyStore data AuthenticationSubsystem m a where + VerifyPassword :: Local UserId -> PlainTextPassword6 -> AuthenticationSubsystem m () CreatePasswordResetCode :: EmailKey -> AuthenticationSubsystem m () ResetPassword :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword8 -> AuthenticationSubsystem m () -- For testing diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs index 5efede38c26..095bb9dfdbc 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Error.hs @@ -31,6 +31,8 @@ data AuthenticationSubsystemError | AuthenticationSubsystemInvalidPasswordResetCode | AuthenticationSubsystemInvalidPhone | AuthenticationSubsystemAllowListError + | AuthenticationSubsystemMissingAuth + | AuthenticationSubsystemBadCredentials deriving (Eq, Show) instance Exception AuthenticationSubsystemError @@ -43,3 +45,5 @@ authenticationSubsystemErrorToHttpError = AuthenticationSubsystemResetPasswordMustDiffer -> errorToWai @E.ResetPasswordMustDiffer AuthenticationSubsystemInvalidPhone -> errorToWai @E.InvalidPhone AuthenticationSubsystemAllowListError -> errorToWai @E.AllowlistError + AuthenticationSubsystemMissingAuth -> errorToWai @E.MissingAuth + AuthenticationSubsystemBadCredentials -> errorToWai @E.BadCredentials diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 94515b1db6a..25e1c9c6e82 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -39,7 +39,8 @@ import Wire.API.Allowlists qualified as AllowLists import Wire.API.Password import Wire.API.User import Wire.API.User.Password -import Wire.AuthenticationSubsystem +import Wire.AuthenticationSubsystem (AuthenticationSubsystem (..)) +import Wire.AuthenticationSubsystem qualified as Auth import Wire.AuthenticationSubsystem.Error import Wire.EmailSubsystem import Wire.HashPassword @@ -70,10 +71,22 @@ interpretAuthenticationSubsystem :: interpretAuthenticationSubsystem userSubsystemInterpreter = interpret $ userSubsystemInterpreter . \case + VerifyPassword luid password -> verifyPasswordImpl luid password CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey +verifyPasswordImpl :: + ( Member PasswordStore r, + Member (Error AuthenticationSubsystemError) r + ) => + Local UserId -> + PlainTextPassword6 -> + Sem r () +verifyPasswordImpl (tUnqualified -> uid) password = do + p <- lookupHashedPassword uid >>= maybe (throw AuthenticationSubsystemMissingAuth) pure + unless (Wire.API.Password.verifyPassword password p) $ throw AuthenticationSubsystemBadCredentials + maxAttempts :: Int32 maxAttempts = 3 diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 79e54917298..10271115fcb 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -21,8 +21,6 @@ data UserSubsystemError | UserSubsystemInsufficientTeamPermissions | UserSubsystemCannotJoinMultipleTeams | UserSubsystemTooManyTeamMembers - | UserSubsystemMissingAuth - | UserSubsystemBadCredentials | UserSubsystemMissingIdentity | UserSubsystemInvalidActivationCodeWrongUser | UserSubsystemInvalidActivationCodeWrongCode @@ -45,8 +43,6 @@ userSubsystemErrorToHttpError = UserSubsystemInsufficientTeamPermissions -> errorToWai @'E.InsufficientTeamPermissions UserSubsystemCannotJoinMultipleTeams -> errorToWai @E.CannotJoinMultipleTeams UserSubsystemTooManyTeamMembers -> errorToWai @E.TooManyTeamMembers - UserSubsystemMissingAuth -> errorToWai @E.MissingAuth - UserSubsystemBadCredentials -> errorToWai @E.BadCredentials UserSubsystemMissingIdentity -> errorToWai @E.MissingIdentity UserSubsystemInvalidActivationCodeWrongUser -> errorToWai @E.InvalidActivationCodeWrongUser UserSubsystemInvalidActivationCodeWrongCode -> errorToWai @E.InvalidActivationCodeWrongCode diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index d01d62aeb75..1ee5331a694 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -32,7 +32,6 @@ import System.Logger.Message qualified as Log import Wire.API.Federation.API import Wire.API.Federation.API.Brig qualified as FedBrig import Wire.API.Federation.Error -import Wire.API.Password (verifyPassword) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) import Wire.API.Team.Feature @@ -57,7 +56,6 @@ import Wire.IndexedUserStore (IndexedUserStore) import Wire.IndexedUserStore qualified as IndexedUserStore import Wire.IndexedUserStore.Bulk.ElasticSearch (teamSearchVisibilityInbound) import Wire.InvitationCodeStore -import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.Sem.Concurrency import Wire.Sem.Metrics import Wire.Sem.Metrics qualified as Metrics @@ -102,8 +100,7 @@ runUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member InvitationCodeStore r, - Member TinyLog r, - Member PasswordStore r + Member TinyLog r ) => UserSubsystemConfig -> InterpreterFor AuthenticationSubsystem r -> @@ -923,7 +920,6 @@ acceptTeamInvitationImpl :: Member IndexedUserStore r, Member Metrics r, Member Events r, - Member PasswordStore r, Member AuthenticationSubsystem r ) => Local UserId -> @@ -934,10 +930,7 @@ acceptTeamInvitationImpl luid pw code = do mSelfProfile <- getSelfProfileImpl luid let mEmailKey = mkEmailKey <$> (userEmail . selfUser =<< mSelfProfile) mTid = mSelfProfile >>= userTeam . selfUser - -- TODO: This exists to make the warnings go away, this is not supposed to be - -- in final code. We have to implement checkPassword in terms of Auth subsystem. - forM_ mEmailKey $ createPasswordResetCode - checkPassword + verifyPassword luid pw inv <- internalFindTeamInvitationImpl mEmailKey code let tid = inv.teamId let minvmeta = (,inv.createdAt) <$> inv.createdBy @@ -951,13 +944,6 @@ acceptTeamInvitationImpl luid pw code = do deleteInvitation inv.teamId inv.invitationId syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) - where - checkPassword = do - p <- - (lookupHashedPassword . tUnqualified $ luid) - >>= maybe (throw UserSubsystemMissingAuth) pure - unless (verifyPassword pw p) $ - throw UserSubsystemBadCredentials -- toInvitationError :: RegisterError -> UserSubsystemError -- toInvitationError = \case diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 83d60544ae8..4a7572ec306 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -18,7 +18,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.Allowlists (AllowlistEmailDomains (AllowlistEmailDomains)) -import Wire.API.Password +import Wire.API.Password as Password import Wire.API.User import Wire.API.User qualified as User import Wire.API.User.Auth @@ -91,7 +91,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> - (fmap (verifyPassword newPassword) newPasswordHash === Just True) + (fmap (Password.verifyPassword newPassword) newPasswordHash === Just True) .&&. (cookiesAfterReset === []) prop "password reset should work with the returned password reset key" $ @@ -110,7 +110,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> - (fmap (verifyPassword newPassword) newPasswordHash === Just True) + (fmap (Password.verifyPassword newPassword) newPasswordHash === Just True) .&&. (cookiesAfterReset === []) prop "reset code is not generated when email is not in allow list" $ @@ -167,7 +167,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do resetPassword (PasswordResetEmailIdentity email) code newPassword (,mCaughtExc) <$> lookupHashedPassword uid - in (fmap (verifyPassword newPassword) newPasswordHash === Just True) + in (fmap (Password.verifyPassword newPassword) newPasswordHash === Just True) .&&. (mCaughtException === Nothing) prop "reset code is not accepted after expiry" $ @@ -269,7 +269,7 @@ instance Arbitrary Upto4 where verifyPasswordProp :: PlainTextPassword8 -> Maybe Password -> Property verifyPasswordProp plainTextPassword passwordHash = counterexample ("Password doesn't match, plainText=" <> show plainTextPassword <> ", passwordHash=" <> show passwordHash) $ - fmap (verifyPassword plainTextPassword) passwordHash == Just True + fmap (Password.verifyPassword plainTextPassword) passwordHash == Just True hashAndUpsertPassword :: (Member PasswordStore r, Member HashPassword r) => UserId -> PlainTextPassword8 -> Sem r () hashAndUpsertPassword uid password = From 8e2697c286720fdfeb2856b6c0e5169e28350b3e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:41:50 +0200 Subject: [PATCH 31/40] rm dead comments. --- .../wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 1ee5331a694..c0cfd1e02d2 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -944,11 +944,3 @@ acceptTeamInvitationImpl luid pw code = do deleteInvitation inv.teamId inv.invitationId syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) - --- toInvitationError :: RegisterError -> UserSubsystemError --- toInvitationError = \case --- RegisterErrorMissingIdentity -> UserSubsystemMissingIdentity --- RegisterErrorInvalidActivationCodeWrongUser -> UserSubsystemInvalidActivationCodeWrongUser --- RegisterErrorInvalidActivationCodeWrongCode -> UserSubsystemInvalidActivationCodeWrongCode --- RegisterErrorInvalidInvitationCode -> UserSubsystemInvalidInvitationCode --- _ -> UserSubsystemInvitationNotFound From 3ed3901b993db50cd2a21f4d0fc905c2d971b127 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 16:56:14 +0200 Subject: [PATCH 32/40] Cleanup. --- services/brig/src/Brig/API/Internal.hs | 8 ++++-- services/brig/src/Brig/API/Public.hs | 2 +- services/brig/src/Brig/Team/API.hs | 39 +++++++++++++------------- 3 files changed, 27 insertions(+), 22 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c1bead99444..33f79d6ec34 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -65,6 +65,7 @@ import Data.Time.Clock.System import Imports hiding (head) import Network.Wai.Utilities as Utilities import Polysemy +import Polysemy.Error qualified import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) @@ -113,6 +114,7 @@ import Wire.UserKeyStore import Wire.UserStore import Wire.UserSubsystem import Wire.UserSubsystem qualified as UserSubsystem +import Wire.UserSubsystem.Error import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -141,7 +143,8 @@ servantSitemap :: Member PasswordResetCodeStore r, Member PropertySubsystem r, Member (Input (Local ())) r, - Member IndexedUserStore r + Member IndexedUserStore r, + Member (Polysemy.Error.Error UserSubsystemError) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -243,6 +246,7 @@ teamsAPI :: Member InvitationCodeStore r, Member TeamInvitationSubsystem r, Member UserSubsystem r, + Member (Polysemy.Error.Error UserSubsystemError) r, Member Events r, Member (Input (Local ())) r, Member IndexedUserStore r @@ -251,7 +255,7 @@ teamsAPI :: teamsAPI = Named @"updateSearchVisibilityInbound" (lift . liftSem . updateTeamSearchVisibilityInbound) :<|> Named @"get-invitation-by-email" Team.getInvitationByEmail - :<|> Named @"get-invitation-code" Team.getInvitationCode + :<|> Named @"get-invitation-code" (\tid iid -> lift . liftSem $ Team.getInvitationCode tid iid) :<|> Named @"suspend-team" Team.suspendTeam :<|> Named @"unsuspend-team" Team.unsuspendTeam :<|> Named @"team-size" (lift . liftSem . getTeamSize) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 09c3cd94c3d..fc460854766 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -155,6 +155,7 @@ import Wire.Events (Events) import Wire.FederationConfigStore (FederationConfigStore) import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.IndexedUserStore (IndexedUserStore) import Wire.InvitationCodeStore import Wire.NotificationSubsystem import Wire.PasswordResetCodeStore (PasswordResetCodeStore) @@ -174,7 +175,6 @@ import Wire.UserSubsystem.Error import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem -import Wire.IndexedUserStore (IndexedUserStore) -- User API ----------------------------------------------------------- diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 08a8f666edb..8b13deab2ef 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -55,8 +55,6 @@ 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 import Wire.API.Routes.Internal.Brig (FoundInvitationCode (FoundInvitationCode)) import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Named @@ -97,13 +95,13 @@ servantAPI :: ) => ServerT TeamsAPI (Handler r) servantAPI = - Named @"send-team-invitation" (\luid tid invreq -> lift . liftSem $ inviteUser luid tid invreq) -- TODO: move 'lift . liftSem' to the outside of 'servantAPI' + Named @"send-team-invitation" (\luid tid invreq -> lift . liftSem $ inviteUser luid tid invreq) :<|> Named @"get-team-invitations" (\u t inv s -> lift . liftSem $ listInvitations u t inv s) :<|> Named @"get-team-invitation" (\u t inv -> lift . liftSem $ getInvitation u t inv) :<|> Named @"delete-team-invitation" (\u t inv -> lift . liftSem $ deleteInvitation u t inv) - :<|> Named @"get-team-invitation-info" getInvitationByCode + :<|> Named @"get-team-invitation-info" (lift . liftSem . getInvitationByCode) :<|> Named @"head-team-invitations" (lift . liftSem . headInvitationByEmail) - :<|> Named @"get-team-size" teamSizePublic + :<|> Named @"get-team-size" (\uid tid -> lift . liftSem $ teamSizePublic uid tid) :<|> Named @"accept-team-invitation" (\luid req -> lift $ liftSem $ acceptTeamInvitation luid req.password req.code) teamSizePublic :: @@ -113,21 +111,22 @@ teamSizePublic :: ) => UserId -> TeamId -> - (Handler r) TeamSize -teamSizePublic uid tid = - lift . liftSem $ do - -- limit this to team admins to reduce risk of involuntary DOS attacks - ensurePermissions uid tid [AddTeamMember] - getTeamSize tid + Sem r TeamSize +teamSizePublic uid tid = do + -- limit this to team admins to reduce risk of involuntary DOS attacks + ensurePermissions uid tid [AddTeamMember] + getTeamSize tid getInvitationCode :: - (Member Store.InvitationCodeStore r) => + ( Member Store.InvitationCodeStore r, + Member (Error UserSubsystemError) r + ) => TeamId -> InvitationId -> - (Handler r) FoundInvitationCode + Sem r FoundInvitationCode getInvitationCode t r = do - inv <- lift . liftSem $ Store.lookupInvitation t r - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode . (.code)) inv + inv <- Store.lookupInvitation t r + maybe (throw UserSubsystemInvalidInvitationCode) (pure . FoundInvitationCode . (.code)) inv data CreateInvitationInviter = CreateInvitationInviter { inviterUid :: UserId, @@ -351,12 +350,14 @@ isPersonalUser uke = do && isNothing account.accountUser.userTeam getInvitationByCode :: - (Member Store.InvitationCodeStore r) => + ( Member Store.InvitationCodeStore r, + Member (Error UserSubsystemError) r + ) => InvitationCode -> - (Handler r) Public.Invitation + Sem r Public.Invitation getInvitationByCode c = do - inv <- lift . liftSem $ Store.lookupInvitationByCode c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv + inv <- Store.lookupInvitationByCode c + maybe (throw UserSubsystemInvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => From 2134f369303f71c47a7bdb670fd29f892e73735b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 17:08:55 +0200 Subject: [PATCH 33/40] generate nix packages. --- libs/types-common/default.nix | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index 5d16d0cfaf0..3b39ec41402 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -19,6 +19,7 @@ , cryptohash-sha1 , crypton , currency-codes +, email-validate , generic-random , gitignoreSource , hashable @@ -79,6 +80,7 @@ mkDerivation { cryptohash-sha1 crypton currency-codes + email-validate generic-random hashable http-api-data From 8f3d9c8ee05620cbd1e52ba7c4b4770694249905 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 17:12:15 +0200 Subject: [PATCH 34/40] hlint. --- libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs | 1 - services/brig/src/Brig/API/User.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs index f6e698380ef..892450e3354 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs @@ -21,4 +21,3 @@ teamInvitationErrorToHttpError = TooManyTeamInvitations -> errorToWai @E.TooManyTeamInvitations TeamInvitationBlacklistedEmail -> errorToWai @E.BlacklistedEmail TeamInvitationEmailTaken -> errorToWai @E.EmailExists - diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index c2d281249a8..7719f808ac0 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -65,7 +65,7 @@ module Brig.API.User blacklistInsert, -- * Utilities - fetchUserIdentity + fetchUserIdentity, ) where From ea8d3accaa5d796e99f21cb02af17558b47dd445 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 17:15:33 +0200 Subject: [PATCH 35/40] New TODOs. --- services/brig/src/Brig/Team/API.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 8b13deab2ef..45f98c24414 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -229,6 +229,9 @@ listInvitations uid tid startingId mSize = do invs <- toInvitations storedInvs pure $ InvitationList invs False where + -- TODO: fix this in this PR? + -- TODO: did we write enough tests to wire-subsystems? + -- To create the correct team invitation URL, we need to detect whether the invited account already exists. -- Optimization: if url is not to be shown, do not check for existing personal user. toInvitationHack :: ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation From ac5fb59858b7f026256bbe1ec0d625021aed8f30 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 25 Sep 2024 17:25:23 +0200 Subject: [PATCH 36/40] Cleanup. --- libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs index 10271115fcb..90a2d39a888 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Error.hs @@ -40,7 +40,7 @@ userSubsystemErrorToHttpError = UserSubsystemHandleExists -> errorToWai @E.HandleExists UserSubsystemInvalidHandle -> errorToWai @E.InvalidHandle UserSubsystemHandleManagedByScim -> errorToWai @E.HandleManagedByScim - UserSubsystemInsufficientTeamPermissions -> errorToWai @'E.InsufficientTeamPermissions + UserSubsystemInsufficientTeamPermissions -> errorToWai @E.InsufficientTeamPermissions UserSubsystemCannotJoinMultipleTeams -> errorToWai @E.CannotJoinMultipleTeams UserSubsystemTooManyTeamMembers -> errorToWai @E.TooManyTeamMembers UserSubsystemMissingIdentity -> errorToWai @E.MissingIdentity From 073e646082a38c08a44b1efe3a5b08220d632c37 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 26 Sep 2024 09:26:34 +0200 Subject: [PATCH 37/40] Fixup --- .../src/Wire/AuthenticationSubsystem/Interpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 25e1c9c6e82..fc13fb05a01 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -40,7 +40,6 @@ import Wire.API.Password import Wire.API.User import Wire.API.User.Password import Wire.AuthenticationSubsystem (AuthenticationSubsystem (..)) -import Wire.AuthenticationSubsystem qualified as Auth import Wire.AuthenticationSubsystem.Error import Wire.EmailSubsystem import Wire.HashPassword From 01b06b619209582f9f99a01f203d0ddc90e92d00 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 26 Sep 2024 09:51:03 +0200 Subject: [PATCH 38/40] Add clarifying comments. --- libs/wire-subsystems/src/Wire/EmailSubsystem.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs index 9d4ef5bd22c..a8fa0f57b5e 100644 --- a/libs/wire-subsystems/src/Wire/EmailSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EmailSubsystem.hs @@ -23,7 +23,9 @@ data EmailSubsystem m a where SendTeamActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m () SendTeamDeletionVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m () SendUpgradePersonalToTeamConfirmationEmail :: EmailAddress -> Name -> Text -> Locale -> EmailSubsystem m () + -- | send invitation to an unknown email address. SendTeamInvitationMail :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text + -- | send invitation to an email address associated with a personal user account. SendTeamInvitationMailPersonalUser :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text makeSem ''EmailSubsystem From 315bc2cd50eeef81939cc76a15ae0b99a8e7f3cb Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 26 Sep 2024 10:02:05 +0200 Subject: [PATCH 39/40] Changelog. --- ...ns-for-personal-users-into-teams-to-wire-subsystems | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 changelog.d/5-internal/WPB-11217-move-code-for-accepting-invitations-for-personal-users-into-teams-to-wire-subsystems diff --git a/changelog.d/5-internal/WPB-11217-move-code-for-accepting-invitations-for-personal-users-into-teams-to-wire-subsystems b/changelog.d/5-internal/WPB-11217-move-code-for-accepting-invitations-for-personal-users-into-teams-to-wire-subsystems new file mode 100644 index 00000000000..0d0f46a242f --- /dev/null +++ b/changelog.d/5-internal/WPB-11217-move-code-for-accepting-invitations-for-personal-users-into-teams-to-wire-subsystems @@ -0,0 +1,10 @@ +Move some invitation handling from brig to wire-subsystems. + +- introduce cyclically dependent effects: UserSubsystem, AuthenticationSubsystem (see Brig.CanonicalInterpreter). +- introduce TeamInvitationSubsystem with operations inviteUser, internalCreateInvitation. +- add verifyPassword to AuthenticationSubsystem. +- add sendInvitationMail, sendInvitationMailPersonalUser to EmailSubsystem. +- add getTeamSize to IndexedUserStore (this is morally internal to wire-subsystems, and making another ES subsystem would mean adding a lot of code everywhere). +- add updateUserTeam to UserStore. +- add acceptTeamInvitation, internalFindTeamInvitation to UserSubsystem. +- make a few small rest api handlers in brig polysemic (Handler -> Sem). From f85268d4839f19f40bc53c856998cc9aad8a0a04 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 26 Sep 2024 10:05:32 +0200 Subject: [PATCH 40/40] post-pone TODOs. --- services/brig/src/Brig/Team/API.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 45f98c24414..8b13deab2ef 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -229,9 +229,6 @@ listInvitations uid tid startingId mSize = do invs <- toInvitations storedInvs pure $ InvitationList invs False where - -- TODO: fix this in this PR? - -- TODO: did we write enough tests to wire-subsystems? - -- To create the correct team invitation URL, we need to detect whether the invited account already exists. -- Optimization: if url is not to be shown, do not check for existing personal user. toInvitationHack :: ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation