WPB-11217 Move accept team invitation to user subsystem

changelog.d/5-internal/WPB-11217-move-code-for-accepting-invitations-for-personal-users-into-teams-to-wire-subsystems

@@ -0,0 +1,10 @@
+Move some invitation handling from brig to wire-subsystems.
+
+- introduce cyclically dependent effects: UserSubsystem, AuthenticationSubsystem (see Brig.CanonicalInterpreter).
+- introduce TeamInvitationSubsystem with operations inviteUser, internalCreateInvitation.
+- add verifyPassword to AuthenticationSubsystem.
+- add sendInvitationMail, sendInvitationMailPersonalUser to EmailSubsystem.
+- add getTeamSize to IndexedUserStore (this is morally internal to wire-subsystems, and making another ES subsystem would mean adding a lot of code everywhere).
+- add updateUserTeam to UserStore.
+- add acceptTeamInvitation, internalFindTeamInvitation to UserSubsystem.
+- make a few small rest api handlers in brig polysemic (Handler -> Sem).

libs/types-common/default.nix

@@ -19,6 +19,7 @@
 , cryptohash-sha1
 , crypton
 , currency-codes
+, email-validate
 , generic-random
 , gitignoreSource
 , hashable
@@ -79,6 +80,7 @@ mkDerivation {
     cryptohash-sha1
     crypton
     currency-codes
+    email-validate
     generic-random
     hashable
     http-api-data

libs/types-common/src/Util/Logging.hs

@@ -25,6 +25,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Imports
 import System.Logger.Class qualified as Log
 import System.Logger.Message (Msg)
+import Text.Email.Parser
 
 sha256String :: Text -> Text
 sha256String t =
@@ -48,3 +49,7 @@ logUser uid = Log.field "user" (T.pack . show $ uid)
 
 logTeam :: TeamId -> (Msg -> Msg)
 logTeam tid = Log.field "team" (T.pack . show $ tid)
+
+logEmail :: EmailAddress -> (Msg -> Msg)
+logEmail email =
+  Log.field "email_sha256" (sha256String . T.pack . show $ email)

libs/types-common/src/Util/Timeout.hs

@@ -9,12 +9,16 @@ import Data.Aeson.Types
 import Data.Scientific
 import Data.Time.Clock
 import Imports
+import Test.QuickCheck (Arbitrary (arbitrary), choose)
 
 newtype Timeout = Timeout
   { timeoutDiff :: NominalDiffTime
   }
   deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show)
 
+instance Arbitrary Timeout where
+  arbitrary = Timeout . fromIntegral <$> choose (60 :: Int, 10 * 24 * 3600)
+
 instance Read Timeout where
   readsPrec i s =
     case readsPrec i s of

libs/types-common/types-common.cabal

@@ -109,6 +109,7 @@ library
     , cryptohash-sha1        >=0.11.7.2
     , crypton                >=0.26
     , currency-codes         >=3.0.0.1
+    , email-validate
     , generic-random         >=1.4.0.0
     , hashable               >=1.2
     , http-api-data

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

@@ -63,6 +63,7 @@ data BrigError
   | AccountEphemeral
   | AccountPending
   | UserKeyExists
+  | EmailExists
   | NameManagedByScim
   | HandleManagedByScim
   | LocaleManagedByScim
@@ -239,6 +240,8 @@ type instance MapError 'AccountPending = 'StaticError 403 "pending-activation" "
 
 type instance MapError 'UserKeyExists = 'StaticError 409 "key-exists" "The given e-mail address is in use."
 
+type instance MapError 'EmailExists = 'StaticError 409 "email-exists" "The given e-mail address is in use."
+
 type instance MapError 'NameManagedByScim = 'StaticError 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM, or E2EId is enabled"
 
 type instance MapError 'HandleManagedByScim = 'StaticError 403 "managed-by-scim" "Updating handle is not allowed, because it is managed by SCIM, or E2EId is enabled"

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

