WPB-15933 Special case of getDomainRegistrationPublic (#4441)

* Special case of getDomainRegistrationPublic Add a flag to the response body of `POST /get-domain-registration` to indicate whether `domain_redirect` is set to `none` due to the existence of a registered account. This makes it possible for clients to let a user log in with an existing cloud account even if a redirection to an on-prem backend is set up for their domain.
wireapp · Feb 3, 2025 · d8c8665 · d8c8665
1 parent b0934a3
commit d8c8665
Show file tree

Hide file tree

Showing 6 changed files with 70 additions and 14 deletions.
diff --git a/changelog.d/1-api-changes/WPB-15933 b/changelog.d/1-api-changes/WPB-15933
@@ -0,0 +1,5 @@
+Add a flag to the response body of `POST /get-domain-registration` to indicate
+whether `domain_redirect` is set to `none` due to the existence of a registered
+account. This makes it possible for clients to let a user log in with an
+existing cloud account even if a redirection to an on-prem backend is set up
+for their domain.
diff --git a/integration/test/Test/DomainVerification.hs b/integration/test/Test/DomainVerification.hs
@@ -448,6 +448,39 @@ testGetAndDeleteRegisteredDomains = do
 
   checkDelete expectedDomains
 
+testGetDomainRegistrationUserExists :: (HasCallStack) => App ()
+testGetDomainRegistrationUserExists = do
+  domain <- randomDomain
+  domainRegistrationPreAuthorize OwnDomain domain >>= assertStatus 204
+
+  -- create a user with email on this domain
+  void
+    $ randomUser
+      OwnDomain
+      def
+        { email = Just ("paolo@" <> domain)
+        }
+
+  setup <- setupOwnershipToken domain
+  updateDomainRedirect
+    OwnDomain
+    domain
+    (Just setup.ownershipToken)
+    (mkDomainRedirectBackend "https://wire.example.com")
+    >>= assertStatus 200
+
+  bindResponse (getDomainRegistrationFromEmail OwnDomain ("sven@" <> domain)) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "domain_redirect" `shouldMatch` "backend"
+    resp.json %. "backend_url" `shouldMatch` "https://wire.example.com"
+    lookupField resp.json "due_to_existing_account" `shouldMatch` (Nothing :: Maybe String)
+
+  bindResponse (getDomainRegistrationFromEmail OwnDomain ("paolo@" <> domain)) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    resp.json %. "domain_redirect" `shouldMatch` "none"
+    lookupField resp.json "backend_url" `shouldMatch` (Nothing :: Maybe String)
+    resp.json %. "due_to_existing_account" `shouldMatch` True
+
 -- helpers
 
 data ChallengeSetup = ChallengeSetup

diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs
@@ -151,6 +151,22 @@ instance ToSchema RegisteredDomains where
       RegisteredDomains
         <$> unRegisteredDomains .= field "registered_domains" (array schema)
 
+data DomainRedirectResponse = DomainRedirectResponse
+  { userExists :: Bool,
+    redirect :: DomainRedirect
+  }
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema DomainRedirectResponse)
+
+instance ToSchema DomainRedirectResponse where
+  schema =
+    object "DomainRedirectResponse" $
+      DomainRedirectResponse
+        <$> (\r -> True <$ guard r.userExists)
+          .= maybe_
+            ( fromMaybe False <$> optField "due_to_existing_account" schema
+            )
+        <*> (.redirect) .= domainRedirectSchema
+
 type DomainVerificationChallengeAPI =
   Named
     "domain-verification-challenge"
@@ -241,5 +257,5 @@ type DomainVerificationAPI =
                :> CanThrow DomainVerificationInvalidDomain
                :> "get-domain-registration"
                :> ReqBody '[JSON] GetDomainRegistrationRequest
-               :> Post '[JSON] DomainRedirect
+               :> Post '[JSON] DomainRedirectResponse
            )
diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs
@@ -30,7 +30,7 @@ data EnterpriseLoginSubsystem m a where
     EnterpriseLoginSubsystem m ()
   GetDomainRegistrationPublic ::
     GetDomainRegistrationRequest ->
-    EnterpriseLoginSubsystem m DomainRedirect
+    EnterpriseLoginSubsystem m DomainRedirectResponse
   CreateDomainVerificationChallenge ::
     Domain ->
     EnterpriseLoginSubsystem m DomainVerificationChallenge

diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs
@@ -650,17 +650,19 @@ getDomainRegistrationPublicImpl ::
     Member TinyLog r
   ) =>
   GetDomainRegistrationRequest ->
-  Sem r DomainRedirect
+  Sem r DomainRedirectResponse
 getDomainRegistrationPublicImpl (GetDomainRegistrationRequest email) = do
   -- check if the email belongs to a registered user
   mUser <- lookupKey (mkEmailKey email)
-  case mUser of
-    Nothing -> do
-      domain <-
-        either
-          (const (throw EnterpriseLoginSubsystemInvalidDomain))
-          pure
-          $ mkDomain (Text.decodeUtf8 (domainPart email))
-      mReg <- getDomainRegistrationImpl domain
-      pure $ maybe None (.domainRedirect) mReg
-    Just _ -> pure None
+
+  domain <-
+    either
+      (const (throw EnterpriseLoginSubsystemInvalidDomain))
+      pure
+      $ mkDomain (Text.decodeUtf8 (domainPart email))
+  mReg <- getDomainRegistrationImpl domain
+
+  pure $ case mUser of
+    Nothing -> DomainRedirectResponse False (maybe None (.domainRedirect) mReg)
+    Just _ ->
+      DomainRedirectResponse (fmap (domainRedirectTag . (.domainRedirect)) mReg == Just BackendTag) None
diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs
@@ -1557,7 +1557,7 @@ deleteRegisteredDomain lusr tid domain = lift . liftSem $ EnterpriseLogin.delete
 getDomainRegistration ::
   (_) =>
   GetDomainRegistrationRequest ->
-  Handler r DomainRedirect
+  Handler r DomainRedirectResponse
 getDomainRegistration req =
   lift . liftSem $
     EnterpriseLogin.getDomainRegistrationPublic req