WPB-15801 GET and DELETE Registered Domains

cassandra-schema.cql

@@ -1045,6 +1045,26 @@ CREATE TABLE brig_test.service_prefix (
     AND min_index_interval = 128
     AND read_repair_chance = 0.0
     AND speculative_retry = '99PERCENTILE';
+
+CREATE TABLE brig_test.domain_registration_by_team (
+    team uuid,
+    domain text,
+    PRIMARY KEY (team, domain)
+) WITH CLUSTERING ORDER BY (domain ASC)
+    AND bloom_filter_fp_chance = 0.01
+    AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'}
+    AND comment = ''
+    AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'}
+    AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'}
+    AND crc_check_chance = 1.0
+    AND dclocal_read_repair_chance = 0.1
+    AND default_time_to_live = 0
+    AND gc_grace_seconds = 864000
+    AND max_index_interval = 2048
+    AND memtable_flush_period_in_ms = 0
+    AND min_index_interval = 128
+    AND read_repair_chance = 0.0
+    AND speculative_retry = '99PERCENTILE';
 CREATE KEYSPACE galley_test WITH replication = {'class': 'SimpleStrategy', 'replication_factor': '1'}  AND durable_writes = true;
 
 CREATE TYPE galley_test.permissions (

changelog.d/1-api-changes/WPB-14307

@@ -1,7 +1,9 @@
-New endpoints for domain registration and verification (#4389, #4422, #4433, #4434)
+New endpoints for domain registration and verification (#4389, #4422, #4433, #4434, #4438)
   - POST /domain-verification/:domain/team
   - POST /domain-verification/:domain/backend
   - POST /domain-verification/:domain/challenges
   - POST /domain-verification/:domain/challenges/:challengeId
   - POST /domain-verification/:domain/authorize-team
   - POST /get-domain-registration
+  - GET /teams/:tid/registered-domains
+  - DELETE /teams/:tid/registered-domains/:domain

charts/nginz/values.yaml

@@ -482,9 +482,6 @@ nginx_conf:
     - path: /domain-verification/([^/]*)/authorize-team$
       envs:
         - all
-    - path: /domain-verification/([^/]*)/team$
-      envs:
-        - all
     - path: /domain-verification/([^/]*)/backend$
       envs:
         - all
@@ -493,6 +490,15 @@ nginx_conf:
       envs:
         - all
       disable_zauth: true
+    - path: /domain-verification/([^/]*)/team$
+      envs:
+        - all
+    - path: /teams/([^/]*)/registered-domains$
+      envs:
+        - all
+    - path: /teams/([^/]*)/registered-domains/([^/]*)
+      envs:
+        - all
     - path: /bot/conversations/(.+)
       envs:
       - all

integration/test/API/Brig.hs

@@ -936,3 +936,13 @@ getDomainRegistrationFromEmail :: (HasCallStack, MakesValue domain) => domain ->
 getDomainRegistrationFromEmail domain email = do
   req <- baseRequest domain Brig Versioned $ joinHttpPath ["get-domain-registration"]
   submit "POST" $ req & addJSONObject ["email" .= email]
+
+getRegisteredDomainsByTeam :: (HasCallStack, MakesValue user) => user -> String -> App Response
+getRegisteredDomainsByTeam user tid = do
+  req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", tid, "registered-domains"]
+  submit "GET" req
+
+deleteRegisteredTeamDomain :: (HasCallStack, MakesValue user) => user -> String -> String -> App Response
+deleteRegisteredTeamDomain user tid registeredDomain = do
+  req <- baseRequest user Brig Versioned $ joinHttpPath ["teams", tid, "registered-domains", registeredDomain]
+  submit "DELETE" req

integration/test/Test/DomainVerification.hs

@@ -219,16 +219,16 @@ testUpdateTeamInvite = do
     setTeamFeatureStatus owner tid "domainRegistration" "enabled"
 
   bindResponse (authorizeTeam mem domain setup.ownershipToken) $ \resp -> do
-    resp.status `shouldMatchInt` 401
-    resp.json %. "label" `shouldMatch` "domain-registration-update-auth-failure"
+    resp.status `shouldMatchInt` 403
+    resp.json %. "label" `shouldMatch` "operation-forbidden-for-domain-registration-state"
 
   -- admin should not be able to set team-invite if the team hasn't been authorized
   bindResponse
     ( updateTeamInvite owner domain (object ["team_invite" .= "team", "team" .= tid])
     )
     $ \resp -> do
-      resp.status `shouldMatchInt` 401
-      resp.json %. "label" `shouldMatch` "domain-registration-update-auth-failure"
+      resp.status `shouldMatchInt` 403
+      resp.json %. "label" `shouldMatch` "operation-forbidden-for-domain-registration-state"
 
   authorizeTeam owner domain setup.ownershipToken >>= assertStatus 200
 
@@ -237,8 +237,8 @@ testUpdateTeamInvite = do
     ( updateTeamInvite mem domain (object ["team_invite" .= "team", "team" .= tid])
     )
     $ \resp -> do
-      resp.status `shouldMatchInt` 401
-      resp.json %. "label" `shouldMatch` "domain-registration-update-auth-failure"
+      resp.status `shouldMatchInt` 403
+      resp.json %. "label" `shouldMatch` "operation-forbidden-for-domain-registration-state"
 
   -- setting team invite to the wrong team should fail
   fakeTeamId <- randomId
@@ -401,6 +401,53 @@ testChallengeTtl = withModifiedBackend
     bindResponse (verifyDomain domain registrationDomain challengeId challengeToken) $ \resp -> do
       resp.status `shouldMatchInt` 404
 
+testGetAndDeleteRegisteredDomains :: (HasCallStack) => App ()
+testGetAndDeleteRegisteredDomains = do
+  (owner, tid, mem : _) <- createTeam OwnDomain 2
+
+  -- enable domain registration feature
+  assertSuccess =<< do
+    setTeamFeatureLockStatus owner tid "domainRegistration" "unlocked"
+    setTeamFeatureStatus owner tid "domainRegistration" "enabled"
+
+  expectedDomains <- replicateM 5 do
+    domain <- randomDomain
+    setup <- setupOwnershipToken domain
+    authorizeTeam owner domain setup.ownershipToken >>= assertStatus 200
+    pure domain
+
+  bindResponse (getRegisteredDomainsByTeam owner tid) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+    actualDomains <- resp.json %. "registered_domains" & asList >>= traverse (asString . (%. "domain"))
+    actualDomains `shouldMatchSet` expectedDomains
+
+  getRegisteredDomainsByTeam mem tid >>= assertStatus 403
+  (otherTeamOwner, _, _) <- createTeam OwnDomain 2
+  getRegisteredDomainsByTeam otherTeamOwner tid >>= assertStatus 403
+
+  nonExistingDomain <- randomDomain
+  deleteRegisteredTeamDomain owner tid nonExistingDomain >>= assertStatus 404
+  let firstDomain = head expectedDomains
+  deleteRegisteredTeamDomain mem tid firstDomain >>= assertStatus 403
+  deleteRegisteredTeamDomain otherTeamOwner tid firstDomain >>= assertStatus 403
+
+  let checkDelete :: [String] -> App ()
+      checkDelete [] =
+        bindResponse (getRegisteredDomainsByTeam owner tid) $ \resp -> do
+          resp.status `shouldMatchInt` 200
+          actualDomains <- resp.json %. "registered_domains" & asList
+          length actualDomains `shouldMatchInt` 0
+      checkDelete (domainToDelete : remainingDomains) = do
+        bindResponse (deleteRegisteredTeamDomain owner tid domainToDelete) $ \resp -> do
+          resp.status `shouldMatchInt` 204
+        bindResponse (getRegisteredDomainsByTeam owner tid) $ \resp -> do
+          resp.status `shouldMatchInt` 200
+          actualDomains <- resp.json %. "registered_domains" & asList >>= traverse (asString . (%. "domain"))
+          actualDomains `shouldMatchSet` remainingDomains
+        checkDelete remainingDomains
+
+  checkDelete expectedDomains
+
 -- helpers
 
 data ChallengeSetup = ChallengeSetup

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -102,6 +102,7 @@ type BrigAPI =
     :<|> ServicesAPI
     :<|> ProviderAPI
     :<|> DomainVerificationAPI
+    :<|> DomainVerificationTeamAPI
     :<|> DomainVerificationChallengeAPI
 
 data BrigAPITag

libs/wire-api/src/Wire/API/Routes/Public/Brig/DomainVerification.hs

@@ -142,6 +142,15 @@ instance ToSchema DomainOwnershipToken where
       DomainOwnershipToken
         <$> unDomainOwnershipToken .= field "domain_ownership_token" schema
 
+newtype RegisteredDomains = RegisteredDomains {unRegisteredDomains :: [DomainRegistrationResponse]}
+  deriving (A.ToJSON, A.FromJSON, S.ToSchema) via (Schema RegisteredDomains)
+
+instance ToSchema RegisteredDomains where
+  schema =
+    object "RegisteredDomains" $
+      RegisteredDomains
+        <$> unRegisteredDomains .= field "registered_domains" (array schema)
+
 type DomainVerificationChallengeAPI =
   Named
     "domain-verification-challenge"
@@ -165,7 +174,7 @@ type DomainVerificationChallengeAPI =
                :> Post '[JSON] DomainOwnershipToken
            )
 
-type DomainVerificationAPI =
+type DomainVerificationTeamAPI =
   Named
     "domain-verification-authorize-team"
     ( Summary "Authorize a team to operate on a verified domain"
@@ -180,30 +189,52 @@ type DomainVerificationAPI =
         :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Authorized")
     )
     :<|> Named
-           "update-domain-redirect"
-           ( Summary "Verify DNS record and save domain redirect configuration"
-               :> CanThrow DomainVerificationAuthFailure
+           "update-team-invite"
+           ( Summary "Update the team-invite configuration"
+               :> CanThrow DomainVerificationPaymentRequired
                :> CanThrow DomainVerificationOperationForbidden
-               :> Header' '[Required, Strict] "Authorization" (Bearer Token)
+               :> ZLocalUser
                :> "domain-verification"
                :> Capture "domain" Domain
-               :> "backend"
-               :> ReqBody '[JSON] DomainRedirectConfig
+               :> "team"
+               :> ReqBody '[JSON] TeamInviteConfig
                :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
            )
     :<|> Named
-           "update-team-invite"
-           ( Summary "Verify DNS record and save team-invite configuration"
-               :> CanThrow DomainVerificationAuthFailure
+           "get-all-registered-domains"
+           ( Summary "Get all registered domains"
+               :> ZLocalUser
+               :> "teams"
+               :> Capture "teamId" TeamId
+               :> "registered-domains"
+               :> Get '[JSON] RegisteredDomains
+           )
+    :<|> Named
+           "delete-registered-domain"
+           ( Summary "Delete a registered domain"
                :> CanThrow DomainVerificationPaymentRequired
                :> CanThrow DomainVerificationOperationForbidden
                :> ZLocalUser
-               :> "domain-verification"
+               :> "teams"
+               :> Capture "teamId" TeamId
+               :> "registered-domains"
                :> Capture "domain" Domain
-               :> "team"
-               :> ReqBody '[JSON] TeamInviteConfig
-               :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
+               :> MultiVerb1 'DELETE '[JSON] (RespondEmpty 204 "Deleted")
            )
+
+type DomainVerificationAPI =
+  Named
+    "update-domain-redirect"
+    ( Summary "Update the domain redirect configuration"
+        :> CanThrow DomainVerificationAuthFailure
+        :> CanThrow DomainVerificationOperationForbidden
+        :> Header' '[Required, Strict] "Authorization" (Bearer Token)
+        :> "domain-verification"
+        :> Capture "domain" Domain
+        :> "backend"
+        :> ReqBody '[JSON] DomainRedirectConfig
+        :> MultiVerb1 'POST '[JSON] (RespondEmpty 200 "Updated")
+    )
     :<|> Named
            "get-domain-registration"
            ( Summary "Get domain registration configuration by email"

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

@@ -6,6 +6,7 @@ module Wire.DomainRegistrationStore
     DomainKey,
     upsert,
     lookup,
+    lookupByTeam,
     delete,
   )
 where
@@ -61,11 +62,23 @@ recordInstance ''StoredDomainRegistration
 data DomainRegistrationStore m a where
   UpsertInternal :: StoredDomainRegistration -> DomainRegistrationStore m ()
   LookupInternal :: DomainKey -> DomainRegistrationStore m (Maybe StoredDomainRegistration)
+  LookupByTeamInternal :: TeamId -> DomainRegistrationStore m [StoredDomainRegistration]
   DeleteInternal :: DomainKey -> DomainRegistrationStore m ()
 
 upsert :: (Member DomainRegistrationStore r) => DomainRegistration -> Sem r ()
 upsert = send . UpsertInternal . toStored
 
+lookupByTeam :: forall r. (Member DomainRegistrationStore r, Member (Log.Logger (Log.Msg -> Log.Msg)) r) => TeamId -> Sem r [DomainRegistration]
+lookupByTeam tid = do
+  rows <- send (LookupByTeamInternal tid)
+  mRegisteredDomains <- for rows fromStoredWithLogging
+  pure $ catMaybes mRegisteredDomains
+  where
+    fromStoredWithLogging :: StoredDomainRegistration -> Sem r (Maybe DomainRegistration)
+    fromStoredWithLogging row = case fromStored row of
+      Just dr -> pure (Just dr)
+      Nothing -> logInvalidDomainRegistrationError (unmkDomainKey row.domain) $> Nothing
+
 lookup ::
   forall r.
   (Member DomainRegistrationStore r, Member TinyLog r) =>
@@ -78,13 +91,15 @@ lookup domain =
   where
     logErrors :: Either Bool a -> Sem r (Maybe a)
     logErrors (Left False) = pure Nothing
-    logErrors (Left True) = do
-      Log.err $
-        Log.field "domain" (toByteString' domain)
-          . Log.msg (Log.val "Invalid stored domain registration")
-      pure Nothing
+    logErrors (Left True) = logInvalidDomainRegistrationError domain $> Nothing
     logErrors (Right x) = pure (Just x)
 
+logInvalidDomainRegistrationError :: (Member TinyLog r, ToByteString a) => a -> Sem r ()
+logInvalidDomainRegistrationError domain =
+  Log.err $
+    Log.field "domain" (toByteString' domain)
+      . Log.msg (Log.val "Invalid stored domain registration")
+
 delete :: (Member DomainRegistrationStore r) => Domain -> Sem r ()
 delete = send . DeleteInternal . mkDomainKey
 

libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs

@@ -6,10 +6,12 @@ module Wire.DomainRegistrationStore.Cassandra
 where
 
 import Cassandra
+import Data.Id (TeamId)
 import Database.CQL.Protocol (Record (..), TupleType, asTuple)
 import Imports hiding (lookup)
 import Polysemy
 import SAML2.WebSSO qualified as SAML
+import UnliftIO (pooledForConcurrentlyN)
 import Wire.DomainRegistrationStore
 
 deriving instance Cql SAML.IdPId
@@ -24,10 +26,32 @@ interpretDomainRegistrationStoreToCassandra casClient =
     embed @IO . runClient casClient . \case
       UpsertInternal dr -> upsertImpl dr
       LookupInternal domain -> lookupImpl domain
+      LookupByTeamInternal tid -> lookupByTeamInternalImpl tid
       DeleteInternal domain -> deleteImpl domain
 
+lookupByTeamInternalImpl :: (MonadClient m, MonadUnliftIO m) => TeamId -> m [StoredDomainRegistration]
+lookupByTeamInternalImpl tid = do
+  domains <- lookupTeamDomains tid
+  catMaybes <$> pooledForConcurrentlyN 16 domains lookupImpl
+
+lookupTeamDomains :: (MonadClient m) => TeamId -> m [DomainKey]
+lookupTeamDomains tid =
+  fmap runIdentity <$> retry x1 (query cql (params LocalQuorum (Identity tid)))
+  where
+    cql :: PrepQuery R (Identity TeamId) (Identity DomainKey)
+    cql = "SELECT domain FROM domain_registration_by_team WHERE team = ?"
+
 upsertImpl :: (MonadClient m) => StoredDomainRegistration -> m ()
-upsertImpl dr = retry x5 $ write cqlUpsert (params LocalQuorum (asTuple dr))
+upsertImpl dr = do
+  for_ dr.authorizedTeam $ flip upsertTeamIndex dr.domain
+  retry x5 $ write cqlUpsert (params LocalQuorum (asTuple dr))
+
+upsertTeamIndex :: (MonadClient m) => TeamId -> DomainKey -> m ()
+upsertTeamIndex tid domain =
+  retry x5 $ write cql (params LocalQuorum (tid, domain))
+  where
+    cql :: PrepQuery W (TeamId, DomainKey) ()
+    cql = "INSERT INTO domain_registration_by_team (team, domain) VALUES (?,?)"
 
 lookupImpl :: (MonadClient m) => DomainKey -> m (Maybe StoredDomainRegistration)
 lookupImpl domain =

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

@@ -49,5 +49,7 @@ data EnterpriseLoginSubsystem m a where
     Token ->
     EnterpriseLoginSubsystem m Token
   AuthorizeTeam :: Local UserId -> Domain -> DomainOwnershipToken -> EnterpriseLoginSubsystem m ()
+  GetRegisteredDomains :: Local UserId -> TeamId -> EnterpriseLoginSubsystem m RegisteredDomains
+  DeleteTeamDomain :: Local UserId -> TeamId -> Domain -> EnterpriseLoginSubsystem m ()
 
 makeSem ''EnterpriseLoginSubsystem