@@ -1574,7 +1574,7 @@ type TeamsAPI =
         :> CanThrow 'TooManyTeamInvitations
         :> CanThrow 'InsufficientTeamPermissions
         :> CanThrow 'InvalidInvitationCode
-        :> ZUser
+        :> ZLocalUser
         :> "teams"
         :> Capture "tid" TeamId
         :> "invitations"

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

@@ -18,14 +18,17 @@
 
 module Wire.AuthenticationSubsystem where
 
+import Data.Id
 import Data.Misc
+import Data.Qualified
 import Imports
 import Polysemy
 import Wire.API.User
 import Wire.API.User.Password
 import Wire.UserKeyStore
 
 data AuthenticationSubsystem m a where
+  VerifyPassword :: Local UserId -> PlainTextPassword6 -> AuthenticationSubsystem m ()
   CreatePasswordResetCode :: EmailKey -> AuthenticationSubsystem m ()
   ResetPassword :: PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword8 -> AuthenticationSubsystem m ()
   -- For testing

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

@@ -31,6 +31,8 @@ data AuthenticationSubsystemError
   | AuthenticationSubsystemInvalidPasswordResetCode
   | AuthenticationSubsystemInvalidPhone
   | AuthenticationSubsystemAllowListError
+  | AuthenticationSubsystemMissingAuth
+  | AuthenticationSubsystemBadCredentials
   deriving (Eq, Show)
 
 instance Exception AuthenticationSubsystemError
@@ -43,3 +45,5 @@ authenticationSubsystemErrorToHttpError =
     AuthenticationSubsystemResetPasswordMustDiffer -> errorToWai @E.ResetPasswordMustDiffer
     AuthenticationSubsystemInvalidPhone -> errorToWai @E.InvalidPhone
     AuthenticationSubsystemAllowListError -> errorToWai @E.AllowlistError
+    AuthenticationSubsystemMissingAuth -> errorToWai @E.MissingAuth
+    AuthenticationSubsystemBadCredentials -> errorToWai @E.BadCredentials

libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs

@@ -39,7 +39,7 @@ import Wire.API.Allowlists qualified as AllowLists
 import Wire.API.Password
 import Wire.API.User
 import Wire.API.User.Password
-import Wire.AuthenticationSubsystem
+import Wire.AuthenticationSubsystem (AuthenticationSubsystem (..))
 import Wire.AuthenticationSubsystem.Error
 import Wire.EmailSubsystem
 import Wire.HashPassword
@@ -62,15 +62,29 @@ interpretAuthenticationSubsystem ::
     Member SessionStore r,
     Member (Input (Local ())) r,
     Member (Input (Maybe AllowlistEmailDomains)) r,
-    Member UserSubsystem r,
     Member PasswordStore r,
     Member EmailSubsystem r
   ) =>
+  InterpreterFor UserSubsystem r ->
   InterpreterFor AuthenticationSubsystem r
-interpretAuthenticationSubsystem = interpret $ \case
-  CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey
-  ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword
-  InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey
+interpretAuthenticationSubsystem userSubsystemInterpreter =
+  interpret $
+    userSubsystemInterpreter . \case
+      VerifyPassword luid password -> verifyPasswordImpl luid password
+      CreatePasswordResetCode userKey -> createPasswordResetCodeImpl userKey
+      ResetPassword ident resetCode newPassword -> resetPasswordImpl ident resetCode newPassword
+      InternalLookupPasswordResetCode userKey -> internalLookupPasswordResetCodeImpl userKey
+
+verifyPasswordImpl ::
+  ( Member PasswordStore r,
+    Member (Error AuthenticationSubsystemError) r
+  ) =>
+  Local UserId ->
+  PlainTextPassword6 ->
+  Sem r ()
+verifyPasswordImpl (tUnqualified -> uid) password = do
+  p <- lookupHashedPassword uid >>= maybe (throw AuthenticationSubsystemMissingAuth) pure
+  unless (Wire.API.Password.verifyPassword password p) $ throw AuthenticationSubsystemBadCredentials
 
 maxAttempts :: Int32
 maxAttempts = 3

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

