[WPB-14310] adjust existing onboarding flow to new domain registratio…

…n constraints. (#4409) * Modify POST /teams/{id}/invitations to check for domain configuration [WIP] * domain registration store in mem interpreter * unit test module for TeamInvitationSubsystem. * Enumerate unimplemented actions in miniGalleyAPIAccess interpreter. * fix flaky dotless email arbitrary instance * Add guard for /register to EnterpriseLoginSubsystem. * More structure for guard errors. * Arbitrary: use instance for Domain in instance for EmailAddress. * Call register guard in brig. (test still missing) * Add link to confluence in comment. --------- Co-authored-by: Leif Battermann <[email protected]> Co-authored-by: Sven Tennie <[email protected]>
wireapp · Jan 22, 2025 · 64d4f04 · 64d4f04
1 parent 0b236a6
commit 64d4f04
Show file tree

Hide file tree

Showing 25 changed files with 519 additions and 55 deletions.
diff --git a/...internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints b/...internal/WPB-14310-adjust-existing-onboarding-flow-to-new-domain-registration-constraints
@@ -0,0 +1,6 @@
+Adjust existing onboarding flow to new domain registration constraints.
+
+Endpoints:
+
+- POST /teams/{id}/invitations
+- POST /register
diff --git a/libs/wire-api/src/Wire/API/EnterpriseLogin.hs b/libs/wire-api/src/Wire/API/EnterpriseLogin.hs
@@ -16,6 +16,9 @@ import Data.Text.Ascii (Ascii, AsciiText (toText))
 import Data.Text.Ascii qualified as Ascii
 import Imports
 import SAML2.WebSSO qualified as SAML
+import SAML2.WebSSO.Test.Arbitrary ()
+import Test.QuickCheck (suchThat)
+import Wire.Arbitrary
 
 data DomainRedirect
   = None
@@ -24,7 +27,8 @@ data DomainRedirect
   | Backend HttpsUrl
   | NoRegistration
   | PreAuthorized
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via GenericUniform DomainRedirect
 
 makePrisms ''DomainRedirect
 
@@ -97,7 +101,8 @@ data TeamInvite
   = Allowed
   | NotAllowed
   | Team TeamId
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via GenericUniform TeamInvite
 
 makePrisms ''TeamInvite
 
@@ -162,6 +167,21 @@ data DomainRegistrationUpdate = DomainRegistrationUpdate
   deriving stock (Eq, Show)
   deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DomainRegistrationUpdate
 
+instance Arbitrary DomainRegistrationUpdate where
+  arbitrary = do
+    ( DomainRegistrationUpdate
+        <$> arbitrary
+        <*> arbitrary
+      )
+      `suchThat` validate
+    where
+      validate :: DomainRegistrationUpdate -> Bool
+      validate dr =
+        case dr.domainRedirect of
+          Locked -> dr.teamInvite == Allowed
+          Backend _ -> dr.teamInvite == NotAllowed
+          _ -> True
+
 instance ToSchema DomainRegistrationUpdate where
   schema =
     object "DomainRegistrationUpdate" $

diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs
@@ -17,9 +17,11 @@ where
 import Cassandra.CQL qualified as C
 import Data.ByteString.Conversion hiding (toByteString)
 import Data.Data (Proxy (..))
+import Data.Domain
 import Data.OpenApi hiding (Schema, ToSchema)
 import Data.Schema
 import Data.Text hiding (null)
+import Data.Text qualified as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
 import Deriving.Aeson
@@ -93,8 +95,8 @@ emailAddressText = emailAddress . encodeUtf8
 arbitraryValidMail :: Gen EmailAddress
 arbitraryValidMail = do
   loc <- arbitrary `suchThat` isValidLoc
-  dom <- arbitrary `suchThat` isValidDom
-  pure . fromJust $ emailAddress (fromString $ loc <> "@" <> dom)
+  Domain dom <- arbitrary
+  pure . fromJust $ emailAddress (fromString $ loc <> "@" <> T.unpack dom)
   where
     notAt :: String -> Bool
     notAt = notElem '@'
@@ -107,12 +109,6 @@ arbitraryValidMail = do
         && notAt x
         && isValid (fromString (x <> "@mail.com"))
 
-    isValidDom :: String -> Bool
-    isValidDom x =
-      notNull x
-        && notAt x
-        && isValid (fromString ("me@" <> x))
-
 -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this
 -- function total without all that praying and hoping.
 emailToSAMLNameID :: EmailAddress -> Either String SAML.NameID

diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix
@@ -26,6 +26,7 @@
 , currency-codes
 , data-default
 , data-timeout
+, email-validate
 , errors
 , exceptions
 , extended
@@ -117,6 +118,7 @@ mkDerivation {
     currency-codes
     data-default
     data-timeout
+    email-validate
     errors
     exceptions
     extended
@@ -206,6 +208,8 @@ mkDerivation {
     tinylog
     transformers
     types-common
+    uri-bytestring
+    uuid
     wire-api
     wire-api-federation
   ];

diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs
@@ -2,9 +2,10 @@
 
 module Wire.DomainRegistrationStore where
 
-import Data.Domain
+import Data.Domain as Domain
 import Data.Id
 import Data.Misc
+import Data.Text as T
 import Database.CQL.Protocol (Record (..), TupleType, recordInstance)
 import Imports
 import Polysemy
@@ -25,8 +26,17 @@ data StoredDomainRegistration = StoredDomainRegistration
 recordInstance ''StoredDomainRegistration
 
 data DomainRegistrationStore m a where
-  Upsert :: StoredDomainRegistration -> DomainRegistrationStore m ()
-  Lookup :: Domain -> DomainRegistrationStore m (Maybe StoredDomainRegistration)
-  Delete :: Domain -> DomainRegistrationStore m ()
+  UpsertInternal :: StoredDomainRegistration -> DomainRegistrationStore m ()
+  LookupInternal :: Domain -> DomainRegistrationStore m (Maybe StoredDomainRegistration)
+  DeleteInternal :: Domain -> DomainRegistrationStore m ()
 
 makeSem ''DomainRegistrationStore
+
+upsert :: (Member DomainRegistrationStore r) => StoredDomainRegistration -> Sem r ()
+upsert storedDomainReg = upsertInternal $ storedDomainReg {Wire.DomainRegistrationStore.domain = storedDomainReg.domain & (Domain . T.toLower . domainText)}
+
+lookup :: (Member DomainRegistrationStore r) => Domain -> Sem r (Maybe StoredDomainRegistration)
+lookup domain = lookupInternal $ Domain . T.toLower . domainText $ domain
+
+delete :: (Member DomainRegistrationStore r) => Domain -> Sem r ()
+delete domain = deleteInternal $ Domain . T.toLower . domainText $ domain
diff --git a/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/DomainRegistrationStore/Cassandra.hs
@@ -23,9 +23,9 @@ interpretDomainRegistrationStoreToCassandra ::
 interpretDomainRegistrationStoreToCassandra casClient =
   interpret $
     embed @IO . runClient casClient . \case
-      Upsert dr -> upsert dr
-      Lookup domain -> lookup domain
-      Delete domain -> delete domain
+      UpsertInternal dr -> upsert dr
+      LookupInternal domain -> lookup domain
+      DeleteInternal domain -> delete domain
 
 upsert :: (MonadClient m) => StoredDomainRegistration -> m ()
 upsert dr = retry x5 $ write cqlUpsert (params LocalQuorum (asTuple dr))

diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs
@@ -3,8 +3,16 @@
 module Wire.EnterpriseLoginSubsystem where
 
 import Data.Domain
+import Data.Id
+import Imports
 import Polysemy
+import Text.Email.Parser
 import Wire.API.EnterpriseLogin
+import Wire.Arbitrary
+
+data InvitationFlow = ExistingUser | NewUser
+  deriving (Show, Eq, Generic)
+  deriving (Arbitrary) via GenericUniform InvitationFlow
 
 data EnterpriseLoginSubsystem m a where
   LockDomain :: Domain -> EnterpriseLoginSubsystem m ()
@@ -14,5 +22,7 @@ data EnterpriseLoginSubsystem m a where
   UpdateDomainRegistration :: Domain -> DomainRegistrationUpdate -> EnterpriseLoginSubsystem m ()
   DeleteDomain :: Domain -> EnterpriseLoginSubsystem m ()
   GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m DomainRegistration
+  GuardEmailDomainRegistrationTeamInvitation :: InvitationFlow -> TeamId -> EmailAddress -> EnterpriseLoginSubsystem m ()
+  GuardEmailDomainRegistrationRegister :: EmailAddress -> EnterpriseLoginSubsystem m ()
 
 makeSem ''EnterpriseLoginSubsystem
diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Error.hs
@@ -1,8 +1,10 @@
 module Wire.EnterpriseLoginSubsystem.Error where
 
+import Data.Text.Lazy qualified as LT
 import Imports
 import Network.HTTP.Types
 import Network.Wai.Utilities qualified as Wai
+import Wire.Arbitrary
 import Wire.Error
 
 data EnterpriseLoginSubsystemError
@@ -12,10 +14,22 @@ data EnterpriseLoginSubsystemError
   | EnterpriseLoginSubsystemUnlockError
   | EnterpriseLoginSubsystemUnAuthorizeError
   | EnterpriseLoginSubsystemPreAuthorizeError
-  deriving (Show, Eq)
+  | EnterpriseLoginSubsystemGuardFailed GuardFailure
+  deriving (Show, Eq, Generic)
+  deriving (Arbitrary) via (GenericUniform EnterpriseLoginSubsystemError)
 
 instance Exception EnterpriseLoginSubsystemError
 
+data GuardFailure
+  = DomRedirSetToSSO
+  | DomRedirSetToBackend
+  | DomRedirSetToNoRegistration
+  | TeamInviteSetToNotAllowed
+  | TeamInviteRestrictedToOtherTeam
+  | InvalidDomain String
+  deriving (Show, Eq, Generic)
+  deriving (Arbitrary) via (GenericUniform GuardFailure)
+
 enterpriseLoginSubsystemErrorToHttpError :: EnterpriseLoginSubsystemError -> HttpError
 enterpriseLoginSubsystemErrorToHttpError =
   StdError . \case
@@ -25,3 +39,13 @@ enterpriseLoginSubsystemErrorToHttpError =
     EnterpriseLoginSubsystemUnlockError -> Wai.mkError status409 "unlock-error" "Domain can only be unlocked from a locked state"
     EnterpriseLoginSubsystemUnAuthorizeError -> Wai.mkError status409 "unauthorize-error" "Domain redirect can not bet set to unauthorized when locked or SSO"
     EnterpriseLoginSubsystemPreAuthorizeError -> Wai.mkError status409 "preauthorize-error" "Domain redirect must be 'none' to be pre-authorized"
+    EnterpriseLoginSubsystemGuardFailed err ->
+      let e403 msg = Wai.mkError status403 "condition-failed" msg
+          e400 msg = Wai.mkError status400 "invalid-domain" (LT.pack msg)
+       in case err of
+            DomRedirSetToSSO -> e403 "`domain_redirect` is set to `sso:{code}`"
+            DomRedirSetToBackend -> e403 "`domain_redirect` is set to `backend`"
+            DomRedirSetToNoRegistration -> e403 "`domain_redirect` is set to `no-registration`"
+            TeamInviteSetToNotAllowed -> e403 "`teamInvite` is set to `not-allowed`"
+            TeamInviteRestrictedToOtherTeam -> e403 "`teamInvite` is restricted to another team."
+            InvalidDomain msg -> e400 msg -- probably impossible.
diff --git a/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs
@@ -11,12 +11,13 @@ where
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Encode.Pretty qualified as Aeson
 import Data.ByteString.Conversion (toByteString')
-import Data.Domain (Domain, domainText)
+import Data.Domain (Domain, domainText, mkDomain)
 import Data.Id
 import Data.Misc (HttpsUrl (..))
+import Data.Text.Encoding as T
 import Data.Text.Internal.Builder (fromLazyText, fromText, toLazyText)
 import Data.Text.Lazy.Builder (Builder)
-import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Lazy.Encoding as LT
 import Imports hiding (lookup)
 import Network.Mail.Mime (Address (Address), Mail (mailHeaders, mailParts, mailTo), emptyMail, plainPart)
 import Polysemy
@@ -26,12 +27,13 @@ import Polysemy.TinyLog (TinyLog)
 import Polysemy.TinyLog qualified as Log
 import SAML2.WebSSO qualified as SAML
 import System.Logger.Message qualified as Log
+import Text.Email.Parser qualified as Email
 import Wire.API.EnterpriseLogin
 import Wire.API.User.EmailAddress (EmailAddress, fromEmail)
 import Wire.DomainRegistrationStore
 import Wire.EmailSending (EmailSending, sendMail)
 import Wire.EnterpriseLoginSubsystem
-import Wire.EnterpriseLoginSubsystem.Error
+import Wire.EnterpriseLoginSubsystem.Error as Error
 
 data EnterpriseLoginSubsystemConfig = EnterpriseLoginSubsystemConfig
   { auditEmailSender :: EmailAddress,
@@ -56,6 +58,8 @@ runEnterpriseLoginSubsystem = interpret $
     UpdateDomainRegistration domain update -> updateDomainRegistrationImpl domain update
     DeleteDomain domain -> deleteDomainImpl domain
     GetDomainRegistration domain -> getDomainRegistrationImpl domain
+    GuardEmailDomainRegistrationTeamInvitation flow tid email -> guardEmailDomainRegistrationTeamInvitationImpl flow tid email
+    GuardEmailDomainRegistrationRegister email -> guardEmailDomainRegistrationRegisterImpl email
 
 deleteDomainImpl ::
   ( Member DomainRegistrationStore r,
@@ -328,15 +332,90 @@ sendAuditMail url subject mBefore mAfter = do
         toLazyText $
           url
             <> " called;\nOld value:\n"
-            <> fromLazyText (decodeUtf8 (maybe "null" Aeson.encodePretty mBefore))
+            <> fromLazyText (LT.decodeUtf8 (maybe "null" Aeson.encodePretty mBefore))
             <> "\nNew value:\n"
-            <> fromLazyText (decodeUtf8 (maybe "null" Aeson.encodePretty mAfter))
+            <> fromLazyText (LT.decodeUtf8 (maybe "null" Aeson.encodePretty mAfter))
   Log.info $
     Log.msg (Log.val "Domain registration audit log")
-      . Log.field "url" (encodeUtf8 $ toLazyText url)
+      . Log.field "url" (LT.encodeUtf8 $ toLazyText url)
       . Log.field "old_value" (maybe "null" Aeson.encode mBefore)
       . Log.field "new_value" (maybe "null" Aeson.encode mAfter)
   mConfig <- input
   for_ mConfig $ \config -> do
     let mail = mkAuditMail (config.auditEmailSender) (config.auditEmailRecipient) subject auditLog
     sendMail mail
+
+-- More info on the behavioral implications of domain registration records:
+-- https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1570832467/Email+domain+registration+and+configuration#Configuration-values
+emailToDomainRegistration ::
+  forall r.
+  ( Member DomainRegistrationStore r,
+    Member (Error EnterpriseLoginSubsystemError) r,
+    Member TinyLog r
+  ) =>
+  EmailAddress ->
+  Sem r (Maybe DomainRegistration)
+emailToDomainRegistration email = case mkDomain $ T.decodeUtf8 $ Email.domainPart email of
+  Right dom -> tryGetDomainRegistrationImpl dom
+  Left msg ->
+    -- The EmailAddress parser and servant *should* make this impossible, but they use
+    -- different parsers, one of us is ours and may change any time, so who knows?
+    throw . EnterpriseLoginSubsystemGuardFailed $ InvalidDomain msg
+
+guardEmailDomainRegistrationTeamInvitationImpl ::
+  forall r.
+  ( Member DomainRegistrationStore r,
+    Member (Error EnterpriseLoginSubsystemError) r,
+    Member TinyLog r
+  ) =>
+  InvitationFlow ->
+  TeamId ->
+  EmailAddress ->
+  Sem r ()
+guardEmailDomainRegistrationTeamInvitationImpl invitationFlow tid email = do
+  mReg <- emailToDomainRegistration email
+  for_ mReg $ \reg -> do
+    -- fail if domain-redirect is set to no-registration, or
+    case reg.domainRedirect of
+      None -> ok
+      Locked -> ok
+      SSO _ -> ok
+      Backend _ -> ok
+      NoRegistration -> case invitationFlow of
+        ExistingUser -> nope DomRedirSetToNoRegistration
+        NewUser -> ok -- https://wearezeta.atlassian.net/wiki/spaces/ENGINEERIN/pages/1587118249/Use+case+initiate+invitation+flow?focusedCommentId=1672839248
+      PreAuthorized -> ok
+    -- team-invitation is set to not-allowed or team:{team id} for any team ID that is not
+    -- the team of the inviter
+    case reg.teamInvite of
+      Allowed -> ok
+      NotAllowed -> nope TeamInviteSetToNotAllowed
+      Team allowedTid ->
+        if allowedTid == tid
+          then ok
+          else nope TeamInviteRestrictedToOtherTeam
+  where
+    ok = pure ()
+    nope = throw . EnterpriseLoginSubsystemGuardFailed
+
+guardEmailDomainRegistrationRegisterImpl ::
+  forall r.
+  ( Member DomainRegistrationStore r,
+    Member (Error EnterpriseLoginSubsystemError) r,
+    Member TinyLog r
+  ) =>
+  EmailAddress ->
+  Sem r ()
+guardEmailDomainRegistrationRegisterImpl email = do
+  mReg <- emailToDomainRegistration email
+  for_ mReg $ \reg -> do
+    case reg.domainRedirect of
+      None -> ok
+      Locked -> ok
+      SSO _ -> nope DomRedirSetToSSO
+      Backend _ -> nope DomRedirSetToBackend
+      NoRegistration -> nope DomRedirSetToNoRegistration
+      PreAuthorized -> ok
+  where
+    ok = pure ()
+    nope = throw . EnterpriseLoginSubsystemGuardFailed
diff --git a/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/TeamInvitationSubsystem/Error.hs
@@ -11,7 +11,9 @@ data TeamInvitationSubsystemError
   | TooManyTeamInvitations
   | TeamInvitationBlacklistedEmail
   | TeamInvitationEmailTaken
-  deriving (Show)
+  deriving (Eq, Show)
+
+instance Exception TeamInvitationSubsystemError
 
 teamInvitationErrorToHttpError :: TeamInvitationSubsystemError -> HttpError
 teamInvitationErrorToHttpError =