Merge branch 'wireapp:develop' into develop

changelog.d/2-features/WPB-16141

@@ -0,0 +1 @@
+Enforce no activation for email domains that are registered for another team or backend

integration/test/Test/User.hs

@@ -261,3 +261,78 @@ testUpdateEmailForEmailDomainForAnotherBackend = do
 
   bindResponse (getSelf user) $ \resp -> do
     resp.json %. "email" `shouldMatch` email
+
+testActivateEmailForEmailDomainForAnotherBackend :: (HasCallStack) => App ()
+testActivateEmailForEmailDomainForAnotherBackend = do
+  tid <- randomId
+  sso <- randomId
+  object
+    [ "domain_redirect" .= "backend",
+      "backend_url" .= "https://example.com",
+      "team_invite" .= "not-allowed"
+    ]
+    & testActivateEmailShouldBeAllowed False
+  object
+    [ "domain_redirect" .= "none",
+      "team_invite" .= "allowed"
+    ]
+    & testActivateEmailShouldBeAllowed True
+  object
+    [ "domain_redirect" .= "no-registration",
+      "team_invite" .= "team",
+      "team" .= tid
+    ]
+    & testActivateEmailShouldBeAllowed False
+  object
+    [ "domain_redirect" .= "no-registration",
+      "team_invite" .= "not-allowed"
+    ]
+    & testActivateEmailShouldBeAllowed False
+  object
+    [ "domain_redirect" .= "sso",
+      "sso_code" .= sso,
+      "team_invite" .= "not-allowed"
+    ]
+    & testActivateEmailShouldBeAllowed False
+  object
+    [ "domain_redirect" .= "sso",
+      "sso_code" .= sso,
+      "team_invite" .= "team",
+      "team" .= tid
+    ]
+    & testActivateEmailShouldBeAllowed False
+  where
+    testActivateEmailShouldBeAllowed :: (HasCallStack) => Bool -> Value -> App ()
+    testActivateEmailShouldBeAllowed activateAllowed update = do
+      registrationDomain <- randomDomain
+      user <- randomUser OwnDomain def
+      email <- user %. "email" & asString
+      (cookie, token) <- bindResponse (login user email defPassword) $ \resp -> do
+        resp.status `shouldMatchInt` 200
+        token <- resp.json %. "access_token" & asString
+        let cookie = fromJust $ getCookie "zuid" resp
+        pure ("zuid=" <> cookie, token)
+
+      let newEmail = "galadriel@" <> registrationDomain
+      updateEmail user newEmail cookie token >>= assertSuccess
+
+      (key, code) <- bindResponse (getActivationCode user newEmail) $ \resp -> do
+        resp.status `shouldMatchInt` 200
+        (,)
+          <$> (resp.json %. "key" & asString)
+          <*> (resp.json %. "code" & asString)
+
+      I.updateDomainRegistration OwnDomain registrationDomain update >>= assertSuccess
+
+      if activateAllowed
+        then do
+          API.Brig.activate user key code >>= assertSuccess
+          getSelf user `bindResponse` \resp -> do
+            resp.json %. "email" `shouldMatch` newEmail
+        else do
+          API.Brig.activate user key code `bindResponse` \resp -> do
+            resp.status `shouldMatchInt` 403
+            resp.json %. "label" `shouldMatch` "condition-failed"
+
+          getSelf user `bindResponse` \resp -> do
+            resp.json %. "email" `shouldMatch` email

libs/wire-subsystems/src/Wire/UserSubsystem.hs

@@ -149,7 +149,7 @@ data UserSubsystem m a where
   -- | Throw error if registered domain forbids user account creation under this email
   -- address.  (This may become internal to the interpreter once migration to wire-subsystems
   -- has progressed enough.)
-  GuardRegisterUserEmailDomain :: EmailAddress -> UserSubsystem m ()
+  GuardRegisterActivateUserEmailDomain :: EmailAddress -> UserSubsystem m ()
   GuardUpgradePersonalUserToTeamEmailDomain :: EmailAddress -> UserSubsystem m ()
   -- | Check if an email is blocked.
   IsBlocked :: EmailAddress -> UserSubsystem m Bool

libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs

@@ -131,8 +131,8 @@ runUserSubsystem authInterpreter = interpret $
       updateHandleImpl uid mconn mb uhandle
     LookupLocaleWithDefault luid ->
       lookupLocaleOrDefaultImpl luid
-    GuardRegisterUserEmailDomain email ->
-      guardRegisterUserEmailDomainImpl email
+    GuardRegisterActivateUserEmailDomain email ->
+      guardRegisterActivateUserEmailDomainImpl email
     GuardUpgradePersonalUserToTeamEmailDomain email ->
       guardUpgradePersonalUserToTeamEmailDomainImpl email
     IsBlocked email ->
@@ -220,15 +220,15 @@ internalFindTeamInvitationImpl (Just e) c =
       mAddUserError <- checkUserCanJoinTeam tid
       maybe (pure ()) (throw . UserSubsystemUserNotAllowedToJoinTeam) mAddUserError
 
-guardRegisterUserEmailDomainImpl ::
+guardRegisterActivateUserEmailDomainImpl ::
   forall r.
   ( Member DRS.DomainRegistrationStore r,
     Member (Error UserSubsystemError) r,
     Member TinyLog r
   ) =>
   EmailAddress ->
   Sem r ()