@@ -3,6 +3,7 @@
 module Wire.EmailSubsystem where
 
 import Data.Code qualified as Code
+import Data.Id
 import Imports
 import Polysemy
 import Wire.API.Locale
@@ -22,5 +23,9 @@ data EmailSubsystem m a where
   SendTeamActivationMail :: EmailAddress -> Name -> ActivationKey -> ActivationCode -> Maybe Locale -> Text -> EmailSubsystem m ()
   SendTeamDeletionVerificationMail :: EmailAddress -> Code.Value -> Maybe Locale -> EmailSubsystem m ()
   SendUpgradePersonalToTeamConfirmationEmail :: EmailAddress -> Name -> Text -> Locale -> EmailSubsystem m ()
+  -- | send invitation to an unknown email address.
+  SendTeamInvitationMail :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text
+  -- | send invitation to an email address associated with a personal user account.
+  SendTeamInvitationMailPersonalUser :: EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> EmailSubsystem m Text
 
 makeSem ''EmailSubsystem

libs/wire-subsystems/src/Wire/EmailSubsystem/Interpreter.hs

@@ -7,6 +7,7 @@ module Wire.EmailSubsystem.Interpreter
 where
 
 import Data.Code qualified as Code
+import Data.Id
 import Data.Json.Util
 import Data.Range (fromRange)
 import Data.Text qualified as Text
@@ -24,19 +25,21 @@ import Wire.EmailSending (EmailSending, sendMail)
 import Wire.EmailSubsystem
 import Wire.EmailSubsystem.Template
 
-emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r
-emailSubsystemInterpreter tpls branding = interpret \case
-  SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl tpls branding email key code mLocale
-  SendVerificationMail email key code mLocale -> sendVerificationMailImpl tpls branding email key code mLocale
-  SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl tpls branding email code mLocale
-  SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl tpls branding email code mLocale
-  SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl tpls branding email code mLocale
-  SendActivationMail email name key code mLocale -> sendActivationMailImpl tpls branding email name key code mLocale
-  SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl tpls branding email name key code mLocale
-  SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl tpls branding email name key code mLocale teamName
-  SendNewClientEmail email name client locale -> sendNewClientEmailImpl tpls branding email name client locale
-  SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl tpls branding email name key code locale
-  SendUpgradePersonalToTeamConfirmationEmail email name teamName locale -> sendUpgradePersonalToTeamConfirmationEmailImpl tpls branding email name teamName locale
+emailSubsystemInterpreter :: (Member EmailSending r) => Localised UserTemplates -> Localised TeamTemplates -> TemplateBranding -> InterpreterFor EmailSubsystem r
+emailSubsystemInterpreter userTpls teamTpls branding = interpret \case
+  SendPasswordResetMail email (key, code) mLocale -> sendPasswordResetMailImpl userTpls branding email key code mLocale
+  SendVerificationMail email key code mLocale -> sendVerificationMailImpl userTpls branding email key code mLocale
+  SendTeamDeletionVerificationMail email code mLocale -> sendTeamDeletionVerificationMailImpl userTpls branding email code mLocale
+  SendCreateScimTokenVerificationMail email code mLocale -> sendCreateScimTokenVerificationMailImpl userTpls branding email code mLocale
+  SendLoginVerificationMail email code mLocale -> sendLoginVerificationMailImpl userTpls branding email code mLocale
+  SendActivationMail email name key code mLocale -> sendActivationMailImpl userTpls branding email name key code mLocale
+  SendEmailAddressUpdateMail email name key code mLocale -> sendEmailAddressUpdateMailImpl userTpls branding email name key code mLocale
+  SendTeamActivationMail email name key code mLocale teamName -> sendTeamActivationMailImpl userTpls branding email name key code mLocale teamName
+  SendNewClientEmail email name client locale -> sendNewClientEmailImpl userTpls branding email name client locale
+  SendAccountDeletionEmail email name key code locale -> sendAccountDeletionEmailImpl userTpls branding email name key code locale
+  SendUpgradePersonalToTeamConfirmationEmail email name teamName locale -> sendUpgradePersonalToTeamConfirmationEmailImpl userTpls branding email name teamName locale
+  SendTeamInvitationMail email tid from code loc -> sendTeamInvitationMailImpl teamTpls branding email tid from code loc
+  SendTeamInvitationMailPersonalUser email tid from code loc -> sendTeamInvitationMailPersonalUserImpl teamTpls branding email tid from code loc
 
 -------------------------------------------------------------------------------
 -- Verification Email for
