From d1becb0b0d25b4e96d0bc2a6cb6a3d9cb6635a20 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 10 Jan 2025 16:09:13 +0100 Subject: [PATCH 01/48] Modify POST /teams/{id}/invitations to check for domain configuration [WIP] --- .../src/Wire/EnterpriseLoginSubsystem.hs | 1 + .../Wire/EnterpriseLoginSubsystem/Error.hs | 4 ++ .../EnterpriseLoginSubsystem/Interpreter.hs | 45 +++++++++++++++++++ 3 files changed, 50 insertions(+) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index 8d839eb50cf..aa380c1afaf 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -14,5 +14,6 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration + GuardEmailDomainRegistrationState :: Domain -> EnterpriseLoginSubsystem m () makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 9392c41f4a4..466a222ea9f 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -12,6 +12,8 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError + | EnterpriseLoginSubsystemGuardFailed LText + | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError @@ -25,3 +27,5 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnlockError -> Wai.mkError status409 "unlock-error" "Domain can only be unlocked from a locked state" EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" + EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) + EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 5eda2649349..c832ce0cfa9 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -56,6 +56,7 @@ runEnterpriseLoginSubsystem = interpret $ UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update DeleteDomain domain -> deleteDomainImpl domain GetDomainRegistration domain -> getDomainRegistrationImpl domain + GuardEmailDomainRegistrationState domain -> guardEmailDomainRegistrationStateImpl domain deleteDomainImpl :: ( Member DomainRegistrationStore r, @@ -340,3 +341,47 @@ sendAuditMail url subject mBefore mAfter = do for_ mConfig $ \config -> do let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog sendMail mail + +guardEmailDomainRegistrationState :: + forall r. + ( Member DomainRegistrationStore r, + Member (Error EnterpriseLoginSubsystemError) r + ) => + TeamId -> + EmailAddress -> + Sem r () +guardEmailDomainRegistrationState tid email = do + dom <- do + txt <- case encodeUtf8' $ Email.domainPart email of + Right t -> pure t + Left msg -> EnterpriseLoginSubsystemGuardInvalidDomain msg + + case mkDomain txt of + Right d -> pure d + Left msg -> EnterpriseLoginSubsystemGuardInvalidDomain msg + + let ok = pure () + nope = throw . EnterpriseLoginSubsystemGuardFailed + + go :: StoredDomainRegistration -> Sem r () + go reg = do + -- fail if domain-redirect is set to no-registration, or + case reg.domainRedirect of + None -> ok + Locked -> ok + SSO SAML.IdPId -> ok + Backend HttpsUrl -> ok + NoRegistration -> nope "`domain_redirect` is set to `no-registration`" + PreAuthorized -> ok + + -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not + -- the team of the inviter + case reg.teamInvite of + Allowed -> ok + NotAllowed -> nope "`teamInvite` is set to `not-allowed`" + Team allowedTid -> + if allowedTid == tid + then ok + else nope $ "`teamInvite` is restricted to another team." + + mapM_ go (Store.lookup dom) From 15655bac8b4b9fd04a42ae98d4d01d00a1eb14a4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 10 Jan 2025 16:15:08 +0100 Subject: [PATCH 02/48] double-WIP. (up next: write a failing test *in wire-subsystems*) --- .../src/Wire/TeamInvitationSubsystem/Interpreter.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 6916ffcb08e..1513f06603c 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -70,6 +70,7 @@ inviteUserImpl :: Member TinyLog r, Member Random r, Member InvitationStore r, + -- Member EnterpriseLoginSubsystem r, Member (Input TeamInvitationSubsystemConfig) r, Member Now r, Member EmailSubsystem r @@ -80,9 +81,10 @@ inviteUserImpl :: 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 + -- guardEmailDomainRegistrationState request.inviteeEmail inviterEmail <- note TeamInvitationNoEmail =<< runMaybeT do From cad63d1720997cd864e1cd4aa16d427db544637c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 10 Jan 2025 16:22:10 +0000 Subject: [PATCH 03/48] make code compile --- .../src/Wire/EnterpriseLoginSubsystem.hs | 4 +- .../EnterpriseLoginSubsystem/Interpreter.hs | 79 +++++++++---------- libs/wire-subsystems/wire-subsystems.cabal | 1 + 3 files changed, 43 insertions(+), 41 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index aa380c1afaf..b84271f517d 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -3,7 +3,9 @@ module Wire.EnterpriseLoginSubsystem where import Data.Domain +import Data.Id import Polysemy +import Text.Email.Parser import Wire.API.EnterpriseLogin data EnterpriseLoginSubsystem m a where @@ -14,6 +16,6 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationState :: Domain -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationState :: TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index c832ce0cfa9..3ee52c8a844 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -11,12 +11,14 @@ where import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson import Data.ByteString.Conversion (toByteString') -import Data.Domain (Domain, domainText) +import Data.Domain (Domain, domainText, mkDomain) import Data.Id import Data.Misc (HttpsUrl (..)) +import Data.Text.Encoding as T import Data.Text.Internal.Builder (fromLazyText, fromText, toLazyText) +import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder (Builder) -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Lazy.Encoding as LT import Imports hiding (lookup) import Network.Mail.Mime (Address (Address), Mail (mailHeaders, mailParts, mailTo), emptyMail, plainPart) import Polysemy @@ -26,6 +28,7 @@ import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Log +import Text.Email.Parser qualified as Email import Wire.API.EnterpriseLogin import Wire.API.User.EmailAddress (EmailAddress, fromEmail) import Wire.DomainRegistrationStore @@ -56,7 +59,7 @@ runEnterpriseLoginSubsystem = interpret $ UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update DeleteDomain domain -> deleteDomainImpl domain GetDomainRegistration domain -> getDomainRegistrationImpl domain - GuardEmailDomainRegistrationState domain -> guardEmailDomainRegistrationStateImpl domain + GuardEmailDomainRegistrationState tid email -> guardEmailDomainRegistrationStateImpl tid email deleteDomainImpl :: ( Member DomainRegistrationStore r, @@ -329,12 +332,12 @@ sendAuditMail url subject mBefore mAfter = do toLazyText $ url <> " called;\nOld value:\n" - <> fromLazyText (decodeUtf8 (maybe "null" Aeson.encodePretty mBefore)) + <> fromLazyText (LT.decodeUtf8 (maybe "null" Aeson.encodePretty mBefore)) <> "\nNew value:\n" - <> fromLazyText (decodeUtf8 (maybe "null" Aeson.encodePretty mAfter)) + <> fromLazyText (LT.decodeUtf8 (maybe "null" Aeson.encodePretty mAfter)) Log.info $ Log.msg (Log.val "Domain registration audit log") - . Log.field "url" (encodeUtf8 $ toLazyText url) + . Log.field "url" (LT.encodeUtf8 $ toLazyText url) . Log.field "old_value" (maybe "null" Aeson.encode mBefore) . Log.field "new_value" (maybe "null" Aeson.encode mAfter) mConfig <- input @@ -342,46 +345,42 @@ sendAuditMail url subject mBefore mAfter = do let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog sendMail mail -guardEmailDomainRegistrationState :: +guardEmailDomainRegistrationStateImpl :: forall r. ( Member DomainRegistrationStore r, - Member (Error EnterpriseLoginSubsystemError) r + Member (Error EnterpriseLoginSubsystemError) r, + Member TinyLog r ) => TeamId -> EmailAddress -> Sem r () -guardEmailDomainRegistrationState tid email = do +guardEmailDomainRegistrationStateImpl tid email = do dom <- do - txt <- case encodeUtf8' $ Email.domainPart email of - Right t -> pure t - Left msg -> EnterpriseLoginSubsystemGuardInvalidDomain msg - - case mkDomain txt of + case mkDomain $ T.decodeUtf8 $ Email.domainPart email of Right d -> pure d - Left msg -> EnterpriseLoginSubsystemGuardInvalidDomain msg - - let ok = pure () - nope = throw . EnterpriseLoginSubsystemGuardFailed + Left msg -> throw $ EnterpriseLoginSubsystemGuardInvalidDomain (LT.pack msg) - go :: StoredDomainRegistration -> Sem r () - go reg = do - -- fail if domain-redirect is set to no-registration, or - case reg.domainRedirect of - None -> ok - Locked -> ok - SSO SAML.IdPId -> ok - Backend HttpsUrl -> ok - NoRegistration -> nope "`domain_redirect` is set to `no-registration`" - PreAuthorized -> ok - - -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not - -- the team of the inviter - case reg.teamInvite of - Allowed -> ok - NotAllowed -> nope "`teamInvite` is set to `not-allowed`" - Team allowedTid -> - if allowedTid == tid - then ok - else nope $ "`teamInvite` is restricted to another team." - - mapM_ go (Store.lookup dom) + mReg <- tryGetDomainRegistrationImpl dom + case mReg of + Nothing -> error "todo(leif): what should happen here?" + Just reg -> do + -- fail if domain-redirect is set to no-registration, or + case reg.domainRedirect of + None -> ok + Locked -> ok + SSO _ -> ok + Backend _ -> ok + NoRegistration -> nope "`domain_redirect` is set to `no-registration`" + PreAuthorized -> ok + -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not + -- the team of the inviter + case reg.teamInvite of + Allowed -> ok + NotAllowed -> nope "`teamInvite` is set to `not-allowed`" + Team allowedTid -> + if allowedTid == tid + then ok + else nope $ "`teamInvite` is restricted to another team." + where + ok = pure () + nope = throw . EnterpriseLoginSubsystemGuardFailed diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 9e2652d6605..02a4b9c9fbf 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -173,6 +173,7 @@ library , currency-codes , data-default , data-timeout + , email-validate , errors , exceptions , extended From 364bf2b56a17d1109398d85a4d04712b9ee4c509 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 09:20:23 +0000 Subject: [PATCH 04/48] handle (non-)existingi user flow --- .../src/Wire/EnterpriseLoginSubsystem.hs | 4 +- .../Wire/EnterpriseLoginSubsystem/Error.hs | 5 ++- .../EnterpriseLoginSubsystem/Interpreter.hs | 45 ++++++++++--------- 3 files changed, 30 insertions(+), 24 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index b84271f517d..5bcbcf6cd45 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -8,6 +8,8 @@ import Polysemy import Text.Email.Parser import Wire.API.EnterpriseLogin +data InvitationFlow = ExistingUser | NewUser + data EnterpriseLoginSubsystem m a where LockDomain :: Domain -> EnterpriseLoginSubsystem m () UnlockDomain :: Domain -> EnterpriseLoginSubsystem m () @@ -16,6 +18,6 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationState :: TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationState :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 466a222ea9f..b585b233a66 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -28,4 +28,7 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) - EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) + EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) + where + status423 :: Status + status423 = mkStatus 423 "Locked" diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 3ee52c8a844..38f4b2edcc6 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -59,7 +59,7 @@ runEnterpriseLoginSubsystem = interpret $ UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update DeleteDomain domain -> deleteDomainImpl domain GetDomainRegistration domain -> getDomainRegistrationImpl domain - GuardEmailDomainRegistrationState tid email -> guardEmailDomainRegistrationStateImpl tid email + GuardEmailDomainRegistrationState flow tid email -> guardEmailDomainRegistrationStateImpl flow tid email deleteDomainImpl :: ( Member DomainRegistrationStore r, @@ -351,36 +351,37 @@ guardEmailDomainRegistrationStateImpl :: Member (Error EnterpriseLoginSubsystemError) r, Member TinyLog r ) => + InvitationFlow -> TeamId -> EmailAddress -> Sem r () -guardEmailDomainRegistrationStateImpl tid email = do +guardEmailDomainRegistrationStateImpl invitationFlow tid email = do dom <- do case mkDomain $ T.decodeUtf8 $ Email.domainPart email of Right d -> pure d Left msg -> throw $ EnterpriseLoginSubsystemGuardInvalidDomain (LT.pack msg) mReg <- tryGetDomainRegistrationImpl dom - case mReg of - Nothing -> error "todo(leif): what should happen here?" - Just reg -> do - -- fail if domain-redirect is set to no-registration, or - case reg.domainRedirect of - None -> ok - Locked -> ok - SSO _ -> ok - Backend _ -> ok - NoRegistration -> nope "`domain_redirect` is set to `no-registration`" - PreAuthorized -> ok - -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not - -- the team of the inviter - case reg.teamInvite of - Allowed -> ok - NotAllowed -> nope "`teamInvite` is set to `not-allowed`" - Team allowedTid -> - if allowedTid == tid - then ok - else nope $ "`teamInvite` is restricted to another team." + for_ mReg $ \reg -> do + -- fail if domain-redirect is set to no-registration, or + case reg.domainRedirect of + None -> ok + Locked -> ok + SSO _ -> ok + Backend _ -> ok + NoRegistration -> case invitationFlow of + ExistingUser -> nope "`domain_redirect` is set to `no-registration`" + NewUser -> ok + PreAuthorized -> ok + -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not + -- the team of the inviter + case reg.teamInvite of + Allowed -> ok + NotAllowed -> nope "`teamInvite` is set to `not-allowed`" + Team allowedTid -> + if allowedTid == tid + then ok + else nope $ "`teamInvite` is restricted to another team." where ok = pure () nope = throw . EnterpriseLoginSubsystemGuardFailed From 65eb32a180ba324435c89939a938fac8520a87dd Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 09:27:21 +0000 Subject: [PATCH 05/48] add guard to invitation handler --- .../Wire/TeamInvitationSubsystem/Interpreter.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 1513f06603c..2c3ec9f7c84 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -25,6 +25,8 @@ import Wire.API.Team.Role import Wire.API.User import Wire.Arbitrary import Wire.EmailSubsystem +import Wire.EnterpriseLoginSubsystem +import Wire.EnterpriseLoginSubsystem qualified as ELS import Wire.GalleyAPIAccess hiding (AddTeamMember) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.InvitationStore (InvitationStore, StoredInvitation) @@ -54,7 +56,8 @@ runTeamInvitationSubsystem :: Member Random r, Member InvitationStore r, Member Now r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member EnterpriseLoginSubsystem r ) => TeamInvitationSubsystemConfig -> InterpreterFor TeamInvitationSubsystem r @@ -70,10 +73,10 @@ inviteUserImpl :: Member TinyLog r, Member Random r, Member InvitationStore r, - -- Member EnterpriseLoginSubsystem r, Member (Input TeamInvitationSubsystemConfig) r, Member Now r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member EnterpriseLoginSubsystem r ) => Local UserId -> TeamId -> @@ -84,7 +87,6 @@ inviteUserImpl luid tid request = do let inviteePerms = Teams.rolePermissions inviteeRole ensurePermissionToAddUser (tUnqualified luid) tid inviteePerms - -- guardEmailDomainRegistrationState request.inviteeEmail inviterEmail <- note TeamInvitationNoEmail =<< runMaybeT do @@ -114,7 +116,8 @@ createInvitation' :: Member Random r, Member (Input TeamInvitationSubsystemConfig) r, Member Now r, - Member EmailSubsystem r + Member EmailSubsystem r, + Member EnterpriseLoginSubsystem r ) => TeamId -> Maybe InvitationId -> @@ -139,6 +142,9 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe && isNothing user.userTeam -> pure True | otherwise -> throw TeamInvitationEmailTaken + let flow = if isPersonalUserMigration then ExistingUser else ELS.NewUser + -- todo(leif): remove after writing the test for it + when False $ guardEmailDomainRegistrationState flow tid email maxSize <- maxTeamSize <$> input pending <- Store.countInvitations tid From 68701c0cb082863ac0e2e3858088e3596bfae133 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 09:51:53 +0000 Subject: [PATCH 06/48] domain registration store in mem interpreter --- libs/wire-subsystems/test/Main.hs | 2 +- .../Wire/MockInterpreters/DomainRegistrationStore.hs | 12 ++++++++++++ libs/wire-subsystems/wire-subsystems.cabal | 1 + 3 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs index 96392ca769d..4f23fff6c2b 100644 --- a/libs/wire-subsystems/test/Main.hs +++ b/libs/wire-subsystems/test/Main.hs @@ -1,7 +1,7 @@ module Main where import Imports -import Spec +import Spec qualified import Test.Hspec main :: IO () diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs new file mode 100644 index 00000000000..152e0e0da2a --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs @@ -0,0 +1,12 @@ +module Wire.MockInterpreters.DomainRegistrationStore where + +import Imports +import Polysemy +import Polysemy.State +import Wire.DomainRegistrationStore + +inMemoryDomainRegistrationStoreInterpreter :: (Member (State [StoredDomainRegistration]) r) => InterpreterFor DomainRegistrationStore r +inMemoryDomainRegistrationStoreInterpreter = interpret $ \case + Upsert dr -> modify ((dr :) . filter ((/= domain dr) . domain)) + Lookup d -> gets (find ((== d) . domain)) + Delete d -> modify (filter ((/= d) . domain)) diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 02a4b9c9fbf..222abecedab 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -246,6 +246,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.BlockListStore + Wire.MockInterpreters.DomainRegistrationStore Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.Error Wire.MockInterpreters.Events From b6febdd499a3c2552de78e02024d86a0f5e1b2e6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 13 Jan 2025 11:43:45 +0100 Subject: [PATCH 07/48] wip --- .../InterpreterSpec.hs | 79 +++++++++++++++++++ 1 file changed, 79 insertions(+) create mode 100644 libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..f3a5ea18b73 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Wire.EnterpriseLoginSubsystemSpec where + +import Data.Domain +import Data.Id +import Polysemy +import Text.Email.Parser +import Wire.API.EnterpriseLogin +import Wire.API.EnterpriseLogin.Interpreter +import Wire.MockInterpreters.DomainRegistrationStore +import Wire.MockInterpreters.EmailSubsystem +import Wire.Sem.Logger.TinyLog + + +runDependencies :: Sem '[ DomainRegistrationStore, + Error EnterpriseLoginSubsystemError, + TinyLog, + Input (Maybe EnterpriseLoginSubsystemConfig), + EmailSending + ] a -> Either e a +runDependencies = + run + . emailSubsystemInterpreter + . runInput (pure Nothing) + . discardTinyLogs + . runError + . inMemoryDomainRegistrationStoreInterpreter + +spec :: Spec +spec = describe "EnterpriseLoginSubsystem" $ do + describe "LockDomain" pending + describe "UnlockDomain" pending + describe "PreAuthorizeDomain" pending + describe "UnAuthorizeDomain" pending + describe "UpdateDomainRegistration" pending + describe "DeleteDomain" pending + + describe "GuardEmailDomainRegistrationState" $ do + let testTeamInvitation fun = it "team-invitation" $ do + outcome <- runDependencies . runEnterpriseLoginSubsystem $ do + upsert + fun + case (.teamInvite) <$> outcome of + Allowed -> ok + NotAllowed -> nope "`teamInvite` is set to `not-allowed`" + Team allowedTid -> + if allowedTid == tid + then ok + else nope $ "`teamInvite` is restricted to another team." + + anyTeam = Id "74d17a68-d196-11ef-934c-2b0e41bf5418" + anyEmailAddress = unsafeEmailAddress "me" "example.com" + + context "invite new user" $ do + let fun = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress + + it "no entry in enterprise login table -> ok" $ do + fun `shouldReturn () + + it "domain-redirect" $ for [minBound ..] \_ -> do + -- write to mock table or something. (also team invite entry) + fun `shouldReturn` () + testTeamInvitation fun + + context "invite existing user" $ do + let fun = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress + it "no entry in enterprise login table -> ok" $ pending + it "domain-redirect" + $ for [minBound ..] \domRegTag -> do + -- write to mock table or something. (also team invite entry) + case domRegTag of + None -> ok + Locked -> ok + SSO _ -> ok + Backend _ -> ok + NoRegistration -> nope "`domain_redirect` is set to `no-registration`" + PreAuthorized -> ok + testTeamInvitation fun From 8cba788f99cdf90785369319c8a7cf398daa96f0 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 12:26:49 +0000 Subject: [PATCH 08/48] make tests compile and pass --- libs/wire-subsystems/default.nix | 3 + libs/wire-subsystems/test/Main.hs | 2 +- .../InterpreterSpec.hs | 153 ++++++++++++------ libs/wire-subsystems/wire-subsystems.cabal | 2 + 4 files changed, 110 insertions(+), 50 deletions(-) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index ac1b63bb452..f5c755c2ab3 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -26,6 +26,7 @@ , currency-codes , data-default , data-timeout +, email-validate , errors , exceptions , extended @@ -117,6 +118,7 @@ mkDerivation { currency-codes data-default data-timeout + email-validate errors exceptions extended @@ -206,6 +208,7 @@ mkDerivation { tinylog transformers types-common + uuid wire-api wire-api-federation ]; diff --git a/libs/wire-subsystems/test/Main.hs b/libs/wire-subsystems/test/Main.hs index 4f23fff6c2b..96392ca769d 100644 --- a/libs/wire-subsystems/test/Main.hs +++ b/libs/wire-subsystems/test/Main.hs @@ -1,7 +1,7 @@ module Main where import Imports -import Spec qualified +import Spec import Test.Hspec main :: IO () diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index f3a5ea18b73..f599ef7602b 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -1,79 +1,134 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Wire.EnterpriseLoginSubsystemSpec where +module Wire.EnterpriseLoginSubsystem.InterpreterSpec where import Data.Domain import Data.Id +import Data.UUID qualified as UUID +import Imports import Polysemy -import Text.Email.Parser +import Polysemy.Error +import Polysemy.Input +import Polysemy.State +import Polysemy.TinyLog +import Test.Hspec import Wire.API.EnterpriseLogin -import Wire.API.EnterpriseLogin.Interpreter +import Wire.API.User.EmailAddress +import Wire.DomainRegistrationStore +import Wire.EmailSending +import Wire.EnterpriseLoginSubsystem +import Wire.EnterpriseLoginSubsystem.Error +import Wire.EnterpriseLoginSubsystem.Interpreter import Wire.MockInterpreters.DomainRegistrationStore -import Wire.MockInterpreters.EmailSubsystem import Wire.Sem.Logger.TinyLog - -runDependencies :: Sem '[ DomainRegistrationStore, +runDependencies :: + Sem + '[ DomainRegistrationStore, Error EnterpriseLoginSubsystemError, TinyLog, Input (Maybe EnterpriseLoginSubsystemConfig), EmailSending - ] a -> Either e a + ] + a -> + Either EnterpriseLoginSubsystemError a runDependencies = run - . emailSubsystemInterpreter - . runInput (pure Nothing) + . emailSendingInterpreter + . runInputConst Nothing . discardTinyLogs . runError + . evalState mempty . inMemoryDomainRegistrationStoreInterpreter + . raiseUnder + +emailSendingInterpreter :: InterpreterFor EmailSending r +emailSendingInterpreter = + interpret \case + SendMail _ -> pure () spec :: Spec spec = describe "EnterpriseLoginSubsystem" $ do - describe "LockDomain" pending - describe "UnlockDomain" pending - describe "PreAuthorizeDomain" pending - describe "UnAuthorizeDomain" pending - describe "UpdateDomainRegistration" pending - describe "DeleteDomain" pending + it "LockDomain" pending + it "UnlockDomain" pending + it "PreAuthorizeDomain" pending + it "UnAuthorizeDomain" pending + it "UpdateDomainRegistration" pending + it "DeleteDomain" pending describe "GuardEmailDomainRegistrationState" $ do - let testTeamInvitation fun = it "team-invitation" $ do - outcome <- runDependencies . runEnterpriseLoginSubsystem $ do - upsert - fun - case (.teamInvite) <$> outcome of - Allowed -> ok - NotAllowed -> nope "`teamInvite` is set to `not-allowed`" - Team allowedTid -> - if allowedTid == tid - then ok - else nope $ "`teamInvite` is restricted to another team." + let testTeamInvitation sut = it "team-invitation" $ do + let teamInvites = [Allowed, NotAllowed, Team anyTeam, Team otherTeam] + for_ teamInvites \teamInvite -> do + let update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = None} + outcome = runDependencies . runEnterpriseLoginSubsystem $ do + updateDomainRegistration (Domain "example.com") update + sut + case teamInvite of + Allowed -> outcome `shouldBe` Right () + NotAllowed -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + Team allowedTid -> + if allowedTid == anyTeam + then outcome `shouldBe` Right () + else outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is restricted to another team.") - anyTeam = Id "74d17a68-d196-11ef-934c-2b0e41bf5418" + anyTeam = Id (fromMaybe (error "invalid uuid") $ UUID.fromString "74d17a68-d196-11ef-934c-2b0e41bf5418") + otherTeam = Id (fromMaybe (error "invalid uuid") $ UUID.fromString "74d17a68-d196-11ef-934c-2b0e41bf5419") anyEmailAddress = unsafeEmailAddress "me" "example.com" - + domainRedirects = + [ None, + Locked, + SSO undefined, + Backend undefined, + NoRegistration, + PreAuthorized + ] context "invite new user" $ do - let fun = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress + let sut = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress it "no entry in enterprise login table -> ok" $ do - fun `shouldReturn () + (runDependencies . runEnterpriseLoginSubsystem) sut `shouldBe` Right () + + it "domain-redirect" $ do + for_ domainRedirects \domReg -> do + let teamInvite = case domReg of + -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` + Backend _ -> NotAllowed + _ -> Allowed + update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = domReg} + let outcome = runDependencies . runEnterpriseLoginSubsystem $ do + updateDomainRegistration (Domain "example.com") update + sut + case domReg of + None -> outcome `shouldBe` Right () + Locked -> outcome `shouldBe` Right () + SSO _ -> outcome `shouldBe` Right () + Backend _ -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + NoRegistration -> outcome `shouldBe` Right () + PreAuthorized -> outcome `shouldBe` Right () - it "domain-redirect" $ for [minBound ..] \_ -> do - -- write to mock table or something. (also team invite entry) - fun `shouldReturn` () - testTeamInvitation fun + testTeamInvitation sut context "invite existing user" $ do - let fun = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress - it "no entry in enterprise login table -> ok" $ pending - it "domain-redirect" - $ for [minBound ..] \domRegTag -> do - -- write to mock table or something. (also team invite entry) - case domRegTag of - None -> ok - Locked -> ok - SSO _ -> ok - Backend _ -> ok - NoRegistration -> nope "`domain_redirect` is set to `no-registration`" - PreAuthorized -> ok - testTeamInvitation fun + let sut = guardEmailDomainRegistrationState ExistingUser anyTeam anyEmailAddress + + it "no entry in enterprise login table -> ok" $ do + (runDependencies . runEnterpriseLoginSubsystem) sut `shouldBe` Right () + + it "domain-redirect" $ do + for_ domainRedirects \domReg -> do + let teamInvite = case domReg of + -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` + Backend _ -> NotAllowed + _ -> Allowed + update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = domReg} + let outcome = runDependencies . runEnterpriseLoginSubsystem $ do + updateDomainRegistration (Domain "example.com") update + sut + case domReg of + None -> outcome `shouldBe` Right () + Locked -> outcome `shouldBe` Right () + SSO _ -> outcome `shouldBe` Right () + Backend _ -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + NoRegistration -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no-registration`") + PreAuthorized -> outcome `shouldBe` Right () + + testTeamInvitation $ sut diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 222abecedab..1cd5e07d444 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -242,6 +242,7 @@ test-suite wire-subsystems-tests Spec Wire.ActivationCodeStore.InterpreterSpec Wire.AuthenticationSubsystem.InterpreterSpec + Wire.EnterpriseLoginSubsystem.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters Wire.MockInterpreters.ActivationCodeStore @@ -309,6 +310,7 @@ test-suite wire-subsystems-tests , tinylog , transformers , types-common + , uuid , wire-api , wire-api-federation , wire-subsystems From 4b327fb047547f9589b74b1502bc14691da70dae Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 16:19:48 +0000 Subject: [PATCH 09/48] convert to property test --- libs/wire-api/src/Wire/API/EnterpriseLogin.hs | 24 +++- .../src/Wire/API/User/EmailAddress.hs | 6 +- .../src/Wire/DomainRegistrationStore.hs | 19 +++- .../Wire/DomainRegistrationStore/Cassandra.hs | 6 +- .../src/Wire/EnterpriseLoginSubsystem.hs | 4 + .../InterpreterSpec.hs | 107 +++++------------- .../DomainRegistrationStore.hs | 6 +- 7 files changed, 83 insertions(+), 89 deletions(-) diff --git a/libs/wire-api/src/Wire/API/EnterpriseLogin.hs b/libs/wire-api/src/Wire/API/EnterpriseLogin.hs index e6f1d34cd7c..a5411a552a9 100644 --- a/libs/wire-api/src/Wire/API/EnterpriseLogin.hs +++ b/libs/wire-api/src/Wire/API/EnterpriseLogin.hs @@ -16,6 +16,9 @@ import Data.Text.Ascii (Ascii, AsciiText (toText)) import Data.Text.Ascii qualified as Ascii import Imports import SAML2.WebSSO qualified as SAML +import SAML2.WebSSO.Test.Arbitrary () +import Test.QuickCheck (suchThat) +import Wire.Arbitrary data DomainRedirect = None @@ -24,7 +27,8 @@ data DomainRedirect | Backend HttpsUrl | NoRegistration | PreAuthorized - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform DomainRedirect makePrisms ''DomainRedirect @@ -97,7 +101,8 @@ data TeamInvite = Allowed | NotAllowed | Team TeamId - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via GenericUniform TeamInvite makePrisms ''TeamInvite @@ -162,6 +167,21 @@ data DomainRegistrationUpdate = DomainRegistrationUpdate deriving stock (Eq, Show) deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DomainRegistrationUpdate +instance Arbitrary DomainRegistrationUpdate where + arbitrary = do + ( DomainRegistrationUpdate + <$> arbitrary + <*> arbitrary + ) + `suchThat` validate + where + validate :: DomainRegistrationUpdate -> Bool + validate dr = + case dr.domainRedirect of + Locked -> dr.teamInvite == Allowed + Backend _ -> dr.teamInvite == NotAllowed + _ -> True + instance ToSchema DomainRegistrationUpdate where schema = object "DomainRegistrationUpdate" $ diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index ffde490b59e..98be75a0d84 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -93,12 +93,16 @@ emailAddressText = emailAddress . encodeUtf8 arbitraryValidMail :: Gen EmailAddress arbitraryValidMail = do loc <- arbitrary `suchThat` isValidLoc - dom <- arbitrary `suchThat` isValidDom + dom <- (addTld <$> arbitrary) `suchThat` isValidDom pure . fromJust $ emailAddress (fromString $ loc <> "@" <> dom) where notAt :: String -> Bool notAt = notElem '@' + -- at some places dotless domains do not work, so we add a tld + addTld :: String -> String + addTld str = if '.' `notElem` str then str <> ".tld" else str + notNull = not . null isValidLoc :: String -> Bool diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs index aa7ed5acd4f..759850c8d92 100644 --- a/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs +++ b/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs @@ -2,9 +2,11 @@ module Wire.DomainRegistrationStore where -import Data.Domain +import Amazonka.Request (delete) +import Data.Domain as Domain import Data.Id import Data.Misc +import Data.Text as T import Database.CQL.Protocol (Record (..), TupleType, recordInstance) import Imports import Polysemy @@ -25,8 +27,17 @@ data StoredDomainRegistration = StoredDomainRegistration recordInstance ''StoredDomainRegistration data DomainRegistrationStore m a where - Upsert :: StoredDomainRegistration -> DomainRegistrationStore m () - Lookup :: Domain -> DomainRegistrationStore m (Maybe StoredDomainRegistration) - Delete :: Domain -> DomainRegistrationStore m () + UpsertInternal :: StoredDomainRegistration -> DomainRegistrationStore m () + LookupInternal :: Domain -> DomainRegistrationStore m (Maybe StoredDomainRegistration) + DeleteInternal :: Domain -> DomainRegistrationStore m () makeSem ''DomainRegistrationStore + +upsert :: (Member DomainRegistrationStore r) => StoredDomainRegistration -> Sem r () +upsert storedDomainReg = upsertInternal $ storedDomainReg {Wire.DomainRegistrationStore.domain = storedDomainReg.domain & (Domain . T.toLower . domainText)} + +lookup :: (Member DomainRegistrationStore r) => Domain -> Sem r (Maybe StoredDomainRegistration) +lookup domain = lookupInternal $ Domain . T.toLower . domainText $ domain + +delete :: (Member DomainRegistrationStore r) => Domain -> Sem r () +delete domain = deleteInternal $ Domain . T.toLower . domainText $ domain diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs index a5062481bce..eceda192c04 100644 --- a/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs @@ -23,9 +23,9 @@ interpretDomainRegistrationStoreToCassandra :: interpretDomainRegistrationStoreToCassandra casClient = interpret $ embed @IO . runClient casClient . \case - Upsert dr -> upsert dr - Lookup domain -> lookup domain - Delete domain -> delete domain + UpsertInternal dr -> upsert dr + LookupInternal domain -> lookup domain + DeleteInternal domain -> delete domain upsert :: (MonadClient m) => StoredDomainRegistration -> m () upsert dr = retry x5 $ write cqlUpsert (params LocalQuorum (asTuple dr)) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index 5bcbcf6cd45..9c8a36d66db 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -4,11 +4,15 @@ module Wire.EnterpriseLoginSubsystem where import Data.Domain import Data.Id +import Imports import Polysemy import Text.Email.Parser import Wire.API.EnterpriseLogin +import Wire.Arbitrary data InvitationFlow = ExistingUser | NewUser + deriving (Show, Eq, Generic) + deriving (Arbitrary) via GenericUniform InvitationFlow data EnterpriseLoginSubsystem m a where LockDomain :: Domain -> EnterpriseLoginSubsystem m () diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index f599ef7602b..ef568c5ef25 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -2,7 +2,7 @@ module Wire.EnterpriseLoginSubsystem.InterpreterSpec where import Data.Domain import Data.Id -import Data.UUID qualified as UUID +import Data.String.Conversions (cs) import Imports import Polysemy import Polysemy.Error @@ -10,8 +10,10 @@ import Polysemy.Input import Polysemy.State import Polysemy.TinyLog import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck import Wire.API.EnterpriseLogin -import Wire.API.User.EmailAddress +import Wire.API.User.EmailAddress (domainPart) import Wire.DomainRegistrationStore import Wire.EmailSending import Wire.EnterpriseLoginSubsystem @@ -54,81 +56,34 @@ spec = describe "EnterpriseLoginSubsystem" $ do it "UpdateDomainRegistration" pending it "DeleteDomain" pending - describe "GuardEmailDomainRegistrationState" $ do - let testTeamInvitation sut = it "team-invitation" $ do - let teamInvites = [Allowed, NotAllowed, Team anyTeam, Team otherTeam] - for_ teamInvites \teamInvite -> do - let update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = None} - outcome = runDependencies . runEnterpriseLoginSubsystem $ do - updateDomainRegistration (Domain "example.com") update - sut - case teamInvite of - Allowed -> outcome `shouldBe` Right () - NotAllowed -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") - Team allowedTid -> - if allowedTid == anyTeam - then outcome `shouldBe` Right () - else outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is restricted to another team.") + focus . prop "GuardEmailDomainRegistrationState" $ + \flow sameTeam teamId email preDomRegEntry -> + let setTeamId :: DomainRegistrationUpdate -> TeamId -> DomainRegistrationUpdate + setTeamId update tid = case update.teamInvite of + Team _ -> DomainRegistrationUpdate update.domainRedirect (Team tid) + _ -> update - anyTeam = Id (fromMaybe (error "invalid uuid") $ UUID.fromString "74d17a68-d196-11ef-934c-2b0e41bf5418") - otherTeam = Id (fromMaybe (error "invalid uuid") $ UUID.fromString "74d17a68-d196-11ef-934c-2b0e41bf5419") - anyEmailAddress = unsafeEmailAddress "me" "example.com" - domainRedirects = - [ None, - Locked, - SSO undefined, - Backend undefined, - NoRegistration, - PreAuthorized - ] - context "invite new user" $ do - let sut = guardEmailDomainRegistrationState NewUser anyTeam anyEmailAddress + domRegEntry = if sameTeam then setTeamId preDomRegEntry teamId else preDomRegEntry - it "no entry in enterprise login table -> ok" $ do - (runDependencies . runEnterpriseLoginSubsystem) sut `shouldBe` Right () + outcome = runDependencies . runEnterpriseLoginSubsystem $ do + updateDomainRegistration (Domain . cs $ domainPart email) domRegEntry + guardEmailDomainRegistrationState flow teamId email - it "domain-redirect" $ do - for_ domainRedirects \domReg -> do - let teamInvite = case domReg of - -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` - Backend _ -> NotAllowed - _ -> Allowed - update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = domReg} - let outcome = runDependencies . runEnterpriseLoginSubsystem $ do - updateDomainRegistration (Domain "example.com") update - sut - case domReg of - None -> outcome `shouldBe` Right () - Locked -> outcome `shouldBe` Right () - SSO _ -> outcome `shouldBe` Right () - Backend _ -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") - NoRegistration -> outcome `shouldBe` Right () - PreAuthorized -> outcome `shouldBe` Right () + a = case domRegEntry.teamInvite of + Allowed -> b + NotAllowed -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + Team allowedTid -> + if allowedTid == teamId + then b + else outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is restricted to another team.") - testTeamInvitation sut - - context "invite existing user" $ do - let sut = guardEmailDomainRegistrationState ExistingUser anyTeam anyEmailAddress - - it "no entry in enterprise login table -> ok" $ do - (runDependencies . runEnterpriseLoginSubsystem) sut `shouldBe` Right () - - it "domain-redirect" $ do - for_ domainRedirects \domReg -> do - let teamInvite = case domReg of - -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` - Backend _ -> NotAllowed - _ -> Allowed - update = DomainRegistrationUpdate {teamInvite = teamInvite, domainRedirect = domReg} - let outcome = runDependencies . runEnterpriseLoginSubsystem $ do - updateDomainRegistration (Domain "example.com") update - sut - case domReg of - None -> outcome `shouldBe` Right () - Locked -> outcome `shouldBe` Right () - SSO _ -> outcome `shouldBe` Right () - Backend _ -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") - NoRegistration -> outcome `shouldBe` Left (EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no-registration`") - PreAuthorized -> outcome `shouldBe` Right () - - testTeamInvitation $ sut + b = case domRegEntry.domainRedirect of + Backend _ -> + -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` + outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + NoRegistration -> + case flow of + ExistingUser -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no-registration`") + NewUser -> outcome === Right () + _ -> outcome === Right () + in a diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs index 152e0e0da2a..59879b23d6c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/DomainRegistrationStore.hs @@ -7,6 +7,6 @@ import Wire.DomainRegistrationStore inMemoryDomainRegistrationStoreInterpreter :: (Member (State [StoredDomainRegistration]) r) => InterpreterFor DomainRegistrationStore r inMemoryDomainRegistrationStoreInterpreter = interpret $ \case - Upsert dr -> modify ((dr :) . filter ((/= domain dr) . domain)) - Lookup d -> gets (find ((== d) . domain)) - Delete d -> modify (filter ((/= d) . domain)) + UpsertInternal dr -> modify ((dr :) . filter ((/= domain dr) . domain)) + LookupInternal d -> gets (find ((== d) . domain)) + DeleteInternal d -> modify (filter ((/= d) . domain)) From 2506d771c3431397415e4b29e0eb3f798b7966a0 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 13 Jan 2025 16:27:51 +0000 Subject: [PATCH 10/48] fix test --- .../InterpreterSpec.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index ef568c5ef25..3a42f3910e1 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -56,7 +56,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do it "UpdateDomainRegistration" pending it "DeleteDomain" pending - focus . prop "GuardEmailDomainRegistrationState" $ + prop "GuardEmailDomainRegistrationState" $ \flow sameTeam teamId email preDomRegEntry -> let setTeamId :: DomainRegistrationUpdate -> TeamId -> DomainRegistrationUpdate setTeamId update tid = case update.teamInvite of @@ -69,21 +69,21 @@ spec = describe "EnterpriseLoginSubsystem" $ do updateDomainRegistration (Domain . cs $ domainPart email) domRegEntry guardEmailDomainRegistrationState flow teamId email - a = case domRegEntry.teamInvite of - Allowed -> b + teamNotAllowedOrWrongTeamIdFails = case domRegEntry.teamInvite of + Allowed -> outcome === Right () NotAllowed -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") Team allowedTid -> if allowedTid == teamId - then b + then outcome === Right () else outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is restricted to another team.") - b = case domRegEntry.domainRedirect of + backendRedirectOrNoRegistrationFails = case domRegEntry.domainRedirect of Backend _ -> -- if domain-redirect is set to `backend`, then team-invite must be set to `not-allowed` - outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + teamNotAllowedOrWrongTeamIdFails NoRegistration -> case flow of ExistingUser -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no-registration`") - NewUser -> outcome === Right () - _ -> outcome === Right () - in a + NewUser -> teamNotAllowedOrWrongTeamIdFails + _ -> teamNotAllowedOrWrongTeamIdFails + in backendRedirectOrNoRegistrationFails From f285fe08bdae0740dc1e03fda7cf7550b983dbe6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2025 09:28:25 +0100 Subject: [PATCH 11/48] nit-pick. --- .../test/unit/Wire/MockInterpreters/UserSubsystem.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 839ced4e5ad..2dedf481ad1 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -6,7 +6,7 @@ import Polysemy import Wire.API.User import Wire.UserSubsystem --- HINT: This is used to test AuthenticationSubsystem, not to test itself! +-- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! userSubsystemTestInterpreter :: [User] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter initialUsers = interpret \case From 386fc7c928d09425eb7d25d4ad5b0c4d6cbe7fd1 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2025 10:01:24 +0100 Subject: [PATCH 12/48] unit test module for TeamInvitationSubsystem. --- .../src/Wire/TeamInvitationSubsystem/Error.hs | 2 +- .../InterpreterSpec.hs | 18 ++--- .../test/unit/Wire/MiniBackend.hs | 2 - .../test/unit/Wire/MockInterpreters.hs | 6 +- .../Wire/MockInterpreters/EmailSubsystem.hs | 1 + .../EnterpriseLoginSubsystem.hs | 18 +++++ .../InterpreterSpec.hs | 79 +++++++++++++++++++ .../InterpreterSpec.hs | 2 +- libs/wire-subsystems/wire-subsystems.cabal | 2 + 9 files changed, 116 insertions(+), 14 deletions(-) create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs create mode 100644 libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs index 892450e3354..364113ed530 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs @@ -11,7 +11,7 @@ data TeamInvitationSubsystemError | TooManyTeamInvitations | TeamInvitationBlacklistedEmail | TeamInvitationEmailTaken - deriving (Show) + deriving (Eq, Show) teamInvitationErrorToHttpError :: TeamInvitationSubsystemError -> HttpError teamInvitationErrorToHttpError = diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 87509b688de..6322f8ab025 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -97,8 +97,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do mapM_ (uncurry (insertCookie uid)) cookiesWithTTL createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email - resetPassword (PasswordResetEmailIdentity email) code newPassword + (_, resetCode) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetEmailIdentity email) resetCode newPassword (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> @@ -121,8 +121,8 @@ spec = describe "AuthenticationSubsystem.Interpreter" do mapM_ (uncurry (insertCookie uid)) cookiesWithTTL createPasswordResetCode (mkEmailKey email) - (passwordResetKey, code) <- expect1ResetPasswordEmail email - resetPassword (PasswordResetIdentityKey passwordResetKey) code newPassword + (passwordResetKey, resetCode) <- expect1ResetPasswordEmail email + resetPassword (PasswordResetIdentityKey passwordResetKey) resetCode newPassword (,) <$> lookupHashedPassword uid <*> listCookies uid in mPreviousPassword /= Just newPassword ==> @@ -189,12 +189,12 @@ spec = describe "AuthenticationSubsystem.Interpreter" do Right (newPasswordHash, mCaughtException) = runAllEffects localDomain [user] Nothing $ do createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email + (_, resetCode) <- expect1ResetPasswordEmail email mCaughtExc <- catchExpectedError $ createPasswordResetCode (mkEmailKey email) -- Reset password still works with previously generated reset code - resetPassword (PasswordResetEmailIdentity email) code newPassword + resetPassword (PasswordResetEmailIdentity email) resetCode newPassword (,mCaughtExc) <$> lookupHashedPassword uid in (fmap (Password.verifyPassword newPassword) newPasswordHash === Just True) @@ -214,11 +214,11 @@ spec = describe "AuthenticationSubsystem.Interpreter" do runAllEffects localDomain [user] Nothing $ do upsertHashedPassword uid =<< hashPassword oldPassword createPasswordResetCode (mkEmailKey email) - (_, code) <- expect1ResetPasswordEmail email + (_, resetCode) <- expect1ResetPasswordEmail email passTime (passwordResetCodeTtl + 1) - mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) code newPassword + mCaughtExc <- catchExpectedError $ resetPassword (PasswordResetEmailIdentity email) resetCode newPassword (,mCaughtExc) <$> lookupHashedPassword uid in resetPasswordResult === Just AuthenticationSubsystemInvalidPasswordResetCode .&&. verifyPasswordProp oldPassword passwordInDB @@ -311,7 +311,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do runAllEffects localDomain [user] Nothing $ do void $ createPasswordResetCode (mkEmailKey email) mLookupRes <- internalLookupPasswordResetCode (mkEmailKey email) - for_ mLookupRes $ \(_, code) -> resetPassword (PasswordResetEmailIdentity email) code newPassword + for_ mLookupRes $ \(_, resetCode) -> resetPassword (PasswordResetEmailIdentity email) resetCode newPassword lookupHashedPassword uid in verifyPasswordProp newPassword passwordHashInDB diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 2dbf1a3a9bc..efcfaff5ee2 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -75,8 +75,6 @@ import Wire.IndexedUserStore import Wire.InternalEvent hiding (DeleteUser) import Wire.InvitationStore import Wire.MockInterpreters -import Wire.MockInterpreters.ActivationCodeStore (inMemoryActivationCodeStoreInterpreter) -import Wire.MockInterpreters.InvitationStore (inMemoryInvitationStoreInterpreter) import Wire.PasswordResetCodeStore import Wire.PasswordStore import Wire.Sem.Concurrency diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs index e975ac6a06c..b7d342b3f6e 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -1,16 +1,20 @@ module Wire.MockInterpreters (module MockInterpreters) where -- Run this from project root to generate the imports: --- ls libs/wire-subsystems/test/unit/Wire/MockInterpreters | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' +-- ls ./MockInterpreters | grep '\.hs' | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' +import Wire.MockInterpreters.ActivationCodeStore as MockInterpreters import Wire.MockInterpreters.BlockListStore as MockInterpreters +import Wire.MockInterpreters.DomainRegistrationStore as MockInterpreters import Wire.MockInterpreters.EmailSubsystem as MockInterpreters +import Wire.MockInterpreters.EnterpriseLoginSubsystem as MockInterpreters import Wire.MockInterpreters.Error as MockInterpreters import Wire.MockInterpreters.Events as MockInterpreters import Wire.MockInterpreters.FederationConfigStore as MockInterpreters import Wire.MockInterpreters.GalleyAPIAccess as MockInterpreters import Wire.MockInterpreters.HashPassword as MockInterpreters import Wire.MockInterpreters.IndexedUserStore as MockInterpreters +import Wire.MockInterpreters.InvitationStore as MockInterpreters import Wire.MockInterpreters.Now as MockInterpreters import Wire.MockInterpreters.PasswordResetCodeStore as MockInterpreters import Wire.MockInterpreters.PasswordStore as MockInterpreters diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index ee8125d758e..1286668f8bb 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -16,6 +16,7 @@ data SentMail = SentMail data SentMailContent = PasswordResetMail PasswordResetPair deriving (Show, Eq) +-- TODO: rename to 'emailSubsystemInterpreter' emailSubsystemInterpreter :: (Member (State (Map EmailAddress [SentMail])) r) => InterpreterFor EmailSubsystem r emailSubsystemInterpreter = interpret \case SendPasswordResetMail email keyCodePair mLocale -> modify $ Map.insertWith (<>) email [SentMail mLocale $ PasswordResetMail keyCodePair] diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs new file mode 100644 index 00000000000..28d578c2a73 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -0,0 +1,18 @@ +module Wire.MockInterpreters.EnterpriseLoginSubsystem where + +import Imports +import Polysemy +import Wire.EnterpriseLoginSubsystem + +-- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! +enterpriseLoginSubsystemTestInterpreter :: InterpreterFor EnterpriseLoginSubsystem r +enterpriseLoginSubsystemTestInterpreter = + interpret \case + LockDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () + UnlockDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () + PreAuthorizeDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () + UnAuthorizeDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () + UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () + DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () + GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration + GuardEmailDomainRegistrationState _ _ _ -> undefined -- :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs new file mode 100644 index 00000000000..312d6349a70 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Wire.TeamInvitationSubsystem.InterpreterSpec (spec) where + +import Data.Id +import Data.Time +import Imports +import Polysemy +import Polysemy.Error +import Polysemy.State +import Polysemy.TinyLog +import System.Random (StdGen, mkStdGen) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Wire.API.Team.Invitation +import Wire.API.Team.Member +import Wire.API.User +import Wire.EmailSubsystem +import Wire.EnterpriseLoginSubsystem +import Wire.GalleyAPIAccess +import Wire.InvitationStore +import Wire.MockInterpreters +import Wire.Sem.Logger.TinyLog +import Wire.Sem.Now (Now) +import Wire.Sem.Random +import Wire.TeamInvitationSubsystem +import Wire.TeamInvitationSubsystem.Error +import Wire.TeamInvitationSubsystem.Interpreter +import Wire.UserSubsystem + +type AllEffects = + [ Error TeamInvitationSubsystemError, + TinyLog, + GalleyAPIAccess, + Random, + State StdGen, + InvitationStore, + State (Map (TeamId, InvitationId) StoredInvitation), + State (Map (InvitationCode) StoredInvitation), + Now, + State UTCTime, + EmailSubsystem, + State (Map EmailAddress [SentMail]), + UserSubsystem, + EnterpriseLoginSubsystem + ] + +runAllEffects :: Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects = + run + . enterpriseLoginSubsystemTestInterpreter + . userSubsystemTestInterpreter [] + . evalState mempty + . emailSubsystemInterpreter + . evalState defaultTime + . interpretNowAsState + . evalState mempty + . evalState mempty + . inMemoryInvitationStoreInterpreter + . evalState (mkStdGen 3) -- deterministic randomness, good for tests. :) + . randomToStatefulStdGen + . miniGalleyAPIAccess Nothing undefined + . discardTinyLogs + . runError + +spec :: Spec +spec = do + describe "InviteUser" $ do + focus . prop "works (TODO: better description pls)" $ + \() -> + let cfg = + TeamInvitationSubsystemConfig + { maxTeamSize = 50, + teamInvitationTimeout = 3_000_000 + } + outcome = runAllEffects . runTeamInvitationSubsystem cfg $ do + pure () + in outcome === Right () diff --git a/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs index 20ffabf6270..a7bceda3640 100644 --- a/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/VerificationCodeSubsystem/InterpreterSpec.hs @@ -9,7 +9,7 @@ import Polysemy.State import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck -import Wire.MockInterpreters +import Wire.MockInterpreters hiding (code) import Wire.Sem.Now import Wire.Sem.Random import Wire.VerificationCode diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 1cd5e07d444..cb2971caf19 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -249,6 +249,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.DomainRegistrationStore Wire.MockInterpreters.EmailSubsystem + Wire.MockInterpreters.EnterpriseLoginSubsystem Wire.MockInterpreters.Error Wire.MockInterpreters.Events Wire.MockInterpreters.FederationConfigStore @@ -268,6 +269,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.VerificationCodeStore Wire.NotificationSubsystem.InterpreterSpec Wire.PropertySubsystem.InterpreterSpec + Wire.TeamInvitationSubsystem.InterpreterSpec Wire.UserSearch.TypesSpec Wire.UserStoreSpec Wire.UserSubsystem.InterpreterSpec From c272f2efe969ce34eb24906873f6c830af18dc63 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2025 10:41:29 +0100 Subject: [PATCH 13/48] Unit test for this PR. --- .../InterpreterSpec.hs | 35 ++++++++++++++----- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 312d6349a70..696d722cf45 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -2,7 +2,10 @@ module Wire.TeamInvitationSubsystem.InterpreterSpec (spec) where +import Data.Default import Data.Id +import Data.LegalHold +import Data.Qualified import Data.Time import Imports import Polysemy @@ -15,6 +18,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Wire.API.Team.Invitation import Wire.API.Team.Member +import Wire.API.Team.Permission import Wire.API.User import Wire.EmailSubsystem import Wire.EnterpriseLoginSubsystem @@ -46,8 +50,13 @@ type AllEffects = EnterpriseLoginSubsystem ] -runAllEffects :: Sem AllEffects a -> Either TeamInvitationSubsystemError a -runAllEffects = +data RunAllEffectsArgs = RunAllEffectsArgs + { teamOwner :: TeamMember + } + deriving (Eq, Show) + +runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects args = run . enterpriseLoginSubsystemTestInterpreter . userSubsystemTestInterpreter [] @@ -60,20 +69,30 @@ runAllEffects = . inMemoryInvitationStoreInterpreter . evalState (mkStdGen 3) -- deterministic randomness, good for tests. :) . randomToStatefulStdGen - . miniGalleyAPIAccess Nothing undefined + . miniGalleyAPIAccess (Just args.teamOwner) def . discardTinyLogs . runError spec :: Spec spec = do describe "InviteUser" $ do - focus . prop "works (TODO: better description pls)" $ - \() -> + prop "calls guardEmailDomainRegistrationState if appropriate" $ + \uid tid email -> let cfg = TeamInvitationSubsystemConfig { maxTeamSize = 50, teamInvitationTimeout = 3_000_000 } - outcome = runAllEffects . runTeamInvitationSubsystem cfg $ do - pure () - in outcome === Right () + invreq = + InvitationRequest + { locale = Nothing, + role = Nothing, + inviteeName = Nothing, + inviteeEmail = email, + allowExisting = False + } + teamMember = mkTeamMember (tUnqualified uid) fullPermissions Nothing UserLegalHoldDisabled + args = RunAllEffectsArgs teamMember + outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do + void $ inviteUser uid tid invreq + in outcome === Right () -- TODO: should be some Left. From da728816b41ba56feecfad6a20f998b21d83a664 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2025 11:04:14 +0100 Subject: [PATCH 14/48] Enumerate unimplemented actions in miniGalleyAPIAccess interpreter. --- .../Wire/MockInterpreters/GalleyAPIAccess.hs | 22 ++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 9f37e501b4a..2072a606d98 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -16,10 +16,30 @@ miniGalleyAPIAccess :: AllTeamFeatures -> InterpreterFor GalleyAPIAccess r miniGalleyAPIAccess member configs = interpret $ \case + CreateSelfConv _ -> error "CreateSelfConv not implemented in miniGalleyAPIAccess" + GetConv _ _ -> error "GetConv not implemented in miniGalleyAPIAccess" + GetTeamConv _ _ _ -> error "GetTeamConv not implemented in miniGalleyAPIAccess" + NewClient _ _ -> error "NewClient not implemented in miniGalleyAPIAccess" + CheckUserCanJoinTeam _ -> error "CheckUserCanJoinTeam not implemented in miniGalleyAPIAccess" + AddTeamMember _ _ _ _ -> error "AddTeamMember not implemented in miniGalleyAPIAccess" + CreateTeam _ _ _ -> error "CreateTeam not implemented in miniGalleyAPIAccess" GetTeamMember _ _ -> pure member + GetTeamMembers _ -> error "GetTeamMembers not implemented in miniGalleyAPIAccess" + GetTeamId _ -> error "GetTeamId not implemented in miniGalleyAPIAccess" + GetTeam _ -> error "GetTeam not implemented in miniGalleyAPIAccess" + GetTeamName _ -> error "GetTeamName not implemented in miniGalleyAPIAccess" + GetTeamLegalHoldStatus _ -> error "GetTeamLegalHoldStatus not implemented in miniGalleyAPIAccess" + GetUserLegalholdStatus _ _ -> error "GetUserLegalholdStatus not implemented in miniGalleyAPIAccess" + GetTeamSearchVisibility _ -> error "GetTeamSearchVisibility not implemented in miniGalleyAPIAccess" + ChangeTeamStatus _ _ _ -> error "ChangeTeamStatus not implemented in miniGalleyAPIAccess" + MemberIsTeamOwner _ _ -> error "MemberIsTeamOwner not implemented in miniGalleyAPIAccess" GetAllTeamFeaturesForUser _ -> pure configs GetFeatureConfigForTeam tid -> pure $ getFeatureConfigForTeamImpl configs tid - _ -> error "uninterpreted effect: GalleyAPIAccess" + GetVerificationCodeEnabled _ -> error "GetVerificationCodeEnabled not implemented in miniGalleyAPIAccess" + GetExposeInvitationURLsToTeamAdmin _ -> error "GetExposeInvitationURLsToTeamAdmin not implemented in miniGalleyAPIAccess" + IsMLSOne2OneEstablished _ _ -> error "IsMLSOne2OneEstablished not implemented in miniGalleyAPIAccess" + UnblockConversation _ _ _ -> error "UnblockConversation not implemented in miniGalleyAPIAccess" + GetEJPDConvInfo _ -> error "GetEJPDConvInfo not implemented in miniGalleyAPIAccess" getFeatureConfigForTeamImpl :: forall feature. (IsFeatureConfig feature) => AllTeamFeatures -> TeamId -> LockableFeature feature getFeatureConfigForTeamImpl allfeatures _ = npProject' (Proxy @(feature)) allfeatures From c13f7f8793b9ebc12ea4524d2110937ae0149da5 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 14 Jan 2025 10:23:33 +0000 Subject: [PATCH 15/48] prop test: wip --- .../TeamInvitationSubsystem/Interpreter.hs | 3 +-- .../Wire/MockInterpreters/UserSubsystem.hs | 23 ++++++++++++++++++- .../InterpreterSpec.hs | 23 +++++++++++-------- 3 files changed, 37 insertions(+), 12 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 2c3ec9f7c84..4dada214e1f 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -143,8 +143,7 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe pure True | otherwise -> throw TeamInvitationEmailTaken let flow = if isPersonalUserMigration then ExistingUser else ELS.NewUser - -- todo(leif): remove after writing the test for it - when False $ guardEmailDomainRegistrationState flow tid email + guardEmailDomainRegistrationState flow tid email maxSize <- maxTeamSize <$> input pending <- Store.countInvitations tid diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 2dedf481ad1..6bc1b63f58d 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -15,4 +15,25 @@ userSubsystemTestInterpreter initialUsers = filter (\u -> userEmail u `elem` (Just <$> emails)) initialUsers - _ -> error $ "userSubsystemTestInterpreter: implement on demand" + GetUserProfiles _ _ -> error "GetUserProfiles: implement on demand (userSubsystemInterpreter)" + GetUserProfilesWithErrors _ _ -> error "GetUserProfilesWithErrors: implement on demand (userSubsystemInterpreter)" + GetLocalUserProfiles _ -> error "GetLocalUserProfiles: implement on demand (userSubsystemInterpreter)" + GetAccountsBy _ -> error "GetAccountsBy: implement on demand (userSubsystemInterpreter)" + GetAccountNoFilter _ -> error "GetAccountNoFilter: implement on demand (userSubsystemInterpreter)" + GetSelfProfile uid -> pure . fmap SelfProfile $ find (\u -> qUnqualified u.userQualifiedId == tUnqualified uid) initialUsers + UpdateUserProfile {} -> error "UpdateUserProfile: implement on demand (userSubsystemInterpreter)" + CheckHandle _ -> error "CheckHandle: implement on demand (userSubsystemInterpreter)" + CheckHandles _ _ -> error "CheckHandles: implement on demand (userSubsystemInterpreter)" + UpdateHandle {} -> error "UpdateHandle: implement on demand (userSubsystemInterpreter)" + LookupLocaleWithDefault _ -> error "LookupLocaleWithDefault: implement on demand (userSubsystemInterpreter)" + IsBlocked _ -> pure False + BlockListDelete _ -> error "BlockListDelete: implement on demand (userSubsystemInterpreter)" + BlockListInsert _ -> error "BlockListInsert: implement on demand (userSubsystemInterpreter)" + UpdateTeamSearchVisibilityInbound _ -> error "UpdateTeamSearchVisibilityInbound: implement on demand (userSubsystemInterpreter)" + AcceptTeamInvitation {} -> error "AcceptTeamInvitation: implement on demand (userSubsystemInterpreter)" + InternalUpdateSearchIndex _ -> error "InternalUpdateSearchIndex: implement on demand (userSubsystemInterpreter)" + InternalFindTeamInvitation {} -> error "InternalFindTeamInvitation: implement on demand (userSubsystemInterpreter)" + GetUserExportData _ -> error "GetUserExportData: implement on demand (userSubsystemInterpreter)" + RemoveEmailEither _ -> error "RemoveEmailEither: implement on demand (userSubsystemInterpreter)" + SearchUsers {} -> error "SearchUsers: implement on demand (userSubsystemInterpreter)" + BrowseTeam {} -> error "BrowseTeam: implement on demand (userSubsystemInterpreter)" diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 696d722cf45..f3b6f437068 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -51,7 +51,8 @@ type AllEffects = ] data RunAllEffectsArgs = RunAllEffectsArgs - { teamOwner :: TeamMember + { teamOwner :: TeamMember, + initialUsers :: [User] } deriving (Eq, Show) @@ -59,7 +60,7 @@ runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationS runAllEffects args = run . enterpriseLoginSubsystemTestInterpreter - . userSubsystemTestInterpreter [] + . userSubsystemTestInterpreter args.initialUsers . evalState mempty . emailSubsystemInterpreter . evalState defaultTime @@ -76,23 +77,27 @@ runAllEffects args = spec :: Spec spec = do describe "InviteUser" $ do - prop "calls guardEmailDomainRegistrationState if appropriate" $ - \uid tid email -> + focus . prop "calls guardEmailDomainRegistrationState if appropriate" $ + \preInviter tid inviterEmail inviteeEmail -> let cfg = TeamInvitationSubsystemConfig { maxTeamSize = 50, teamInvitationTimeout = 3_000_000 } - invreq = + invReq = InvitationRequest { locale = Nothing, role = Nothing, inviteeName = Nothing, - inviteeEmail = email, + inviteeEmail = inviteeEmail, allowExisting = False } - teamMember = mkTeamMember (tUnqualified uid) fullPermissions Nothing UserLegalHoldDisabled - args = RunAllEffectsArgs teamMember + inviter = preInviter {userIdentity = Just $ EmailIdentity inviterEmail} + uid = qUnqualified inviter.userQualifiedId + domain = qDomain inviter.userQualifiedId + luid = toLocalUnsafe domain uid + teamMember = mkTeamMember uid fullPermissions Nothing UserLegalHoldDisabled + args = RunAllEffectsArgs teamMember [inviter] outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do - void $ inviteUser uid tid invreq + void $ inviteUser luid tid invReq in outcome === Right () -- TODO: should be some Left. From 764fbdc3bc041d17c37ad8d4b1c0835e4e3b37c8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 14 Jan 2025 11:22:33 +0000 Subject: [PATCH 16/48] team invitation test passes --- .../src/Wire/TeamInvitationSubsystem/Error.hs | 2 ++ .../MockInterpreters/EnterpriseLoginSubsystem.hs | 8 ++++++-- .../TeamInvitationSubsystem/InterpreterSpec.hs | 15 +++++++++------ 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs index 364113ed530..ac592a5fd89 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs @@ -13,6 +13,8 @@ data TeamInvitationSubsystemError | TeamInvitationEmailTaken deriving (Eq, Show) +instance Exception TeamInvitationSubsystemError + teamInvitationErrorToHttpError :: TeamInvitationSubsystemError -> HttpError teamInvitationErrorToHttpError = StdError . \case diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 28d578c2a73..2dde0baee13 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -2,10 +2,14 @@ module Wire.MockInterpreters.EnterpriseLoginSubsystem where import Imports import Polysemy +import Polysemy.Error (Error, throw) import Wire.EnterpriseLoginSubsystem +import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError (EnterpriseLoginSubsystemGuardFailed)) -- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! -enterpriseLoginSubsystemTestInterpreter :: InterpreterFor EnterpriseLoginSubsystem r +enterpriseLoginSubsystemTestInterpreter :: + (Member (Error EnterpriseLoginSubsystemError) r) => + InterpreterFor EnterpriseLoginSubsystem r enterpriseLoginSubsystemTestInterpreter = interpret \case LockDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () @@ -15,4 +19,4 @@ enterpriseLoginSubsystemTestInterpreter = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationState _ _ _ -> undefined -- :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationState {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index f3b6f437068..26d22d2fd5d 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -22,6 +22,7 @@ import Wire.API.Team.Permission import Wire.API.User import Wire.EmailSubsystem import Wire.EnterpriseLoginSubsystem +import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError (EnterpriseLoginSubsystemGuardFailed)) import Wire.GalleyAPIAccess import Wire.InvitationStore import Wire.MockInterpreters @@ -35,6 +36,8 @@ import Wire.UserSubsystem type AllEffects = [ Error TeamInvitationSubsystemError, + EnterpriseLoginSubsystem, + Error EnterpriseLoginSubsystemError, TinyLog, GalleyAPIAccess, Random, @@ -46,8 +49,7 @@ type AllEffects = State UTCTime, EmailSubsystem, State (Map EmailAddress [SentMail]), - UserSubsystem, - EnterpriseLoginSubsystem + UserSubsystem ] data RunAllEffectsArgs = RunAllEffectsArgs @@ -56,10 +58,9 @@ data RunAllEffectsArgs = RunAllEffectsArgs } deriving (Eq, Show) -runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either TeamInvitationSubsystemError a +runAllEffects :: RunAllEffectsArgs -> Sem AllEffects a -> Either EnterpriseLoginSubsystemError a runAllEffects args = run - . enterpriseLoginSubsystemTestInterpreter . userSubsystemTestInterpreter args.initialUsers . evalState mempty . emailSubsystemInterpreter @@ -73,11 +74,13 @@ runAllEffects args = . miniGalleyAPIAccess (Just args.teamOwner) def . discardTinyLogs . runError + . enterpriseLoginSubsystemTestInterpreter + . runErrorUnsafe @TeamInvitationSubsystemError spec :: Spec spec = do describe "InviteUser" $ do - focus . prop "calls guardEmailDomainRegistrationState if appropriate" $ + prop "calls guardEmailDomainRegistrationState if appropriate" $ \preInviter tid inviterEmail inviteeEmail -> let cfg = TeamInvitationSubsystemConfig @@ -100,4 +103,4 @@ spec = do args = RunAllEffectsArgs teamMember [inviter] outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser luid tid invReq - in outcome === Right () -- TODO: should be some Left. + in outcome === Left (EnterpriseLoginSubsystemGuardFailed "error") From 2d5c4727f5ccefae8e666a481b5005326ec6cb06 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 14 Jan 2025 11:38:41 +0000 Subject: [PATCH 17/48] fix flaky dotless email arbitrary instance --- libs/wire-api/src/Wire/API/User/EmailAddress.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index 98be75a0d84..6cecd5c3b85 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -93,12 +93,15 @@ emailAddressText = emailAddress . encodeUtf8 arbitraryValidMail :: Gen EmailAddress arbitraryValidMail = do loc <- arbitrary `suchThat` isValidLoc - dom <- (addTld <$> arbitrary) `suchThat` isValidDom + dom <- (addTld . trimDots <$> arbitrary) `suchThat` isValidDom pure . fromJust $ emailAddress (fromString $ loc <> "@" <> dom) where notAt :: String -> Bool notAt = notElem '@' + trimDots :: String -> String + trimDots = Imports.dropWhile (== '.') . Imports.dropWhileEnd (== '.') + -- at some places dotless domains do not work, so we add a tld addTld :: String -> String addTld str = if '.' `notElem` str then str <> ".tld" else str From 2f71628869835de1413eae0cbdd4e8005307a87a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 14 Jan 2025 21:38:47 +0100 Subject: [PATCH 18/48] Add guard for /register to EnterpriseLoginSubsystem. --- .../src/Wire/EnterpriseLoginSubsystem.hs | 3 +- .../EnterpriseLoginSubsystem/Interpreter.hs | 52 +++++++++++++++---- .../TeamInvitationSubsystem/Interpreter.hs | 2 +- .../InterpreterSpec.hs | 2 +- .../EnterpriseLoginSubsystem.hs | 3 +- services/brig/src/Brig/API/Public.hs | 2 + 6 files changed, 51 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index 9c8a36d66db..50901593ee8 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -22,6 +22,7 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationState :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m () makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 38f4b2edcc6..5b5b88bba64 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -59,7 +59,8 @@ runEnterpriseLoginSubsystem = interpret $ UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update DeleteDomain domain -> deleteDomainImpl domain GetDomainRegistration domain -> getDomainRegistrationImpl domain - GuardEmailDomainRegistrationState flow tid email -> guardEmailDomainRegistrationStateImpl flow tid email + GuardEmailDomainRegistrationTeamInvitation flow tid email -> guardEmailDomainRegistrationTeamInvitationImpl flow tid email + GuardEmailDomainRegistrationRegister email -> guardEmailDomainRegistrationRegisterImpl email deleteDomainImpl :: ( Member DomainRegistrationStore r, @@ -345,7 +346,21 @@ sendAuditMail url subject mBefore mAfter = do let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog sendMail mail -guardEmailDomainRegistrationStateImpl :: +-- More info on the behavioral implications of domain registration records: +-- https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1570832467/Email+domain+registration+and+configuration#Configuration-values +emailToDomainRegistration :: + forall r. + ( Member DomainRegistrationStore r, + Member (Error EnterpriseLoginSubsystemError) r, + Member TinyLog r + ) => + EmailAddress -> + Sem r (Maybe DomainRegistration) +emailToDomainRegistration email = case mkDomain $ T.decodeUtf8 $ Email.domainPart email of + Right dom -> tryGetDomainRegistrationImpl dom + Left msg -> throw $ EnterpriseLoginSubsystemGuardInvalidDomain (LT.pack msg) + +guardEmailDomainRegistrationTeamInvitationImpl :: forall r. ( Member DomainRegistrationStore r, Member (Error EnterpriseLoginSubsystemError) r, @@ -355,13 +370,8 @@ guardEmailDomainRegistrationStateImpl :: TeamId -> EmailAddress -> Sem r () -guardEmailDomainRegistrationStateImpl invitationFlow tid email = do - dom <- do - case mkDomain $ T.decodeUtf8 $ Email.domainPart email of - Right d -> pure d - Left msg -> throw $ EnterpriseLoginSubsystemGuardInvalidDomain (LT.pack msg) - - mReg <- tryGetDomainRegistrationImpl dom +guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do + mReg <- emailToDomainRegistration email for_ mReg $ \reg -> do -- fail if domain-redirect is set to no-registration, or case reg.domainRedirect of @@ -385,3 +395,27 @@ guardEmailDomainRegistrationStateImpl invitationFlow tid email = do where ok = pure () nope = throw . EnterpriseLoginSubsystemGuardFailed + +guardEmailDomainRegistrationRegisterImpl :: + forall r. + ( Member DomainRegistrationStore r, + Member (Error EnterpriseLoginSubsystemError) r, + Member TinyLog r + ) => + EmailAddress -> + Sem r () +guardEmailDomainRegistrationRegisterImpl email = do + mReg <- emailToDomainRegistration email + for_ mReg $ \reg -> do + case reg.domainRedirect of + None -> ok + Locked -> ok + SSO _ -> nope "`domain_redirect` is set to `sso:{code}`" + Backend url -> + -- TODO: this should make /register respond with 302 found or something similar. + undefined url + NoRegistration -> nope "`domain_redirect` is set to `no_registration`" + PreAuthorized -> ok + where + ok = pure () + nope = throw . EnterpriseLoginSubsystemGuardFailed diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 4dada214e1f..39ceaae3cc2 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -143,7 +143,7 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe pure True | otherwise -> throw TeamInvitationEmailTaken let flow = if isPersonalUserMigration then ExistingUser else ELS.NewUser - guardEmailDomainRegistrationState flow tid email + in guardEmailDomainRegistrationTeamInvitation flow tid email maxSize <- maxTeamSize <$> input pending <- Store.countInvitations tid diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 3a42f3910e1..ee468de5a4e 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -67,7 +67,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do outcome = runDependencies . runEnterpriseLoginSubsystem $ do updateDomainRegistration (Domain . cs $ domainPart email) domRegEntry - guardEmailDomainRegistrationState flow teamId email + guardEmailDomainRegistrationTeamInvitation flow teamId email teamNotAllowedOrWrongTeamIdFails = case domRegEntry.teamInvite of Allowed -> outcome === Right () diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 2dde0baee13..93927435729 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -19,4 +19,5 @@ enterpriseLoginSubsystemTestInterpreter = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationState {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" + GuardEmailDomainRegistrationTeamInvitation {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" + GuardEmailDomainRegistrationRegister {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 7ce1de25e31..7c7e5d33efe 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -833,6 +833,8 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do API.checkRestrictedUserCreation new for_ (Public.newUserEmail new) $ mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError + -- TODO: remove the conditional once we have a failing test that is fixed by this. + when False $ guardEmailDomainRegistrationRegisterImpl email result <- API.createUser new let acc = createdAccount result From e0b0af52f1103e8ba9c5afc6c89aa501f7a82269 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 15 Jan 2025 08:53:07 +0100 Subject: [PATCH 19/48] [experiment / wip] make guard functions return a result value... ... not throw exceptions --- .../src/Wire/EnterpriseLoginSubsystem.hs | 13 +++++++++++-- .../src/Wire/EnterpriseLoginSubsystem/Error.hs | 7 ------- .../Wire/EnterpriseLoginSubsystem/Interpreter.hs | 4 ++-- 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index 50901593ee8..2501aeebe4f 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -14,6 +14,12 @@ data InvitationFlow = ExistingUser | NewUser deriving (Show, Eq, Generic) deriving (Arbitrary) via GenericUniform InvitationFlow +-- TODO: refactor this some more. make it more type-safe. +data GuardResult + = GuardResultSuccess + | GuardResultIncompatibleValues [(Text, Text)] -- Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg)? mkStatus 423 "Locked"? + deriving (Eq, Show, Generic) + data EnterpriseLoginSubsystem m a where LockDomain :: Domain -> EnterpriseLoginSubsystem m () UnlockDomain :: Domain -> EnterpriseLoginSubsystem m () @@ -22,7 +28,10 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () - GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m () + -- | These following guard functions encapsulate the parts of the behavior of api end-points + -- that depends on the domain registration record, if available. The result can serve as a + -- DSL to be interpreted by the caller. + GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m GuardResult + GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m GuardResult makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index b585b233a66..9392c41f4a4 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -12,8 +12,6 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError - | EnterpriseLoginSubsystemGuardFailed LText - | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError @@ -27,8 +25,3 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnlockError -> Wai.mkError status409 "unlock-error" "Domain can only be unlocked from a locked state" EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" - EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) - EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) - where - status423 :: Status - status423 = mkStatus 423 "Locked" diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 5b5b88bba64..aa55431afaf 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -369,7 +369,7 @@ guardEmailDomainRegistrationTeamInvitationImpl :: InvitationFlow -> TeamId -> EmailAddress -> - Sem r () + Sem r GuardResult guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do mReg <- emailToDomainRegistration email for_ mReg $ \reg -> do @@ -393,7 +393,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do then ok else nope $ "`teamInvite` is restricted to another team." where - ok = pure () + ok = pure GuardResultSuccess nope = throw . EnterpriseLoginSubsystemGuardFailed guardEmailDomainRegistrationRegisterImpl :: From e11f35fe829b2b871ce642a64ebd3a772dad202b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 15 Jan 2025 08:53:51 +0100 Subject: [PATCH 20/48] Revert "[experiment / wip] make guard functions return a result value..." This reverts commit e0b0af52f1103e8ba9c5afc6c89aa501f7a82269. --- .../src/Wire/EnterpriseLoginSubsystem.hs | 13 ++----------- .../src/Wire/EnterpriseLoginSubsystem/Error.hs | 7 +++++++ .../Wire/EnterpriseLoginSubsystem/Interpreter.hs | 4 ++-- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs index 2501aeebe4f..50901593ee8 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs @@ -14,12 +14,6 @@ data InvitationFlow = ExistingUser | NewUser deriving (Show, Eq, Generic) deriving (Arbitrary) via GenericUniform InvitationFlow --- TODO: refactor this some more. make it more type-safe. -data GuardResult - = GuardResultSuccess - | GuardResultIncompatibleValues [(Text, Text)] -- Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg)? mkStatus 423 "Locked"? - deriving (Eq, Show, Generic) - data EnterpriseLoginSubsystem m a where LockDomain :: Domain -> EnterpriseLoginSubsystem m () UnlockDomain :: Domain -> EnterpriseLoginSubsystem m () @@ -28,10 +22,7 @@ data EnterpriseLoginSubsystem m a where UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - -- | These following guard functions encapsulate the parts of the behavior of api end-points - -- that depends on the domain registration record, if available. The result can serve as a - -- DSL to be interpreted by the caller. - GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m GuardResult - GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m GuardResult + GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m () + GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m () makeSem ''EnterpriseLoginSubsystem diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 9392c41f4a4..b585b233a66 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -12,6 +12,8 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError + | EnterpriseLoginSubsystemGuardFailed LText + | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError @@ -25,3 +27,8 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnlockError -> Wai.mkError status409 "unlock-error" "Domain can only be unlocked from a locked state" EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" + EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) + EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) + where + status423 :: Status + status423 = mkStatus 423 "Locked" diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index aa55431afaf..5b5b88bba64 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -369,7 +369,7 @@ guardEmailDomainRegistrationTeamInvitationImpl :: InvitationFlow -> TeamId -> EmailAddress -> - Sem r GuardResult + Sem r () guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do mReg <- emailToDomainRegistration email for_ mReg $ \reg -> do @@ -393,7 +393,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do then ok else nope $ "`teamInvite` is restricted to another team." where - ok = pure GuardResultSuccess + ok = pure () nope = throw . EnterpriseLoginSubsystemGuardFailed guardEmailDomainRegistrationRegisterImpl :: From 5fb6da5b10a6d6b743482c982853b00e9b3380fc Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Fri, 17 Jan 2025 11:17:43 +0100 Subject: [PATCH 21/48] Fix linting issue --- .../test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs index 2072a606d98..ed08752766c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/GalleyAPIAccess.hs @@ -18,11 +18,11 @@ miniGalleyAPIAccess :: miniGalleyAPIAccess member configs = interpret $ \case CreateSelfConv _ -> error "CreateSelfConv not implemented in miniGalleyAPIAccess" GetConv _ _ -> error "GetConv not implemented in miniGalleyAPIAccess" - GetTeamConv _ _ _ -> error "GetTeamConv not implemented in miniGalleyAPIAccess" + GetTeamConv {} -> error "GetTeamConv not implemented in miniGalleyAPIAccess" NewClient _ _ -> error "NewClient not implemented in miniGalleyAPIAccess" CheckUserCanJoinTeam _ -> error "CheckUserCanJoinTeam not implemented in miniGalleyAPIAccess" - AddTeamMember _ _ _ _ -> error "AddTeamMember not implemented in miniGalleyAPIAccess" - CreateTeam _ _ _ -> error "CreateTeam not implemented in miniGalleyAPIAccess" + AddTeamMember {} -> error "AddTeamMember not implemented in miniGalleyAPIAccess" + CreateTeam {} -> error "CreateTeam not implemented in miniGalleyAPIAccess" GetTeamMember _ _ -> pure member GetTeamMembers _ -> error "GetTeamMembers not implemented in miniGalleyAPIAccess" GetTeamId _ -> error "GetTeamId not implemented in miniGalleyAPIAccess" @@ -31,14 +31,14 @@ miniGalleyAPIAccess member configs = interpret $ \case GetTeamLegalHoldStatus _ -> error "GetTeamLegalHoldStatus not implemented in miniGalleyAPIAccess" GetUserLegalholdStatus _ _ -> error "GetUserLegalholdStatus not implemented in miniGalleyAPIAccess" GetTeamSearchVisibility _ -> error "GetTeamSearchVisibility not implemented in miniGalleyAPIAccess" - ChangeTeamStatus _ _ _ -> error "ChangeTeamStatus not implemented in miniGalleyAPIAccess" + ChangeTeamStatus {} -> error "ChangeTeamStatus not implemented in miniGalleyAPIAccess" MemberIsTeamOwner _ _ -> error "MemberIsTeamOwner not implemented in miniGalleyAPIAccess" GetAllTeamFeaturesForUser _ -> pure configs GetFeatureConfigForTeam tid -> pure $ getFeatureConfigForTeamImpl configs tid GetVerificationCodeEnabled _ -> error "GetVerificationCodeEnabled not implemented in miniGalleyAPIAccess" GetExposeInvitationURLsToTeamAdmin _ -> error "GetExposeInvitationURLsToTeamAdmin not implemented in miniGalleyAPIAccess" IsMLSOne2OneEstablished _ _ -> error "IsMLSOne2OneEstablished not implemented in miniGalleyAPIAccess" - UnblockConversation _ _ _ -> error "UnblockConversation not implemented in miniGalleyAPIAccess" + UnblockConversation {} -> error "UnblockConversation not implemented in miniGalleyAPIAccess" GetEJPDConvInfo _ -> error "GetEJPDConvInfo not implemented in miniGalleyAPIAccess" getFeatureConfigForTeamImpl :: forall feature. (IsFeatureConfig feature) => AllTeamFeatures -> TeamId -> LockableFeature feature From 48795a576fb12650907bfa42ccd2027eff26d91f Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Fri, 17 Jan 2025 12:47:31 +0100 Subject: [PATCH 22/48] WIP: Test registration backend redirect --- .../src/Wire/EnterpriseLoginSubsystem/Error.hs | 3 ++- .../Wire/EnterpriseLoginSubsystem/Interpreter.hs | 5 +++-- .../EnterpriseLoginSubsystem/InterpreterSpec.hs | 16 +++++++++++++++- services/brig/src/Brig/API/Public.hs | 9 ++++++--- 4 files changed, 26 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index b585b233a66..8a131358e06 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -12,7 +12,8 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError - | EnterpriseLoginSubsystemGuardFailed LText + | -- TODO: Better structured errors: data GuardFailure = InvalidDomain LText | DomRedirSetToSSO | ... + EnterpriseLoginSubsystemGuardFailed LText | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 5b5b88bba64..afa69d56ac8 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -10,6 +10,7 @@ where import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson +import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain, domainText, mkDomain) import Data.Id @@ -29,6 +30,7 @@ import Polysemy.TinyLog qualified as Log import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Log import Text.Email.Parser qualified as Email +import URI.ByteString (serializeURIRef) import Wire.API.EnterpriseLogin import Wire.API.User.EmailAddress (EmailAddress, fromEmail) import Wire.DomainRegistrationStore @@ -412,8 +414,7 @@ guardEmailDomainRegistrationRegisterImpl email = do Locked -> ok SSO _ -> nope "`domain_redirect` is set to `sso:{code}`" Backend url -> - -- TODO: this should make /register respond with 302 found or something similar. - undefined url + nope $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url NoRegistration -> nope "`domain_redirect` is set to `no_registration`" PreAuthorized -> ok where diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index ee468de5a4e..57f07d600f1 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -56,7 +56,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do it "UpdateDomainRegistration" pending it "DeleteDomain" pending - prop "GuardEmailDomainRegistrationState" $ + prop "GuardEmailDomainRegistrationTeamInvitation" $ \flow sameTeam teamId email preDomRegEntry -> let setTeamId :: DomainRegistrationUpdate -> TeamId -> DomainRegistrationUpdate setTeamId update tid = case update.teamInvite of @@ -87,3 +87,17 @@ spec = describe "EnterpriseLoginSubsystem" $ do NewUser -> teamNotAllowedOrWrongTeamIdFails _ -> teamNotAllowedOrWrongTeamIdFails in backendRedirectOrNoRegistrationFails + + focus . prop "GuardEmailDomainRegistrationRegister" $ + \email domRegEntry -> + let outcome = runDependencies . runEnterpriseLoginSubsystem $ do + updateDomainRegistration (Domain . cs $ domainPart email) domRegEntry + guardEmailDomainRegistrationRegister email + expected = case domRegEntry.domainRedirect of + None -> Right () + Locked -> Right () + SSO _ -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `sso:{code}`" + Backend url -> Left $ EnterpriseLoginSubsystemGuardFailed "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url + NoRegistration -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no_registration`" + PreAuthorized -> Right () + in outcome === expected diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 7c7e5d33efe..aade8560f68 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -151,6 +151,7 @@ import Wire.DeleteQueue import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem import Wire.EmailSubsystem.Template +import Wire.EnterpriseLoginSubsystem import Wire.Error import Wire.Events (Events) import Wire.FederationConfigStore (FederationConfigStore) @@ -367,7 +368,8 @@ servantSitemap :: Member IndexedUserStore r, Member (ConnectionStore InternalPaging) r, Member HashPassword r, - Member (Input UserSubsystemConfig) r + Member (Input UserSubsystemConfig) r, + Member EnterpriseLoginSubsystem r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -825,7 +827,8 @@ createUser :: Member PasswordResetCodeStore r, Member HashPassword r, Member EmailSending r, - Member ActivationCodeStore r + Member ActivationCodeStore r, + Member EnterpriseLoginSubsystem r ) => Public.NewUserPublic -> Handler r (Either Public.RegisterError Public.RegisterSuccess) @@ -834,7 +837,7 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do for_ (Public.newUserEmail new) $ mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError -- TODO: remove the conditional once we have a failing test that is fixed by this. - when False $ guardEmailDomainRegistrationRegisterImpl email + when False $ lift . liftSem $ guardEmailDomainRegistrationRegister undefined result <- API.createUser new let acc = createdAccount result From ccce7b21ac01b5efb28ca86196df93162bb399f5 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 14:33:39 +0100 Subject: [PATCH 23/48] Fix imports. --- .../unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs | 6 +++++- libs/wire-subsystems/wire-subsystems.cabal | 1 + 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 57f07d600f1..83a38962500 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -1,8 +1,11 @@ module Wire.EnterpriseLoginSubsystem.InterpreterSpec where +import Data.ByteString.Builder (toLazyByteString) import Data.Domain import Data.Id +import Data.Misc (httpsUrl) import Data.String.Conversions (cs) +import Data.Text.Lazy.Encoding qualified as LT import Imports import Polysemy import Polysemy.Error @@ -12,6 +15,7 @@ import Polysemy.TinyLog import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck +import URI.ByteString (serializeURIRef) import Wire.API.EnterpriseLogin import Wire.API.User.EmailAddress (domainPart) import Wire.DomainRegistrationStore @@ -97,7 +101,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do None -> Right () Locked -> Right () SSO _ -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `sso:{code}`" - Backend url -> Left $ EnterpriseLoginSubsystemGuardFailed "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url + Backend url -> Left $ EnterpriseLoginSubsystemGuardFailed $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url NoRegistration -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no_registration`" PreAuthorized -> Right () in outcome === expected diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index cb2971caf19..21f9ad10268 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -312,6 +312,7 @@ test-suite wire-subsystems-tests , tinylog , transformers , types-common + , uri-bytestring , uuid , wire-api , wire-api-federation From bde5381ec6c89c522328a1671ce94bd9d2594638 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Fri, 17 Jan 2025 15:23:01 +0100 Subject: [PATCH 24/48] WIP: Save for Matthias --- .../Wire/EnterpriseLoginSubsystem/Error.hs | 19 +++++++++++++++++-- .../EnterpriseLoginSubsystem/Interpreter.hs | 10 +++++----- 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 8a131358e06..f556c1b2cbb 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -1,8 +1,10 @@ module Wire.EnterpriseLoginSubsystem.Error where +import Data.Misc (HttpsUrl) import Imports import Network.HTTP.Types import Network.Wai.Utilities qualified as Wai +import SAML2.WebSSO.Types (IdPId) import Wire.Error data EnterpriseLoginSubsystemError @@ -12,13 +14,26 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError - | -- TODO: Better structured errors: data GuardFailure = InvalidDomain LText | DomRedirSetToSSO | ... - EnterpriseLoginSubsystemGuardFailed LText + | EnterpriseLoginSubsystemGuardFailed GuardFailure | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError +data GuardFailure + = BackendRedirect HttpsUrl + | DomRedirSetToSSO IdPId + | NoRegistration + | -- TODO: Will this ever be reached? + InvalidDomain String + deriving (Show, Eq) + +-- \| EnterpriseLoginSubsystemGuardFailed GuardFailure +-- \| EnterpriseLoginSubsystemGuardInvalidDomain LText +-- EnterpriseLoginSubsystemGuardFailed (BackendRedirect url) -> Wai.mkError status302 "enterprise-login-guard-failed" ("condition failed: " <> msg) +-- EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) +-- EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) + enterpriseLoginSubsystemErrorToHttpError :: EnterpriseLoginSubsystemError -> HttpError enterpriseLoginSubsystemErrorToHttpError = StdError . \case diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index afa69d56ac8..cd2eaaf0ebc 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -36,7 +36,7 @@ import Wire.API.User.EmailAddress (EmailAddress, fromEmail) import Wire.DomainRegistrationStore import Wire.EmailSending (EmailSending, sendMail) import Wire.EnterpriseLoginSubsystem -import Wire.EnterpriseLoginSubsystem.Error +import Wire.EnterpriseLoginSubsystem.Error as Error data EnterpriseLoginSubsystemConfig = EnterpriseLoginSubsystemConfig { auditEmailSender :: EmailAddress, @@ -381,7 +381,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do Locked -> ok SSO _ -> ok Backend _ -> ok - NoRegistration -> case invitationFlow of + Wire.API.EnterpriseLogin.NoRegistration -> case invitationFlow of ExistingUser -> nope "`domain_redirect` is set to `no-registration`" NewUser -> ok PreAuthorized -> ok @@ -412,10 +412,10 @@ guardEmailDomainRegistrationRegisterImpl email = do case reg.domainRedirect of None -> ok Locked -> ok - SSO _ -> nope "`domain_redirect` is set to `sso:{code}`" + SSO idpId -> nope $ DomRedirSetToSSO idpId Backend url -> - nope $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url - NoRegistration -> nope "`domain_redirect` is set to `no_registration`" + nope $ BackendRedirect url + Wire.API.EnterpriseLogin.NoRegistration -> nope .Error.NoRegistration PreAuthorized -> ok where ok = pure () From 970781e62b2f215a687200b3642961dfe286811f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 15:24:18 +0100 Subject: [PATCH 25/48] Revert "WIP: Save for Matthias" This reverts commit bde5381ec6c89c522328a1671ce94bd9d2594638. --- .../Wire/EnterpriseLoginSubsystem/Error.hs | 19 ++----------------- .../EnterpriseLoginSubsystem/Interpreter.hs | 10 +++++----- 2 files changed, 7 insertions(+), 22 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index f556c1b2cbb..8a131358e06 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -1,10 +1,8 @@ module Wire.EnterpriseLoginSubsystem.Error where -import Data.Misc (HttpsUrl) import Imports import Network.HTTP.Types import Network.Wai.Utilities qualified as Wai -import SAML2.WebSSO.Types (IdPId) import Wire.Error data EnterpriseLoginSubsystemError @@ -14,26 +12,13 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError - | EnterpriseLoginSubsystemGuardFailed GuardFailure + | -- TODO: Better structured errors: data GuardFailure = InvalidDomain LText | DomRedirSetToSSO | ... + EnterpriseLoginSubsystemGuardFailed LText | EnterpriseLoginSubsystemGuardInvalidDomain LText deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError -data GuardFailure - = BackendRedirect HttpsUrl - | DomRedirSetToSSO IdPId - | NoRegistration - | -- TODO: Will this ever be reached? - InvalidDomain String - deriving (Show, Eq) - --- \| EnterpriseLoginSubsystemGuardFailed GuardFailure --- \| EnterpriseLoginSubsystemGuardInvalidDomain LText --- EnterpriseLoginSubsystemGuardFailed (BackendRedirect url) -> Wai.mkError status302 "enterprise-login-guard-failed" ("condition failed: " <> msg) --- EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) --- EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) - enterpriseLoginSubsystemErrorToHttpError :: EnterpriseLoginSubsystemError -> HttpError enterpriseLoginSubsystemErrorToHttpError = StdError . \case diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index cd2eaaf0ebc..afa69d56ac8 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -36,7 +36,7 @@ import Wire.API.User.EmailAddress (EmailAddress, fromEmail) import Wire.DomainRegistrationStore import Wire.EmailSending (EmailSending, sendMail) import Wire.EnterpriseLoginSubsystem -import Wire.EnterpriseLoginSubsystem.Error as Error +import Wire.EnterpriseLoginSubsystem.Error data EnterpriseLoginSubsystemConfig = EnterpriseLoginSubsystemConfig { auditEmailSender :: EmailAddress, @@ -381,7 +381,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do Locked -> ok SSO _ -> ok Backend _ -> ok - Wire.API.EnterpriseLogin.NoRegistration -> case invitationFlow of + NoRegistration -> case invitationFlow of ExistingUser -> nope "`domain_redirect` is set to `no-registration`" NewUser -> ok PreAuthorized -> ok @@ -412,10 +412,10 @@ guardEmailDomainRegistrationRegisterImpl email = do case reg.domainRedirect of None -> ok Locked -> ok - SSO idpId -> nope $ DomRedirSetToSSO idpId + SSO _ -> nope "`domain_redirect` is set to `sso:{code}`" Backend url -> - nope $ BackendRedirect url - Wire.API.EnterpriseLogin.NoRegistration -> nope .Error.NoRegistration + nope $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url + NoRegistration -> nope "`domain_redirect` is set to `no_registration`" PreAuthorized -> ok where ok = pure () From 5e3d1bec7fa51e009efa48fd890a7f7bce4d55ba Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 15:59:07 +0100 Subject: [PATCH 26/48] More structure for guard errors. --- .../Wire/EnterpriseLoginSubsystem/Error.hs | 28 +++++++++++++++---- .../EnterpriseLoginSubsystem/Interpreter.hs | 23 ++++++++------- .../InterpreterSpec.hs | 18 +++++------- .../EnterpriseLoginSubsystem.hs | 6 ++-- .../InterpreterSpec.hs | 6 ++-- 5 files changed, 47 insertions(+), 34 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 8a131358e06..3263e3f4b98 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -1,5 +1,6 @@ module Wire.EnterpriseLoginSubsystem.Error where +import Data.Text.Lazy qualified as LT import Imports import Network.HTTP.Types import Network.Wai.Utilities qualified as Wai @@ -12,13 +13,20 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnlockError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError - | -- TODO: Better structured errors: data GuardFailure = InvalidDomain LText | DomRedirSetToSSO | ... - EnterpriseLoginSubsystemGuardFailed LText - | EnterpriseLoginSubsystemGuardInvalidDomain LText + | EnterpriseLoginSubsystemGuardFailed GuardFailure deriving (Show, Eq) instance Exception EnterpriseLoginSubsystemError +data GuardFailure + = DomRedirSetToSSO + | DomRedirSetToBackend + | DomRedirSetToNoRegistration + | TeamInviteSetToNotAllowed + | TeamInviteRestrictedToOtherTeam + | InvalidDomain String + deriving (Show, Eq) + enterpriseLoginSubsystemErrorToHttpError :: EnterpriseLoginSubsystemError -> HttpError enterpriseLoginSubsystemErrorToHttpError = StdError . \case @@ -28,8 +36,18 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnlockError -> Wai.mkError status409 "unlock-error" "Domain can only be unlocked from a locked state" EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" - EnterpriseLoginSubsystemGuardFailed msg -> Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) - EnterpriseLoginSubsystemGuardInvalidDomain msg -> Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> msg) + EnterpriseLoginSubsystemGuardFailed err -> + -- TODO: maybe we can show these wai errors to client devs and see if they have change + -- requests? also, are we leaking too much info? + let e409 msg = Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) + e423 msg = Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> LT.pack msg) + in case err of + DomRedirSetToSSO -> e409 "`domain_redirect` is set to `sso:{code}`" + DomRedirSetToBackend -> e409 "`domain_redirect` is set to `backend`" -- TODO: https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1570832467/Email+domain+registration+and+configuration says this should be 403 with another label? + DomRedirSetToNoRegistration -> e409 "`domain_redirect` is set to `no-registration`" + TeamInviteSetToNotAllowed -> e409 "`teamInvite` is set to `not-allowed`" + TeamInviteRestrictedToOtherTeam -> e409 "`teamInvite` is restricted to another team." + InvalidDomain msg -> e423 msg where status423 :: Status status423 = mkStatus 423 "Locked" diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index afa69d56ac8..f5e80034f4d 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -10,14 +10,12 @@ where import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson -import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Conversion (toByteString') import Data.Domain (Domain, domainText, mkDomain) import Data.Id import Data.Misc (HttpsUrl (..)) import Data.Text.Encoding as T import Data.Text.Internal.Builder (fromLazyText, fromText, toLazyText) -import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Encoding as LT import Imports hiding (lookup) @@ -30,13 +28,12 @@ import Polysemy.TinyLog qualified as Log import SAML2.WebSSO qualified as SAML import System.Logger.Message qualified as Log import Text.Email.Parser qualified as Email -import URI.ByteString (serializeURIRef) import Wire.API.EnterpriseLogin import Wire.API.User.EmailAddress (EmailAddress, fromEmail) import Wire.DomainRegistrationStore import Wire.EmailSending (EmailSending, sendMail) import Wire.EnterpriseLoginSubsystem -import Wire.EnterpriseLoginSubsystem.Error +import Wire.EnterpriseLoginSubsystem.Error as Error data EnterpriseLoginSubsystemConfig = EnterpriseLoginSubsystemConfig { auditEmailSender :: EmailAddress, @@ -360,7 +357,10 @@ emailToDomainRegistration :: Sem r (Maybe DomainRegistration) emailToDomainRegistration email = case mkDomain $ T.decodeUtf8 $ Email.domainPart email of Right dom -> tryGetDomainRegistrationImpl dom - Left msg -> throw $ EnterpriseLoginSubsystemGuardInvalidDomain (LT.pack msg) + Left msg -> + -- The EmailAddress parser and servant *should* make this impossible, but they use + -- different parsers, one of us is ours and may change any time, so who knows? + throw . EnterpriseLoginSubsystemGuardFailed $ InvalidDomain msg guardEmailDomainRegistrationTeamInvitationImpl :: forall r. @@ -382,18 +382,18 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do SSO _ -> ok Backend _ -> ok NoRegistration -> case invitationFlow of - ExistingUser -> nope "`domain_redirect` is set to `no-registration`" + ExistingUser -> nope DomRedirSetToNoRegistration NewUser -> ok PreAuthorized -> ok -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not -- the team of the inviter case reg.teamInvite of Allowed -> ok - NotAllowed -> nope "`teamInvite` is set to `not-allowed`" + NotAllowed -> nope TeamInviteSetToNotAllowed Team allowedTid -> if allowedTid == tid then ok - else nope $ "`teamInvite` is restricted to another team." + else nope TeamInviteRestrictedToOtherTeam where ok = pure () nope = throw . EnterpriseLoginSubsystemGuardFailed @@ -412,10 +412,9 @@ guardEmailDomainRegistrationRegisterImpl email = do case reg.domainRedirect of None -> ok Locked -> ok - SSO _ -> nope "`domain_redirect` is set to `sso:{code}`" - Backend url -> - nope $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url - NoRegistration -> nope "`domain_redirect` is set to `no_registration`" + SSO _ -> nope DomRedirSetToSSO + Backend _ -> nope DomRedirSetToBackend + NoRegistration -> nope DomRedirSetToNoRegistration PreAuthorized -> ok where ok = pure () diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 83a38962500..41faf342d49 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -1,11 +1,8 @@ module Wire.EnterpriseLoginSubsystem.InterpreterSpec where -import Data.ByteString.Builder (toLazyByteString) import Data.Domain import Data.Id -import Data.Misc (httpsUrl) import Data.String.Conversions (cs) -import Data.Text.Lazy.Encoding qualified as LT import Imports import Polysemy import Polysemy.Error @@ -15,7 +12,6 @@ import Polysemy.TinyLog import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck -import URI.ByteString (serializeURIRef) import Wire.API.EnterpriseLogin import Wire.API.User.EmailAddress (domainPart) import Wire.DomainRegistrationStore @@ -60,7 +56,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do it "UpdateDomainRegistration" pending it "DeleteDomain" pending - prop "GuardEmailDomainRegistrationTeamInvitation" $ + focus . prop "GuardEmailDomainRegistrationTeamInvitation" $ \flow sameTeam teamId email preDomRegEntry -> let setTeamId :: DomainRegistrationUpdate -> TeamId -> DomainRegistrationUpdate setTeamId update tid = case update.teamInvite of @@ -75,11 +71,11 @@ spec = describe "EnterpriseLoginSubsystem" $ do teamNotAllowedOrWrongTeamIdFails = case domRegEntry.teamInvite of Allowed -> outcome === Right () - NotAllowed -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is set to `not-allowed`") + NotAllowed -> outcome === Left (EnterpriseLoginSubsystemGuardFailed TeamInviteSetToNotAllowed) Team allowedTid -> if allowedTid == teamId then outcome === Right () - else outcome === Left (EnterpriseLoginSubsystemGuardFailed "`teamInvite` is restricted to another team.") + else outcome === Left (EnterpriseLoginSubsystemGuardFailed TeamInviteRestrictedToOtherTeam) backendRedirectOrNoRegistrationFails = case domRegEntry.domainRedirect of Backend _ -> @@ -87,7 +83,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do teamNotAllowedOrWrongTeamIdFails NoRegistration -> case flow of - ExistingUser -> outcome === Left (EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no-registration`") + ExistingUser -> outcome === Left (EnterpriseLoginSubsystemGuardFailed DomRedirSetToNoRegistration) NewUser -> teamNotAllowedOrWrongTeamIdFails _ -> teamNotAllowedOrWrongTeamIdFails in backendRedirectOrNoRegistrationFails @@ -100,8 +96,8 @@ spec = describe "EnterpriseLoginSubsystem" $ do expected = case domRegEntry.domainRedirect of None -> Right () Locked -> Right () - SSO _ -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `sso:{code}`" - Backend url -> Left $ EnterpriseLoginSubsystemGuardFailed $ "TODO: dummy text: url=" <> (LT.decodeUtf8 . toLazyByteString . serializeURIRef . httpsUrl) url - NoRegistration -> Left $ EnterpriseLoginSubsystemGuardFailed "`domain_redirect` is set to `no_registration`" + SSO _ -> Left $ EnterpriseLoginSubsystemGuardFailed DomRedirSetToSSO + Backend _ -> Left $ EnterpriseLoginSubsystemGuardFailed DomRedirSetToBackend + NoRegistration -> Left $ EnterpriseLoginSubsystemGuardFailed DomRedirSetToNoRegistration PreAuthorized -> Right () in outcome === expected diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 93927435729..32196a9ca8d 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -4,7 +4,7 @@ import Imports import Polysemy import Polysemy.Error (Error, throw) import Wire.EnterpriseLoginSubsystem -import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError (EnterpriseLoginSubsystemGuardFailed)) +import Wire.EnterpriseLoginSubsystem.Error -- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! enterpriseLoginSubsystemTestInterpreter :: @@ -19,5 +19,5 @@ enterpriseLoginSubsystemTestInterpreter = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationTeamInvitation {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" - GuardEmailDomainRegistrationRegister {} -> throw $ EnterpriseLoginSubsystemGuardFailed "error" + GuardEmailDomainRegistrationTeamInvitation {} -> throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain "mock interpreter: don't know which error, i'm not very smart") + GuardEmailDomainRegistrationRegister {} -> throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain "mock interpreter: don't know which error, i'm not very smart") diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 26d22d2fd5d..fb793b5b552 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -22,7 +22,7 @@ import Wire.API.Team.Permission import Wire.API.User import Wire.EmailSubsystem import Wire.EnterpriseLoginSubsystem -import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError (EnterpriseLoginSubsystemGuardFailed)) +import Wire.EnterpriseLoginSubsystem.Error (EnterpriseLoginSubsystemError) import Wire.GalleyAPIAccess import Wire.InvitationStore import Wire.MockInterpreters @@ -80,7 +80,7 @@ runAllEffects args = spec :: Spec spec = do describe "InviteUser" $ do - prop "calls guardEmailDomainRegistrationState if appropriate" $ + focus . prop "calls guardEmailDomainRegistrationState if appropriate" $ \preInviter tid inviterEmail inviteeEmail -> let cfg = TeamInvitationSubsystemConfig @@ -103,4 +103,4 @@ spec = do args = RunAllEffectsArgs teamMember [inviter] outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser luid tid invReq - in outcome === Left (EnterpriseLoginSubsystemGuardFailed "error") + in counterexample (show outcome) (isLeft outcome === True) From 977a4384bd028ee9dd6ddc1378e369f49d5c9d12 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 16:16:17 +0100 Subject: [PATCH 27/48] Arbitrary: use instance for Domain in instance for EmailAddress. --- .../src/Wire/API/User/EmailAddress.hs | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index 6cecd5c3b85..aa577828917 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -17,9 +17,11 @@ where import Cassandra.CQL qualified as C import Data.ByteString.Conversion hiding (toByteString) import Data.Data (Proxy (..)) +import Data.Domain import Data.OpenApi hiding (Schema, ToSchema) import Data.Schema import Data.Text hiding (null) +import Data.Text qualified as T import Data.Text.Encoding import Data.Text.Encoding.Error import Deriving.Aeson @@ -93,19 +95,12 @@ emailAddressText = emailAddress . encodeUtf8 arbitraryValidMail :: Gen EmailAddress arbitraryValidMail = do loc <- arbitrary `suchThat` isValidLoc - dom <- (addTld . trimDots <$> arbitrary) `suchThat` isValidDom - pure . fromJust $ emailAddress (fromString $ loc <> "@" <> dom) + Domain dom <- arbitrary + pure . fromJust $ emailAddress (fromString $ loc <> "@" <> T.unpack dom) where notAt :: String -> Bool notAt = notElem '@' - trimDots :: String -> String - trimDots = Imports.dropWhile (== '.') . Imports.dropWhileEnd (== '.') - - -- at some places dotless domains do not work, so we add a tld - addTld :: String -> String - addTld str = if '.' `notElem` str then str <> ".tld" else str - notNull = not . null isValidLoc :: String -> Bool @@ -114,12 +109,6 @@ arbitraryValidMail = do && notAt x && isValid (fromString (x <> "@mail.com")) - isValidDom :: String -> Bool - isValidDom x = - notNull x - && notAt x - && isValid (fromString ("me@" <> x)) - -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this -- function total without all that praying and hoping. emailToSAMLNameID :: EmailAddress -> Either String SAML.NameID From 6a2c1de0a27edf39f8d15a25ff43576a985fbe78 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 16:32:31 +0100 Subject: [PATCH 28/48] Call register guard in brig. (test still missing) --- services/brig/src/Brig/API/Public.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index aade8560f68..7b256a5fc4f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -139,6 +139,7 @@ import Wire.API.User.Client qualified as Public import Wire.API.User.Client.DPoPAccessToken import Wire.API.User.Client.Prekey qualified as Public import Wire.API.User.Handle qualified as Public +import Wire.API.User.Identity import Wire.API.User.Password qualified as Public import Wire.API.User.RichInfo qualified as Public import Wire.API.User.Search qualified as Public @@ -836,8 +837,9 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do API.checkRestrictedUserCreation new for_ (Public.newUserEmail new) $ mapExceptT wrapHttp . checkAllowlistWithError RegisterErrorAllowlistError - -- TODO: remove the conditional once we have a failing test that is fixed by this. - when False $ lift . liftSem $ guardEmailDomainRegistrationRegister undefined + -- TODO: we need an integration test for this, but it'd be easier to write that in a + -- different PR where we have https://github.com/wireapp/wire-server/pull/4389. + (lift . liftSem . guardEmailDomainRegistrationRegister) `mapM_` (emailIdentity =<< new.newUserIdentity) result <- API.createUser new let acc = createdAccount result From ae12d2615f69ce823aac1837aba6ce4a7ad5e546 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 16:37:16 +0100 Subject: [PATCH 29/48] Changelog. --- ...g-onboarding-flow-to-new-domain-registration-constraints | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints diff --git a/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints b/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints new file mode 100644 index 00000000000..db61d503eff --- /dev/null +++ b/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints @@ -0,0 +1,6 @@ +Adjust existing onboarding flow to new domain registration constraints. + +end-points: + +- POST /teams/{id}/invitations +- POST /register From 0123544be4575cf445ef0e9a94de13dab8c1c56a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 16:39:44 +0100 Subject: [PATCH 30/48] Remove dangling hspec.focus. --- .../unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs | 4 ++-- .../test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 41faf342d49..7dc1255c08b 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -56,7 +56,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do it "UpdateDomainRegistration" pending it "DeleteDomain" pending - focus . prop "GuardEmailDomainRegistrationTeamInvitation" $ + prop "GuardEmailDomainRegistrationTeamInvitation" $ \flow sameTeam teamId email preDomRegEntry -> let setTeamId :: DomainRegistrationUpdate -> TeamId -> DomainRegistrationUpdate setTeamId update tid = case update.teamInvite of @@ -88,7 +88,7 @@ spec = describe "EnterpriseLoginSubsystem" $ do _ -> teamNotAllowedOrWrongTeamIdFails in backendRedirectOrNoRegistrationFails - focus . prop "GuardEmailDomainRegistrationRegister" $ + prop "GuardEmailDomainRegistrationRegister" $ \email domRegEntry -> let outcome = runDependencies . runEnterpriseLoginSubsystem $ do updateDomainRegistration (Domain . cs $ domainPart email) domRegEntry diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index fb793b5b552..b29275846dc 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -80,7 +80,7 @@ runAllEffects args = spec :: Spec spec = do describe "InviteUser" $ do - focus . prop "calls guardEmailDomainRegistrationState if appropriate" $ + prop "calls guardEmailDomainRegistrationState if appropriate" $ \preInviter tid inviterEmail inviteeEmail -> let cfg = TeamInvitationSubsystemConfig From 139731caa8dcede90c45e8327c9f975cd88ae207 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 17:08:01 +0100 Subject: [PATCH 31/48] make sanitize-pr --- libs/wire-subsystems/default.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index f5c755c2ab3..19d1ab39b2a 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -208,6 +208,7 @@ mkDerivation { tinylog transformers types-common + uri-bytestring uuid wire-api wire-api-federation From 5455369e1ae2a74080182dfe45c1032b47fbc309 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 17 Jan 2025 17:08:34 +0100 Subject: [PATCH 32/48] nit-pick --- .../src/Wire/TeamInvitationSubsystem/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index 39ceaae3cc2..cd559a89718 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -142,7 +142,7 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe && isNothing user.userTeam -> pure True | otherwise -> throw TeamInvitationEmailTaken - let flow = if isPersonalUserMigration then ExistingUser else ELS.NewUser + let flow = if isPersonalUserMigration then ELS.ExistingUser else ELS.NewUser in guardEmailDomainRegistrationTeamInvitation flow tid email maxSize <- maxTeamSize <$> input From ef4704dbaf46d2df61d7f4e48d7d5be1d0df5ecb Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 20 Jan 2025 08:58:53 +0100 Subject: [PATCH 33/48] Fix imports. --- libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs index 759850c8d92..2f46710f894 100644 --- a/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs +++ b/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs @@ -2,7 +2,6 @@ module Wire.DomainRegistrationStore where -import Amazonka.Request (delete) import Data.Domain as Domain import Data.Id import Data.Misc From 23d3442ae6ecd724682f31daa5e046e3f74f579f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 20 Jan 2025 09:02:43 +0100 Subject: [PATCH 34/48] Better name for mock interpreter. --- .../unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs | 2 +- .../test/unit/Wire/MockInterpreters/EmailSubsystem.hs | 5 ++--- .../unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 6322f8ab025..329298595b6 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -63,7 +63,7 @@ runAllEffects localDomain preexistingUsers mAllowedEmailDomains = . evalState mempty . evalState mempty . inMemoryUserStoreInterpreter - . emailSubsystemInterpreter + . inMemoryEmailSubsystemInterpreter . discardTinyLogs . evalState mempty . inMemoryPasswordResetCodeStore diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs index 1286668f8bb..a70ff649ce5 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSubsystem.hs @@ -16,9 +16,8 @@ data SentMail = SentMail data SentMailContent = PasswordResetMail PasswordResetPair deriving (Show, Eq) --- TODO: rename to 'emailSubsystemInterpreter' -emailSubsystemInterpreter :: (Member (State (Map EmailAddress [SentMail])) r) => InterpreterFor EmailSubsystem r -emailSubsystemInterpreter = interpret \case +inMemoryEmailSubsystemInterpreter :: (Member (State (Map EmailAddress [SentMail])) r) => InterpreterFor EmailSubsystem r +inMemoryEmailSubsystemInterpreter = interpret \case SendPasswordResetMail email keyCodePair mLocale -> modify $ Map.insertWith (<>) email [SentMail mLocale $ PasswordResetMail keyCodePair] _ -> error "emailSubsystemInterpreter: implement on demand" diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index b29275846dc..9871afed693 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -63,7 +63,7 @@ runAllEffects args = run . userSubsystemTestInterpreter args.initialUsers . evalState mempty - . emailSubsystemInterpreter + . inMemoryEmailSubsystemInterpreter . evalState defaultTime . interpretNowAsState . evalState mempty From 1a2913c2087371c09858b9f3a0160ae35479fbbd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 20 Jan 2025 09:11:09 +0100 Subject: [PATCH 35/48] whitespace. --- .../src/Wire/TeamInvitationSubsystem/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index cd559a89718..ca66cf1e20b 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -84,8 +84,8 @@ inviteUserImpl :: Sem r (Invitation, InvitationLocation) inviteUserImpl luid tid request = do let inviteeRole = fromMaybe defaultRole request.role - let inviteePerms = Teams.rolePermissions inviteeRole + let inviteePerms = Teams.rolePermissions inviteeRole ensurePermissionToAddUser (tUnqualified luid) tid inviteePerms inviterEmail <- From 3b39ebbc40ea4541fe356eade413261f05a346fc Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 20 Jan 2025 09:26:06 +0100 Subject: [PATCH 36/48] Polish error codes / messages. --- .../Wire/EnterpriseLoginSubsystem/Error.hs | 21 +++++++------------ 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index 3263e3f4b98..b8ce345126e 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -37,17 +37,12 @@ enterpriseLoginSubsystemErrorToHttpError = EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO" EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized" EnterpriseLoginSubsystemGuardFailed err -> - -- TODO: maybe we can show these wai errors to client devs and see if they have change - -- requests? also, are we leaking too much info? - let e409 msg = Wai.mkError status409 "enterprise-login-guard-failed" ("condition failed: " <> msg) - e423 msg = Wai.mkError status423 "enterprise-login-guard-failed" ("could not parse domain: " <> LT.pack msg) + let e403 msg = Wai.mkError status403 "condition-failed" msg + e400 msg = Wai.mkError status400 "invalid-domain" (LT.pack msg) in case err of - DomRedirSetToSSO -> e409 "`domain_redirect` is set to `sso:{code}`" - DomRedirSetToBackend -> e409 "`domain_redirect` is set to `backend`" -- TODO: https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1570832467/Email+domain+registration+and+configuration says this should be 403 with another label? - DomRedirSetToNoRegistration -> e409 "`domain_redirect` is set to `no-registration`" - TeamInviteSetToNotAllowed -> e409 "`teamInvite` is set to `not-allowed`" - TeamInviteRestrictedToOtherTeam -> e409 "`teamInvite` is restricted to another team." - InvalidDomain msg -> e423 msg - where - status423 :: Status - status423 = mkStatus 423 "Locked" + DomRedirSetToSSO -> e403 "`domain_redirect` is set to `sso:{code}`" + DomRedirSetToBackend -> e403 "`domain_redirect` is set to `backend`" + DomRedirSetToNoRegistration -> e403 "`domain_redirect` is set to `no-registration`" + TeamInviteSetToNotAllowed -> e403 "`teamInvite` is set to `not-allowed`" + TeamInviteRestrictedToOtherTeam -> e403 "`teamInvite` is restricted to another team." + InvalidDomain msg -> e400 msg -- probably impossible. From 8b4cb953a790387d290f7217a7f29eb56089a7ef Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 09:35:07 +0100 Subject: [PATCH 37/48] orthography Co-authored-by: Sven Tennie --- ...sting-onboarding-flow-to-new-domain-registration-constraints | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints b/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints index db61d503eff..fe630268bfe 100644 --- a/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints +++ b/changelog.d/5-internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints @@ -1,6 +1,6 @@ Adjust existing onboarding flow to new domain registration constraints. -end-points: +Endpoints: - POST /teams/{id}/invitations - POST /register From da1083590d4de68edd9426fb718dbbc0820cc905 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 09:52:32 +0100 Subject: [PATCH 38/48] refactor. --- .../Wire/TeamInvitationSubsystem/Interpreter.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs index ca66cf1e20b..31bfd456e77 100644 --- a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Interpreter.hs @@ -134,16 +134,15 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe throw TeamInvitationBlacklistedEmail mEmailOwner <- getLocalUserAccountByUserKey uke - isPersonalUserMigration <- case mEmailOwner of - Nothing -> pure False + invitationFlow <- case mEmailOwner of + Nothing -> pure ELS.NewUser Just user | invRequest.allowExisting && user.userStatus == Active && isNothing user.userTeam -> - pure True + pure ELS.ExistingUser | otherwise -> throw TeamInvitationEmailTaken - let flow = if isPersonalUserMigration then ELS.ExistingUser else ELS.NewUser - in guardEmailDomainRegistrationTeamInvitation flow tid email + guardEmailDomainRegistrationTeamInvitation invitationFlow tid email maxSize <- maxTeamSize <$> input pending <- Store.countInvitations tid @@ -171,10 +170,9 @@ createInvitation' tid mExpectedInvId inviteeRole mbInviterUid inviterEmail invRe } in Store.insertInvitation insertInv timeout - let sendOp = - if isPersonalUserMigration - then sendTeamInvitationMailPersonalUser - else sendTeamInvitationMail + let sendOp = case invitationFlow of + ELS.ExistingUser -> sendTeamInvitationMailPersonalUser + ELS.NewUser -> sendTeamInvitationMail invitationUrl <- sendOp email tid inviterEmail code invRequest.locale inv <- toInvitation invitationUrl showInvitationUrl newInv From b70855d61ac4c518b1b1215f4150ce7ddd43982c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 10:01:49 +0100 Subject: [PATCH 39/48] refactor tests. --- .../unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs | 8 ++------ libs/wire-subsystems/wire-subsystems.cabal | 1 + 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs index 7dc1255c08b..91d4d768b00 100644 --- a/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/EnterpriseLoginSubsystem/InterpreterSpec.hs @@ -20,6 +20,7 @@ import Wire.EnterpriseLoginSubsystem import Wire.EnterpriseLoginSubsystem.Error import Wire.EnterpriseLoginSubsystem.Interpreter import Wire.MockInterpreters.DomainRegistrationStore +import Wire.MockInterpreters.EmailSending import Wire.Sem.Logger.TinyLog runDependencies :: @@ -34,7 +35,7 @@ runDependencies :: Either EnterpriseLoginSubsystemError a runDependencies = run - . emailSendingInterpreter + . noopEmailSendingInterpreter . runInputConst Nothing . discardTinyLogs . runError @@ -42,11 +43,6 @@ runDependencies = . inMemoryDomainRegistrationStoreInterpreter . raiseUnder -emailSendingInterpreter :: InterpreterFor EmailSending r -emailSendingInterpreter = - interpret \case - SendMail _ -> pure () - spec :: Spec spec = describe "EnterpriseLoginSubsystem" $ do it "LockDomain" pending diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 21f9ad10268..ad85491a049 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -248,6 +248,7 @@ test-suite wire-subsystems-tests Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.DomainRegistrationStore + Wire.MockInterpreters.EmailSending Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.EnterpriseLoginSubsystem Wire.MockInterpreters.Error From 958994cbb22fd697fadf74b08f62178b01044bc2 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 10:05:36 +0100 Subject: [PATCH 40/48] revert brainfart. --- libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs index b7d342b3f6e..72a41004245 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters.hs @@ -1,7 +1,7 @@ module Wire.MockInterpreters (module MockInterpreters) where -- Run this from project root to generate the imports: --- ls ./MockInterpreters | grep '\.hs' | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' +-- ls libs/wire-subsystems/test/unit/Wire/MockInterpreters | sed 's|\(.*\)\.hs|import Wire.MockInterpreters.\1 as MockInterpreters|' import Wire.MockInterpreters.ActivationCodeStore as MockInterpreters import Wire.MockInterpreters.BlockListStore as MockInterpreters From ebc997e385702ce7eab1e1df604b6f46720d9eae Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 10:11:58 +0100 Subject: [PATCH 41/48] Better mock interpreter errors. --- .../unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 32196a9ca8d..464f5ba5a5c 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -19,5 +19,7 @@ enterpriseLoginSubsystemTestInterpreter = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationTeamInvitation {} -> throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain "mock interpreter: don't know which error, i'm not very smart") - GuardEmailDomainRegistrationRegister {} -> throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain "mock interpreter: don't know which error, i'm not very smart") + GuardEmailDomainRegistrationTeamInvitation flow tid email -> + throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain ("mock interpreter: GuardEmailDomainRegistrationTeamInvitation " <> show (flow, tid, email))) + GuardEmailDomainRegistrationRegister email -> + throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain ("mock interpreter: GuardEmailDomainRegistrationRegister " <> show email)) From 10e7aa3f254b2fea37dd5c341459756f4fd5456f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 10:15:06 +0100 Subject: [PATCH 42/48] Remove unhelpful and misleading hints; better names. --- .../test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs | 1 - .../test/unit/Wire/MockInterpreters/UserSubsystem.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 464f5ba5a5c..6b43d372f5e 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -6,7 +6,6 @@ import Polysemy.Error (Error, throw) import Wire.EnterpriseLoginSubsystem import Wire.EnterpriseLoginSubsystem.Error --- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! enterpriseLoginSubsystemTestInterpreter :: (Member (Error EnterpriseLoginSubsystemError) r) => InterpreterFor EnterpriseLoginSubsystem r diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index 6bc1b63f58d..512ccce229f 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -6,7 +6,6 @@ import Polysemy import Wire.API.User import Wire.UserSubsystem --- HINT: This is used to test AuthenticationSubsystem, ...; not to test itself! userSubsystemTestInterpreter :: [User] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter initialUsers = interpret \case From ad7add4e834616a8232c246c5b9df963c40102d5 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 10:38:55 +0100 Subject: [PATCH 43/48] Unit tests: throw any error from underlying effect, not some. --- .../src/Wire/EnterpriseLoginSubsystem/Error.hs | 7 +++++-- .../Wire/MockInterpreters/EnterpriseLoginSubsystem.hs | 9 ++++----- .../unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs | 9 +++++---- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs index b8ce345126e..71b80923aa3 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs @@ -4,6 +4,7 @@ import Data.Text.Lazy qualified as LT import Imports import Network.HTTP.Types import Network.Wai.Utilities qualified as Wai +import Wire.Arbitrary import Wire.Error data EnterpriseLoginSubsystemError @@ -14,7 +15,8 @@ data EnterpriseLoginSubsystemError | EnterpriseLoginSubsystemUnAuthorizeError | EnterpriseLoginSubsystemPreAuthorizeError | EnterpriseLoginSubsystemGuardFailed GuardFailure - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform EnterpriseLoginSubsystemError) instance Exception EnterpriseLoginSubsystemError @@ -25,7 +27,8 @@ data GuardFailure | TeamInviteSetToNotAllowed | TeamInviteRestrictedToOtherTeam | InvalidDomain String - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform GuardFailure) enterpriseLoginSubsystemErrorToHttpError :: EnterpriseLoginSubsystemError -> HttpError enterpriseLoginSubsystemErrorToHttpError = diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index 6b43d372f5e..a383ea2135b 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -8,8 +8,9 @@ import Wire.EnterpriseLoginSubsystem.Error enterpriseLoginSubsystemTestInterpreter :: (Member (Error EnterpriseLoginSubsystemError) r) => + EnterpriseLoginSubsystemError -> InterpreterFor EnterpriseLoginSubsystem r -enterpriseLoginSubsystemTestInterpreter = +enterpriseLoginSubsystemTestInterpreter err = interpret \case LockDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () UnlockDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () @@ -18,7 +19,5 @@ enterpriseLoginSubsystemTestInterpreter = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationTeamInvitation flow tid email -> - throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain ("mock interpreter: GuardEmailDomainRegistrationTeamInvitation " <> show (flow, tid, email))) - GuardEmailDomainRegistrationRegister email -> - throw $ EnterpriseLoginSubsystemGuardFailed (InvalidDomain ("mock interpreter: GuardEmailDomainRegistrationRegister " <> show email)) + GuardEmailDomainRegistrationTeamInvitation flow tid email -> throw err + GuardEmailDomainRegistrationRegister email -> throw err diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 9871afed693..33951cf7353 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -54,7 +54,8 @@ type AllEffects = data RunAllEffectsArgs = RunAllEffectsArgs { teamOwner :: TeamMember, - initialUsers :: [User] + initialUsers :: [User], + enterpriseLoginError :: EnterpriseLoginSubsystemError } deriving (Eq, Show) @@ -74,14 +75,14 @@ runAllEffects args = . miniGalleyAPIAccess (Just args.teamOwner) def . discardTinyLogs . runError - . enterpriseLoginSubsystemTestInterpreter + . enterpriseLoginSubsystemTestInterpreter args.guardError . runErrorUnsafe @TeamInvitationSubsystemError spec :: Spec spec = do describe "InviteUser" $ do prop "calls guardEmailDomainRegistrationState if appropriate" $ - \preInviter tid inviterEmail inviteeEmail -> + \preInviter tid inviterEmail inviteeEmail enterpriseLoginError -> let cfg = TeamInvitationSubsystemConfig { maxTeamSize = 50, @@ -100,7 +101,7 @@ spec = do domain = qDomain inviter.userQualifiedId luid = toLocalUnsafe domain uid teamMember = mkTeamMember uid fullPermissions Nothing UserLegalHoldDisabled - args = RunAllEffectsArgs teamMember [inviter] + args = RunAllEffectsArgs teamMember [inviter] enterpriseLoginError outcome = runAllEffects args . runTeamInvitationSubsystem cfg $ do void $ inviteUser luid tid invReq in counterexample (show outcome) (isLeft outcome === True) From c046d25719a71a75d12ea1e89befb6ecb1bec21d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 11:34:00 +0100 Subject: [PATCH 44/48] Add link to confluence in comment. --- .../src/Wire/EnterpriseLoginSubsystem/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index f5e80034f4d..08ae09d29ac 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -383,7 +383,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do Backend _ -> ok NoRegistration -> case invitationFlow of ExistingUser -> nope DomRedirSetToNoRegistration - NewUser -> ok + NewUser -> ok -- https://wearezeta.atlassian.net/wiki/people/5b238b2002cfea1ba6411236?ref=confluence PreAuthorized -> ok -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not -- the team of the inviter From 1ce524b9e382a8c7640c77e53e1ca03d9f76a422 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 11:47:38 +0100 Subject: [PATCH 45/48] Commit missing hs file. --- .../test/unit/Wire/MockInterpreters/EmailSending.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSending.hs diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSending.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSending.hs new file mode 100644 index 00000000000..9c967e608de --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EmailSending.hs @@ -0,0 +1,10 @@ +module Wire.MockInterpreters.EmailSending where + +import Imports +import Polysemy +import Wire.EmailSending + +noopEmailSendingInterpreter :: InterpreterFor EmailSending r +noopEmailSendingInterpreter = + interpret \case + SendMail _ -> pure () From c0f8e96eb47dcca8aaada9d4cf1677fc496161f7 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 13:30:35 +0100 Subject: [PATCH 46/48] pffffff. --- .../unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs index a383ea2135b..bad8b31eed8 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/EnterpriseLoginSubsystem.hs @@ -19,5 +19,5 @@ enterpriseLoginSubsystemTestInterpreter err = UpdateDomainRegistration _ _ -> undefined -- :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m () DeleteDomain _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m () GetDomainRegistration _ -> undefined -- :: Domain -> EnterpriseLoginSubsystem m DomainRegistration - GuardEmailDomainRegistrationTeamInvitation flow tid email -> throw err - GuardEmailDomainRegistrationRegister email -> throw err + GuardEmailDomainRegistrationTeamInvitation {} -> throw err + GuardEmailDomainRegistrationRegister _ -> throw err From cbe42b5f31172f628d47d0c0797251fb9714a22b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 13:31:53 +0100 Subject: [PATCH 47/48] pffffffffffffffffffffffffffffffffff. --- .../test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs index 33951cf7353..92deb3b7d6e 100644 --- a/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/TeamInvitationSubsystem/InterpreterSpec.hs @@ -75,7 +75,7 @@ runAllEffects args = . miniGalleyAPIAccess (Just args.teamOwner) def . discardTinyLogs . runError - . enterpriseLoginSubsystemTestInterpreter args.guardError + . enterpriseLoginSubsystemTestInterpreter args.enterpriseLoginError . runErrorUnsafe @TeamInvitationSubsystemError spec :: Spec From 3b27fcb46e142ad4aca385f1297242958a9fa7cd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 21 Jan 2025 13:47:15 +0100 Subject: [PATCH 48/48] fix broken link. --- .../src/Wire/EnterpriseLoginSubsystem/Interpreter.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs index 08ae09d29ac..bcb09e0a7e6 100644 --- a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs @@ -383,7 +383,7 @@ guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do Backend _ -> ok NoRegistration -> case invitationFlow of ExistingUser -> nope DomRedirSetToNoRegistration - NewUser -> ok -- https://wearezeta.atlassian.net/wiki/people/5b238b2002cfea1ba6411236?ref=confluence + NewUser -> ok -- https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1587118249/Use+case+initiate+invitation+flow?focusedCommentId=1672839248 PreAuthorized -> ok -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not -- the team of the inviter