-guardRegisterUserEmailDomainImpl email = do
+guardRegisterActivateUserEmailDomainImpl email = do
   let throwGuardFailed = throw . UserSubsystemGuardFailed
   mReg <-
     emailDomain email

libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs

@@ -25,7 +25,7 @@ userSubsystemTestInterpreter initialUsers =
     CheckHandles _ _ -> error "CheckHandles: implement on demand (userSubsystemInterpreter)"
     UpdateHandle {} -> error "UpdateHandle: implement on demand (userSubsystemInterpreter)"
     LookupLocaleWithDefault _ -> error "LookupLocaleWithDefault: implement on demand (userSubsystemInterpreter)"
-    GuardRegisterUserEmailDomain {} -> error "GuardRegisterUserEmailDomain: implemented on demand (userSubsystemInterpreter)"
+    GuardRegisterActivateUserEmailDomain {} -> error "GuardRegisterActivateUserEmailDomain: implemented on demand (userSubsystemInterpreter)"
     GuardUpgradePersonalUserToTeamEmailDomain {} -> error "GuardUpgradePersonalUserToTeamEmailDomain: implemented on demand (userSubsystemInterpreter)"
     IsBlocked _ -> pure False
     BlockListDelete _ -> error "BlockListDelete: implement on demand (userSubsystemInterpreter)"

libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs

@@ -937,7 +937,7 @@ spec = describe "UserSubsystem.Interpreter" do
               _ -> Right ()
          in outcome === expected
 
-  describe "GuardRegisterUserEmailDomain" $ do
+  describe "GuardRegisterActivateUserEmailDomain" $ do
     prop "throws the appropriate errors" $
       \(domreg :: DomainRegistration) (preEmail :: EmailAddress) config ->
         let email :: EmailAddress
@@ -952,7 +952,7 @@ spec = describe "UserSubsystem.Interpreter" do
               . runError
               $ interpretNoFederationStack def Nothing def config do
                 DRS.upsert domreg
-                guardRegisterUserEmailDomain email
+                guardRegisterActivateUserEmailDomain email
 
             expected = case domreg.domainRedirect of
               None -> Right ()

services/brig/src/Brig/API/Public.hs

@@ -1448,7 +1448,8 @@ activateKey ::
   (Handler r) ActivationRespWithStatus
 activateKey (Public.Activate tgt code dryrun)
   | dryrun = do
-      wrapClientE (API.preverify tgt code) !>> actError
+      (emailKey, _) <- wrapClientE (API.preverify tgt code) !>> actError
+      lift $ liftSem $ guardRegisterActivateUserEmailDomain (emailKeyOrig emailKey)
       pure ActivationRespDryRun
   | otherwise = do
       result <- API.activate tgt code Nothing !>> actError

services/brig/src/Brig/API/User.hs

@@ -337,12 +337,12 @@ createUser new = do
         inv <- lift $ liftSem $ internalFindTeamInvitation (mkEmailKey <$> email) i
         pure (Nothing, Just inv, Just inv.teamId)
       Just (NewTeamCreator t) -> do
-        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterUserEmailDomain)
+        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterActivateUserEmailDomain)
         (Just t,Nothing,) <$> (Just . Id <$> liftIO nextRandom)
       Just (NewTeamMemberSSO tid) ->
         pure (Nothing, Nothing, Just tid)
       Nothing -> do
-        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterUserEmailDomain)
+        for_ (emailIdentity =<< new.newUserIdentity) (lift . liftSem . guardRegisterActivateUserEmailDomain)
         pure (Nothing, Nothing, Nothing)
   let mbInv = (.invitationId) <$> teamInvitation
   mbExistingAccount <-
@@ -683,10 +683,10 @@ preverify ::
   ) =>
   ActivationTarget ->
   ActivationCode ->
-  ExceptT ActivationError m ()
+  ExceptT ActivationError m (EmailKey, Maybe UserId)
 preverify tgt code = do
   key <- mkActivationKey tgt
-  void $ Data.verifyCode key code
+  Data.verifyCode key code
 
 onActivated ::
   ( Member TinyLog r,

services/brig/src/Brig/Data/Activation.hs

@@ -44,7 +44,7 @@ import Wire.API.User.Password
 import Wire.PasswordResetCodeStore (PasswordResetCodeStore)
 import Wire.PasswordResetCodeStore qualified as Password
 import Wire.UserKeyStore
-import Wire.UserSubsystem (UserSubsystem)
+import Wire.UserSubsystem
 import Wire.UserSubsystem qualified as User
 
 data ActivationError
@@ -77,7 +77,10 @@ activateKey ::
   ActivationCode ->
   Maybe UserId ->
   ExceptT ActivationError (AppT r) (Maybe ActivationEvent)
-activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate
+activateKey k c u = do
+  (emailKey, mUser) <- wrapClientE (verifyCode k c)
+  lift $ liftSem $ guardRegisterActivateUserEmailDomain (emailKeyOrig emailKey)
+  pickUser (emailKey, mUser) >>= activate
   where
     pickUser :: (t, Maybe UserId) -> ExceptT ActivationError (AppT r) (t, UserId)
     pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u')