[WIP] Use DomainRegistration sum type everywhere.

Also:
- rename lots of stuff (necessary)
- add more unit tests (roundtrip stuff)

libs/wire-api/default.nix

@@ -230,6 +230,7 @@ mkDerivation {
     containers
     crypton
     currency-codes
+    data-default
     filepath
     hex
     hspec

libs/wire-api/src/Wire/API/EnterpriseLogin.hs

@@ -220,79 +220,95 @@ data DomainRegistrationResponse = DomainRegistrationResponse
   deriving (ToJSON, FromJSON, S.ToSchema) via Schema DomainRegistrationResponse
 
 mkDomainRegistrationResponse :: DomainRegistration -> DomainRegistrationResponse
-mkDomainRegistrationResponse DomainRegistration {..} = DomainRegistrationResponse {..}
+mkDomainRegistrationResponse = prs . domainRegistrationToRow
+  where
+    prs DomainRegistrationRow {..} = DomainRegistrationResponse {..}
 
 instance ToSchema DomainRegistrationResponse where
   schema =
     object "DomainRegistrationResponse" $
       DomainRegistrationResponse
         <$> (.domain) .= field "domain" schema
-        <*> (.authorizedTeam) .= maybe_ (optField "authorized_team" schema)
+        <*> (.authorizedTeam) .= maybe_ (optField "authorized_team" schema) -- TODO: change to "team" to make it consistent with client->server talk
         <*> (.domainRedirect) .= domainRedirectSchema
         <*> (.teamInvite) .= teamInviteObjectSchema
         <*> (.dnsVerificationToken) .= optField "dns_verification_token" (maybeWithDefault Aeson.Null schema)
 
-----------------------------------------------------------------------
-
-data DomainRegistration' = DomainRegistration'
-  { settings :: Maybe DomainRegistrationSettings',
+-- | See 'domainRegistration{From,To}Row'.
+data DomainRegistration = DomainRegistration
+  { domain :: Domain,
+    settings :: Maybe DomainRegistrationSettings,
     dnsVerificationToken :: Maybe DnsVerificationToken,
     authTokenHash :: Maybe Token
   }
   deriving (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform DomainRegistration')
+  deriving (Arbitrary) via (GenericUniform DomainRegistration)
+
+instance {-# OVERLAPPING #-} Default (Domain -> DomainRegistration) where
+  def dom = DomainRegistration dom Nothing Nothing Nothing
 
-data DomainRegistrationSettings'
-  = Locked'
-  | PreAuthorized'
-  | NoRegistration'
+data DomainRegistrationSettings
+  = DomainLocked
+  | DomainPreAuthorized
+  | DomainNoRegistration
   | DomainForBackend HttpsUrl
   | DomainForLocalTeam TeamId (Maybe SAML.IdPId)
   deriving (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform DomainRegistrationSettings')
+  deriving (Arbitrary) via (GenericUniform DomainRegistrationSettings)
 
-newToOld :: Domain -> DomainRegistration' -> DomainRegistration
-newToOld domain DomainRegistration' {..} = DomainRegistration {..}
+domainRegistrationToRow :: DomainRegistration -> DomainRegistrationRow
+domainRegistrationToRow DomainRegistration {..} = DomainRegistrationRow {..}
   where
     domainRedirect = case settings of
       Nothing -> None
-      Just Locked' -> Locked
-      Just PreAuthorized' -> PreAuthorized
-      Just NoRegistration' -> NoRegistration
+      Just DomainLocked -> Locked
+      Just DomainPreAuthorized -> PreAuthorized
+      Just DomainNoRegistration -> NoRegistration
       Just (DomainForBackend url) -> Backend url
       Just (DomainForLocalTeam _tid Nothing) -> None
       Just (DomainForLocalTeam _tid (Just idpid)) -> SSO idpid
 
     teamInvite = case settings of
       Nothing -> Allowed
-      Just Locked' -> Allowed
-      Just PreAuthorized' -> Allowed
-      Just NoRegistration' -> NotAllowed -- TODO: where does the spec cover this case?
+      Just DomainLocked -> Allowed
+      Just DomainPreAuthorized -> Allowed
+      Just DomainNoRegistration -> NotAllowed
       Just (DomainForBackend _) -> NotAllowed
       Just (DomainForLocalTeam tid _) -> Team tid
 
     authorizedTeam = case settings of
       Just (DomainForLocalTeam tid _) -> Just tid
       _ -> Nothing
 
-oldToNew :: DomainRegistration -> Either String (Domain, DomainRegistration')
-oldToNew DomainRegistration {..} = do
-  settings :: Maybe DomainRegistrationSettings' <- do
-    case (domainRedirect, teamInvite, authorizedTeam) of
-      (None, Allowed, Nothing) -> Right Nothing
-      (Locked, Allowed, Nothing) -> Right (Just Locked')
-      (PreAuthorized, Allowed, Nothing) -> Right (Just PreAuthorized')
-      (NoRegistration, NotAllowed, Nothing) -> Right (Just NoRegistration')
-      (Backend url, NotAllowed, Nothing) -> Right (Just (DomainForBackend url))
-      (None, Team tid, Just tid') | tid == tid' -> Right (Just (DomainForLocalTeam tid Nothing))
-      (SSO idpid, Team tid, Just tid') | tid == tid' -> Right (Just (DomainForLocalTeam tid (Just idpid)))
-      _ -> Left ("domainRedirect, teamInvite, authorizedTeam mismatch: " <> show (domainRedirect, teamInvite, authorizedTeam))
-
-  Right (domain, DomainRegistration' {..})
-
-----------------------------------------------------------------------
-
-data DomainRegistration = DomainRegistration
+domainRegistrationSettingsFromRow :: DomainRedirect -> TeamInvite -> Maybe TeamId -> Either String (Maybe DomainRegistrationSettings)
+domainRegistrationSettingsFromRow domainRedirect teamInvite authorizedTeam =
+  case (domainRedirect, teamInvite, authorizedTeam) of
+    (None, Allowed, Nothing) -> Right Nothing
+    (Locked, Allowed, Nothing) -> Right (Just DomainLocked)
+    (PreAuthorized, Allowed, Nothing) -> Right (Just DomainPreAuthorized)
+    (NoRegistration, NotAllowed, Nothing) -> Right (Just DomainNoRegistration)
+    (Backend url, NotAllowed, Nothing) -> Right (Just (DomainForBackend url))
+    (None, Team tid, Just tid') | tid == tid' -> Right (Just (DomainForLocalTeam tid Nothing))
+    (SSO idpid, Team tid, Just tid') | tid == tid' -> Right (Just (DomainForLocalTeam tid (Just idpid)))
+    _ -> Left ("domainRedirect, teamInvite, authorizedTeam mismatch: " <> show (domainRedirect, teamInvite, authorizedTeam))
+
+domainRegistrationFromRow :: DomainRegistrationRow -> Either String DomainRegistration
+domainRegistrationFromRow DomainRegistrationRow {..} = do
+  settings <- domainRegistrationSettingsFromRow domainRedirect teamInvite authorizedTeam
+  Right DomainRegistration {..}
+
+domainRegistrationFromUpdate :: DomainRegistration -> DomainRegistrationUpdate -> Either String DomainRegistration
+domainRegistrationFromUpdate reg upd = do
+  let authorizedTeam = case upd.teamInvite of
+        Allowed -> Nothing
+        NotAllowed -> Nothing
+        Team tid -> Just tid
+  newSettings <- domainRegistrationSettingsFromRow upd.domainRedirect upd.teamInvite authorizedTeam
+  Right reg {settings = newSettings}
+
+-- | This type only server as a helper for json (and cql, for historical reasons).  App logic
+-- should always use 'DomainRegistration' instead.  See 'domainRegistration{From,To}Row'.
+data DomainRegistrationRow = DomainRegistrationRow
   { domain :: Domain,
     authorizedTeam :: Maybe TeamId,
     domainRedirect :: DomainRedirect,
@@ -301,11 +317,11 @@ data DomainRegistration = DomainRegistration
     authTokenHash :: Maybe Token
   }
   deriving stock (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform DomainRegistration)
+  deriving (Arbitrary) via (GenericUniform DomainRegistrationRow)
 
-instance {-# OVERLAPPING #-} Default (Domain -> DomainRegistration) where
+instance {-# OVERLAPPING #-} Default (Domain -> DomainRegistrationRow) where
   def domain =
-    DomainRegistration
+    DomainRegistrationRow
       { domain,
         authorizedTeam = Nothing,
         domainRedirect = def,

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -105,6 +105,7 @@ data BrigError
   | NotificationQueueConnectionError
   | DomainVerificationErrorNotFound
   | DomainVerificationInvalidDomain
+  | DomainVerificationInvalidDomainUpdate
   | DomainVerificationDomainVerificationFailed
   | DomainVerificationOperationForbidden
   | DomainVerificationAuthFailure
@@ -320,6 +321,8 @@ type instance MapError 'DomainVerificationErrorNotFound = 'StaticError 404 "not-
 
 type instance MapError 'DomainVerificationInvalidDomain = 'StaticError 400 "invalid-domain" "Invalid domain"
 
+type instance MapError 'DomainVerificationInvalidDomainUpdate = 'StaticError 400 "invalid-domain-update" "Invalid domain update"
+
 type instance MapError 'DomainVerificationDomainVerificationFailed = 'StaticError 403 "domain-verification-failed" "Domain verification failed"
 
 type instance MapError 'DomainVerificationOperationForbidden = 'StaticError 403 "operation-forbidden-for-domain-registration-state" "Invalid domain registration state update"

libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
@@ -19,10 +21,13 @@ module Test.Wire.API.Roundtrip.Aeson (tests) where
 
 import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON)
 import Data.Aeson.Types (parseEither)
+import Data.Default
+import Data.Domain
 import Data.Id (ConvId)
 import Data.OpenApi (ToSchema, validatePrettyToJSON)
 import Imports
 import Test.Tasty qualified as T
+import Test.Tasty.HUnit (testCase, (@?=))
 import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (.&&.), (===))
 import Type.Reflection (typeRep)
 import Wire.API.Asset qualified as Asset
@@ -351,8 +356,17 @@ tests =
       testRoundTrip @TeamsIntra.TeamStatusUpdate,
       testRoundTrip @TeamsIntra.TeamData,
       testRoundTrip @TeamsIntra.TeamName,
-      testProperty "EnterpriseLogin.EnterpriseLogin'" $ \(dom, new) -> do
-        EnterpriseLogin.oldToNew (EnterpriseLogin.newToOld dom new) === Right (dom, new)
+      T.testGroup "EnterpriseLogin.DomainRegistration{,Row}" $
+        [ -- TODO: move this group to a better place
+          testCase "default values match" $ do
+            let Right dom = mkDomain "example.com"
+            Right (def dom :: EnterpriseLogin.DomainRegistration)
+              @?= EnterpriseLogin.domainRegistrationFromRow (def dom)
+            (def dom :: EnterpriseLogin.DomainRegistrationRow)
+              @?= EnterpriseLogin.domainRegistrationToRow (def dom),
+          testProperty "to, from row" $ \new -> do
+            EnterpriseLogin.domainRegistrationFromRow (EnterpriseLogin.domainRegistrationToRow new) === Right new
+        ]
     ]
 
 testRoundTrip ::

libs/wire-api/wire-api.cabal

@@ -699,6 +699,7 @@ test-suite wire-api-tests
     , cassava
     , containers             >=0.5
     , crypton
+    , data-default
     , filepath
     , hex
     , hspec

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

@@ -103,13 +103,17 @@ logInvalidDomainRegistrationError domain =
 delete :: (Member DomainRegistrationStore r) => Domain -> Sem r ()
 delete = send . DeleteInternal . mkDomainKey
 
+-- | Inconsistently stored domain registrations (according to 'domainRegistrationFromRow') are
+-- discarded.
 fromStored :: StoredDomainRegistration -> Maybe DomainRegistration
-fromStored sdr =
-  DomainRegistration (unmkDomainKey sdr.domain) sdr.authorizedTeam
-    <$> getDomainRedirect sdr
-    <*> getTeamInvite sdr
-    <*> pure sdr.dnsVerificationToken
-    <*> pure sdr.authTokenHash
+fromStored sdr = do
+  row <-
+    DomainRegistrationRow (unmkDomainKey sdr.domain) sdr.authorizedTeam
+      <$> getDomainRedirect sdr
+      <*> getTeamInvite sdr
+      <*> pure sdr.dnsVerificationToken
+      <*> pure sdr.authTokenHash
+  either (const Nothing) Just (domainRegistrationFromRow row)
   where
     getTeamInvite :: StoredDomainRegistration -> Maybe TeamInvite
     getTeamInvite = \case
@@ -133,7 +137,7 @@ fromStored sdr =
         _ -> Nothing
 
 toStored :: DomainRegistration -> StoredDomainRegistration
-toStored dr =
+toStored (domainRegistrationToRow -> dr) =
   let (domainRedirect, idpId, backendUrl) = fromDomainRedirect dr.domainRedirect
       (teamInvite, team) = fromTeamInvite dr.teamInvite
    in StoredDomainRegistration

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

@@ -9,6 +9,7 @@ import Wire.Error
 data EnterpriseLoginSubsystemError
   = EnterpriseLoginSubsystemErrorNotFound
   | EnterpriseLoginSubsystemInvalidDomain
+  | EnterpriseLoginSubsystemInvalidDomainUpdate String
   | EnterpriseLoginSubsystemDomainVerificationFailed
   | EnterpriseLoginSubsystemOperationForbidden
   | EnterpriseLoginSubsystemAuthFailure
@@ -25,6 +26,7 @@ enterpriseLoginSubsystemErrorToHttpError =
   StdError . \case
     EnterpriseLoginSubsystemErrorNotFound -> errorToWai @DomainVerificationErrorNotFound
     EnterpriseLoginSubsystemInvalidDomain -> errorToWai @DomainVerificationInvalidDomain
+    EnterpriseLoginSubsystemInvalidDomainUpdate _msg -> errorToWai @DomainVerificationInvalidDomainUpdate
     EnterpriseLoginSubsystemDomainVerificationFailed -> errorToWai @DomainVerificationDomainVerificationFailed
     EnterpriseLoginSubsystemOperationForbidden -> errorToWai @DomainVerificationOperationForbidden
     EnterpriseLoginSubsystemPaymentRequired -> errorToWai @DomainVerificationPaymentRequired