implement get team dns token

wireapp · Jan 20, 2025 · 5ba4f9a · 5ba4f9a
1 parent a50b5e2
commit 5ba4f9a
Showing 1 changed file with 54 additions and 16 deletions.
diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs
@@ -300,7 +300,7 @@ getDomainVerificationToken ::
     Member Rpc r
   ) =>
   Domain ->
-  DomainVerificationAuthToken ->
+  Text ->
   Sem r DomainVerificationToken
 getDomainVerificationToken domain authToken =
   decodeBodyOrThrow
@@ -452,15 +452,36 @@ requestDomainVerificationTokenImpl ::
   Sem r DomainVerificationTokenResponse
 requestDomainVerificationTokenImpl mAuthToken domain = do
   authToken <- maybe generateAuthToken pure mAuthToken
-  dnsToken <- getDomainVerificationToken domain authToken
+  dnsToken <- getDomainVerificationToken domain (serializeDomainVerificationAuthToken authToken)
   pure
     DomainVerificationTokenResponse
       { authToken = Just authToken,
         dnsToken = dnsToken
       }
 
-requestDomainVerificationTeamTokenImpl :: Local UserId -> Domain -> Sem (Input Endpoint : r) DomainVerificationTokenResponse
-requestDomainVerificationTeamTokenImpl = todo
+requestDomainVerificationTeamTokenImpl ::
+  forall r.
+  ( Member (Input Endpoint) r,
+    Member TinyLog r,
+    Member (Error EnterpriseLoginSubsystemError) r,
+    Member (Error ParseException) r,
+    Member UserSubsystem r,
+    Member GalleyAPIAccess r,
+    Member DomainRegistrationStore r,
+    Member Rpc r
+  ) =>
+  Local UserId ->
+  Domain ->
+  Sem r DomainVerificationTokenResponse
+requestDomainVerificationTeamTokenImpl lusr domain = do
+  (tid, _mDomReg) <- guardTeamAdminAccess lusr domain
+  let authToken = idToText tid
+  dnsToken <- getDomainVerificationToken domain authToken
+  pure
+    DomainVerificationTokenResponse
+      { authToken = Nothing,
+        dnsToken = dnsToken
+      }
 
 updateDomainRedirectImpl ::
   ( Member (Error EnterpriseLoginSubsystemError) r,
@@ -515,21 +536,11 @@ updateTeamInviteImpl ::
   TeamInviteConfig ->
   Sem r ()
 updateTeamInviteImpl luid domain config = do
-  profile <- getSelfProfile luid >>= note EnterpriseLoginSubsystemAuthFailure
-  tid <- note EnterpriseLoginSubsystemAuthFailure profile.selfUser.userTeam
-  teamMember <-
-    getTeamMember (tUnqualified luid) tid
-      >>= note EnterpriseLoginSubsystemAuthFailure
-  validatePaymentStatus tid
-  unless (isAdminOrOwner (teamMember ^. permissions)) $
-    throw EnterpriseLoginSubsystemAuthFailure
-  mbDomainReg <- tryGetDomainRegistrationImpl domain
-  update <- validateUpdate tid mbDomainReg config
+  (tid, mbDomainReg) <- guardTeamAdminAccess luid domain
   verifyDNSRecord domain (idToText tid)
+  update <- validateUpdate tid mbDomainReg config
   updateDomainRegistrationImpl domain update
   where
-    -- maybe (throwStd $ errorToWai @E.DomainRegistrationUpdatedAuthFailure) pure result
-
     validateUpdate :: TeamId -> Maybe DomainRegistration -> TeamInviteConfig -> Sem r DomainRegistrationUpdate
     validateUpdate tid mDomReg conf = do
       let domReg = fromMaybe defDomReg mDomReg
@@ -553,6 +564,33 @@ updateTeamInviteImpl luid domain config = do
     defDomReg :: DomainRegistration
     defDomReg = DomainRegistration domain def def Nothing
 
+guardTeamAdminAccess ::
+  forall r.
+  ( Member (Input Endpoint) r,
+    Member TinyLog r,
+    Member (Error EnterpriseLoginSubsystemError) r,
+    Member (Error ParseException) r,
+    Member UserSubsystem r,
+    Member GalleyAPIAccess r,
+    Member DomainRegistrationStore r,
+    Member Rpc r
+  ) =>
+  Local UserId ->
+  Domain ->
+  Sem r (TeamId, Maybe DomainRegistration)
+guardTeamAdminAccess luid domain = do
+  profile <- getSelfProfile luid >>= note EnterpriseLoginSubsystemAuthFailure
+  tid <- note EnterpriseLoginSubsystemAuthFailure profile.selfUser.userTeam
+  teamMember <-
+    getTeamMember (tUnqualified luid) tid
+      >>= note EnterpriseLoginSubsystemAuthFailure
+  validatePaymentStatus tid
+  unless (isAdminOrOwner (teamMember ^. permissions)) $
+    throw EnterpriseLoginSubsystemAuthFailure
+  mbDomainReg <- tryGetDomainRegistrationImpl domain
+  verifyDNSRecord domain (idToText tid)
+  pure (tid, mbDomainReg)
+  where
     validatePaymentStatus :: TeamId -> Sem r ()
     validatePaymentStatus tid = do
       -- If the team is paying, conference calling will always be enabled