@@ -432,6 +435,65 @@ renderUpgradePersonalToTeamConfirmationEmail email name _teamName UpgradePersona
     replace1 "name" = fromName name
     replace1 x = x
 
+-------------------------------------------------------------------------------
+-- Invitation Email
+
+sendTeamInvitationMailImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text
+sendTeamInvitationMailImpl teamTemplates branding to tid from code loc = do
+  let tpl = invitationEmail . snd $ forLocale loc teamTemplates
+      mail = InvitationEmail to tid code from
+      (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding
+  sendMail renderedMail
+  pure renderedInvitaitonUrl
+
+sendTeamInvitationMailPersonalUserImpl :: (Member EmailSending r) => Localised TeamTemplates -> TemplateBranding -> EmailAddress -> TeamId -> EmailAddress -> InvitationCode -> Maybe Locale -> Sem r Text
+sendTeamInvitationMailPersonalUserImpl teamTemplates branding to tid from code loc = do
+  let tpl = existingUserInvitationEmail . snd $ forLocale loc teamTemplates
+      mail = InvitationEmail to tid code from
+      (renderedMail, renderedInvitaitonUrl) = renderInvitationEmail mail tpl branding
+  sendMail renderedMail
+  pure renderedInvitaitonUrl
+
+data InvitationEmail = InvitationEmail
+  { invTo :: !EmailAddress,
+    invTeamId :: !TeamId,
+    invInvCode :: !InvitationCode,
+    invInviter :: !EmailAddress
+  }
+
+renderInvitationEmail :: InvitationEmail -> InvitationEmailTemplate -> TemplateBranding -> (Mail, Text)
+renderInvitationEmail InvitationEmail {..} InvitationEmailTemplate {..} branding =
+  ( (emptyMail from)
+      { mailTo = [to],
+        mailHeaders =
+          [ ("Subject", toStrict subj),
+            ("X-Zeta-Purpose", "TeamInvitation"),
+            ("X-Zeta-Code", Ascii.toText code)
+          ],
+        mailParts = [[plainPart txt, htmlPart html]]
+      },
+    invitationUrl
+  )
+  where
+    (InvitationCode code) = invInvCode
+    from = Address (Just invitationEmailSenderName) (fromEmail invitationEmailSender)
+    to = Address Nothing (fromEmail invTo)
+    txt = renderTextWithBranding invitationEmailBodyText replace branding
+    html = renderHtmlWithBranding invitationEmailBodyHtml replace branding
+    subj = renderTextWithBranding invitationEmailSubject replace branding
+    invitationUrl = renderInvitationUrl invitationEmailUrl invTeamId invInvCode branding
+    replace "url" = invitationUrl
+    replace "inviter" = fromEmail invInviter
+    replace x = x
+
+renderInvitationUrl :: Template -> TeamId -> InvitationCode -> TemplateBranding -> Text
+renderInvitationUrl t tid (InvitationCode c) branding =
+  toStrict $ renderTextWithBranding t replace branding
+  where
+    replace "team" = idToText tid
+    replace "code" = Ascii.toText c
+    replace x = x
+
 -------------------------------------------------------------------------------
 -- MIME Conversions
 

libs/wire-subsystems/src/Wire/EmailSubsystem/Template.hs

@@ -18,31 +18,10 @@
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
 module Wire.EmailSubsystem.Template
-  ( Localised (..),
-    TemplateBranding,
-    forLocale,
-
-    -- * templates
-    UserTemplates (..),
-    ActivationSmsTemplate (..),
-    VerificationEmailTemplate (..),
-    ActivationEmailTemplate (..),
-    TeamActivationEmailTemplate (..),
-    ActivationCallTemplate (..),
-    PasswordResetSmsTemplate (..),
-    PasswordResetEmailTemplate (..),
-    LoginSmsTemplate (..),
-    LoginCallTemplate (..),
-    DeletionSmsTemplate (..),
-    DeletionEmailTemplate (..),
-    UpgradePersonalToTeamEmailTemplate (..),
-    NewClientEmailTemplate (..),
-    SecondFactorVerificationEmailTemplate (..),
+  ( module Wire.EmailSubsystem.Template,
 
     -- * Re-exports
     Template,
-    renderTextWithBranding,
-    renderHtmlWithBranding,
   )
 where
 
@@ -212,3 +191,37 @@ data SecondFactorVerificationEmailTemplate = SecondFactorVerificationEmailTempla
     sndFactorVerificationEmailSender :: EmailAddress,
     sndFactorVerificationEmailSenderName :: Text
   }
+
+data InvitationEmailTemplate = InvitationEmailTemplate
+  { invitationEmailUrl :: !Template,
+    invitationEmailSubject :: !Template,
+    invitationEmailBodyText :: !Template,
+    invitationEmailBodyHtml :: !Template,
+    invitationEmailSender :: !EmailAddress,
+    invitationEmailSenderName :: !Text
+  }
+
+data CreatorWelcomeEmailTemplate = CreatorWelcomeEmailTemplate
+  { creatorWelcomeEmailUrl :: !Text,
+    creatorWelcomeEmailSubject :: !Template,
+    creatorWelcomeEmailBodyText :: !Template,
+    creatorWelcomeEmailBodyHtml :: !Template,
+    creatorWelcomeEmailSender :: !EmailAddress,
+    creatorWelcomeEmailSenderName :: !Text
+  }
+
+data MemberWelcomeEmailTemplate = MemberWelcomeEmailTemplate
+  { memberWelcomeEmailUrl :: !Text,
+    memberWelcomeEmailSubject :: !Template,
+    memberWelcomeEmailBodyText :: !Template,
+    memberWelcomeEmailBodyHtml :: !Template,
+    memberWelcomeEmailSender :: !EmailAddress,
+    memberWelcomeEmailSenderName :: !Text
+  }
+
+data TeamTemplates = TeamTemplates
+  { invitationEmail :: !InvitationEmailTemplate,
+    existingUserInvitationEmail :: !InvitationEmailTemplate,
+    creatorWelcomeEmail :: !CreatorWelcomeEmailTemplate,
+    memberWelcomeEmail :: !MemberWelcomeEmailTemplate
+  }

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

@@ -7,6 +7,7 @@ import Database.Bloodhound qualified as ES
 import Database.Bloodhound.Types hiding (SearchResult)
 import Imports
 import Polysemy
+import Wire.API.Team.Size
 import Wire.API.User.Search
 import Wire.UserSearch.Types
 
@@ -39,5 +40,6 @@ data IndexedUserStore m a where
     Int ->
     Maybe PagingState ->
     IndexedUserStore m (SearchResult UserDoc)
+  GetTeamSize :: TeamId -> IndexedUserStore m TeamSize
 
 makeSem ''IndexedUserStore