diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index fdefca08785..24ec6786981 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9ad577393611ee91f6a62115d4f12241752f808fc982eddbdffc91149d1d122d +-- hash: bb4a3b9b5b4305ddf1e6c3bb031fa8784a988c45b2754e5be43c1db94a057502 name: brig version: 1.35.0 @@ -51,6 +51,7 @@ library Brig.Data.Types Brig.Data.User Brig.Data.UserKey + Brig.Data.UserPendingActivation Brig.Email Brig.Index.Eval Brig.Index.Migrations @@ -187,6 +188,7 @@ library , retry >=0.7 , ropes >=0.4.20 , safe >=0.3 + , safe-exceptions >=0.1 , scientific >=0.3.4 , scrypt >=0.5 , semigroups >=0.15 @@ -286,6 +288,7 @@ executable brig-integration API.User.Property API.User.RichInfo API.User.Util + API.UserPendingActivation Index.Create Util Util.AWS @@ -296,6 +299,8 @@ executable brig-integration ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -funbox-strict-fields build-depends: HsOpenSSL + , MonadRandom >=0.5 + , QuickCheck , aeson , async , attoparsec @@ -312,11 +317,14 @@ executable brig-integration , containers , cookie , data-timeout + , email-validate , exceptions , extra , filepath >=1.4 , galley-types , gundeck-types + , hscim + , http-api-data , http-client , http-client-tls >=0.2 , http-types @@ -333,7 +341,9 @@ executable brig-integration , random >=1.0 , retry >=0.6 , safe + , saml2-web-sso , semigroups + , spar , string-conversions , tasty >=1.0 , tasty-cannon >=0.3.4 @@ -416,6 +426,7 @@ executable brig-schema V60_AddFederationIdMapping V61_team_invitation_email V62_RemoveFederationIdMapping + V63_AddUsersPendingActivation V9 Paths_brig hs-source-dirs: diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 438dea8989e..0078adc74e2 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -131,6 +131,7 @@ turn: optSettings: setActivationTimeout: 5 setTeamInvitationTimeout: 5 + setExpiredUserCleanupTimeout: 1 setTwilio: test/resources/twilio-credentials.yaml setNexmo: test/resources/nexmo-credentials.yaml # setStomp: test/resources/stomp-credentials.yaml diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 5f21216ed64..9c958d1eb16 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -93,6 +93,7 @@ library: - scrypt >=0.5 - smtp-mail >=0.1 - split >=0.2 + - safe-exceptions >=0.1 - semigroups >=0.15 - servant - servant-server @@ -183,6 +184,7 @@ executables: source-dirs: test/integration dependencies: - aeson + - lens-aeson - async - attoparsec - bilge @@ -198,12 +200,15 @@ executables: - containers - cookie - data-timeout + - email-validate - extra - exceptions - filepath >=1.4 - galley-types - gundeck-types - HsOpenSSL + - hscim + - http-api-data - http-client - http-client-tls >=0.2 - http-types @@ -212,15 +217,19 @@ executables: - lens-aeson - metrics-wai - mime >=0.4 + - MonadRandom >= 0.5 - network - options >=0.1 - optparse-applicative - pem - proto-lens + - QuickCheck - random >=1.0 - retry >=0.6 - safe + - saml2-web-sso - semigroups + - spar - string-conversions - tasty >=1.0 - tasty-cannon >=0.3.4 diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 8966d04782f..9f25bff40c6 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -72,6 +72,7 @@ import qualified V59 import qualified V60_AddFederationIdMapping import qualified V61_team_invitation_email import qualified V62_RemoveFederationIdMapping +import qualified V63_AddUsersPendingActivation import qualified V9 main :: IO () @@ -133,7 +134,11 @@ main = do V59.migration, V60_AddFederationIdMapping.migration, V61_team_invitation_email.migration, - V62_RemoveFederationIdMapping.migration + V62_RemoveFederationIdMapping.migration, + V63_AddUsersPendingActivation.migration + -- When adding migrations here, don't forget to update + -- 'schemaVersion' in Brig.App + -- FUTUREWORK: undo V41 (searchable flag); we stopped using it in -- https://github.com/wireapp/wire-server/pull/964 ] diff --git a/services/brig/schema/src/V63_AddUsersPendingActivation.hs b/services/brig/schema/src/V63_AddUsersPendingActivation.hs new file mode 100644 index 00000000000..211ddc9f88f --- /dev/null +++ b/services/brig/schema/src/V63_AddUsersPendingActivation.hs @@ -0,0 +1,38 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V63_AddUsersPendingActivation (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 63 "Add users_pending_activation" $ + -- This table keeps track of users that were invited via SCIM. + -- When their invitation expires this table is used + -- to clean any data of these expired users. + schema' + [r| + CREATE TABLE users_pending_activation + ( + user uuid + , expires_at timestamp + , primary key (user) + ) + |] diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 842fc14bc54..7eb74a5bb03 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -49,6 +49,7 @@ module Brig.API.User removePhone, revokeIdentity, deleteUserNoVerify, + deleteUsersNoVerify, Brig.API.User.deleteUser, verifyDeleteUser, deleteAccount, @@ -102,6 +103,8 @@ import Brig.Data.User import qualified Brig.Data.User as Data import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data +import Brig.Data.UserPendingActivation +import qualified Brig.Data.UserPendingActivation as Data import qualified Brig.IO.Intra as Intra import qualified Brig.InternalEvent.Types as Internal import Brig.Options hiding (Timeout, internalEvents) @@ -132,9 +135,10 @@ import Data.Id as Id import Data.Json.Util import Data.List1 (List1) import qualified Data.Map.Strict as Map +import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) import Data.Qualified -import Data.Time.Clock (diffUTCTime) +import Data.Time.Clock (addUTCTime, diffUTCTime) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team import qualified Galley.Types.Teams.Intra as Team @@ -328,6 +332,7 @@ createUser new@NewUser {..} = do field "user" (toByteString uid) . field "team" (toByteString $ Team.iiTeam ii) . msg (val "Accepting invitation") + Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam @@ -356,6 +361,15 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca verifyUniquenessAndCheckBlacklist emKey account <- lift $ newAccountInviteViaScim uid tid loc name email Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (Log.val "User.createUserInviteViaScim") + + -- add the expiry table entry first! (if brig creates an account, and then crashes before + -- creating the expiry table entry, gc will miss user data.) + expiresAt <- do + ttl <- setTeamInvitationTimeout <$> view settings + now <- liftIO =<< view currentTime + pure $ addUTCTime (realToFrac ttl) now + lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) + let activated = -- It would be nice to set this to 'False' to make sure we're not accidentally -- treating 'PendingActivation' as 'Active', but then 'Brig.Data.User.toIdentity' @@ -363,6 +377,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca -- the SCIM user. True lift $ Data.insertAccount account Nothing Nothing activated + return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. @@ -1006,6 +1021,13 @@ deleteUserNoVerify uid = do queue <- view internalEvents Queue.enqueue queue (Internal.DeleteUser uid) +deleteUsersNoVerify :: [UserId] -> AppIO () +deleteUsersNoVerify uids = do + for_ uids deleteUserNoVerify + m <- view metrics + Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.enqueue_multi_delete_total") m + Metrics.counterIncr (Metrics.path "user.enqueue_multi_delete_calls_total") m + -- | Garbage collect users if they're ephemeral and they have expired. -- Always returns the user (deletion itself is delayed) userGC :: User -> AppIO User diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 2deb024d8ab..cc64578086c 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -132,7 +132,7 @@ import Util.Options import Wire.API.User.Identity (Email) schemaVersion :: Int32 -schemaVersion = 62 +schemaVersion = 63 ------------------------------------------------------------------------------- -- Environment diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs new file mode 100644 index 00000000000..f56025ccd26 --- /dev/null +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Data.UserPendingActivation + ( usersPendingActivationAdd, + usersPendingActivationList, + usersPendingActivationRemove, + usersPendingActivationRemoveMultiple, + UserPendingActivation (..), + ) +where + +import Brig.App (AppIO) +import Cassandra +import Data.Id (UserId) +import Data.Time (UTCTime) +import Imports + +data UserPendingActivation = UserPendingActivation + { upaUserId :: !UserId, + upaDay :: !UTCTime + } + deriving stock (Eq, Show, Ord) + +usersPendingActivationAdd :: UserPendingActivation -> AppIO () +usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do + retry x5 . write insertExpiration . params Quorum $ (uid, expiresAt) + where + insertExpiration :: PrepQuery W (UserId, UTCTime) () + insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" + +usersPendingActivationList :: AppIO (Page UserPendingActivation) +usersPendingActivationList = do + uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params Quorum ())) + where + selectExpired :: PrepQuery R () (UserId, UTCTime) + selectExpired = + "SELECT user, expires_at FROM users_pending_activation" + +usersPendingActivationRemove :: UserId -> AppIO () +usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] + +usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () +usersPendingActivationRemoveMultiple uids = + retry x5 . write deleteExpired . params Quorum $ (Identity uids) + where + deleteExpired :: PrepQuery W (Identity [UserId]) () + deleteExpired = + "DELETE FROM users_pending_activation WHERE user IN ?" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index eeb8657e259..c8e6e1a1f6b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -398,6 +398,8 @@ data Settings = Settings setActivationTimeout :: !Timeout, -- | Team invitation timeout, in seconds setTeamInvitationTimeout :: !Timeout, + -- | Check for expired users every so often, in seconds + setExpiredUserCleanupTimeout :: !(Maybe Timeout), -- | Twilio credentials setTwilio :: !FilePathSecrets, -- | Nexmo credentials diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 93ab43adb02..97860be15e5 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NumericUnderscores #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -24,21 +26,28 @@ where import Brig.API (sitemap) import Brig.API.Handler import Brig.API.Public (ServantAPI, SwaggerDocsAPI, servantSitemap, swaggerDocsAPI) +import qualified Brig.API.User as API import Brig.AWS (sesQueue) import qualified Brig.AWS as AWS import qualified Brig.AWS.SesNotification as SesNotification import Brig.App import qualified Brig.Calling as Calling +import Brig.Data.UserPendingActivation (UserPendingActivation (..), usersPendingActivationList, usersPendingActivationRemoveMultiple) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue +import Brig.Types.Intra (AccountStatus (PendingInvitation)) +import Cassandra (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async -import Control.Lens ((.~), (^.)) -import Control.Monad.Catch (finally) +import Control.Exception.Safe (catchAny) +import Control.Lens (view, (.~), (^.)) +import Control.Monad.Catch (MonadCatch, finally) +import Control.Monad.Random (Random (randomRIO)) import Data.Default (Default (def)) import Data.Id (RequestId (..)) import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) +import Data.String.Conversions (cs) import Data.Text (unpack) import Imports hiding (head) import qualified Network.Wai as Wai @@ -49,6 +58,8 @@ import Network.Wai.Utilities.Server import qualified Network.Wai.Utilities.Server as Server import Servant ((:<|>) (..)) import qualified Servant +import System.Logger (msg, val, (.=), (~~)) +import System.Logger.Class (MonadLogger, err) import Util.Options -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -69,10 +80,13 @@ run o = do AWS.execute (e ^. awsEnv) $ AWS.listen throttleMillis q (runAppT e . SesNotification.onEvent) sftDiscovery <- forM (e ^. sftEnv) $ Async.async . Calling.startSFTServiceDiscovery (e ^. applog) + pendingActivationCleanupAsync <- Async.async (runAppT e pendingActivationCleanup) + runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener Async.cancel internalEventListener mapM_ Async.cancel sftDiscovery + Async.cancel pendingActivationCleanupAsync closeEnv e where endpoint = brig o @@ -111,3 +125,60 @@ lookupRequestIdMiddleware :: (RequestId -> Wai.Application) -> Wai.Application lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont + +pendingActivationCleanup :: AppIO () +pendingActivationCleanup = do + safeForever "pendingActivationCleanup" $ do + now <- liftIO =<< view currentTime + forExpirationsPaged $ \exps -> do + uids <- + ( for exps $ \(UserPendingActivation uid expiresAt) -> do + isPendingInvitation <- (Just PendingInvitation ==) <$> API.lookupStatus uid + pure $ + ( expiresAt < now, + isPendingInvitation, + uid + ) + ) + + API.deleteUsersNoVerify $ + catMaybes + ( uids <&> \(isExpired, isPendingInvitation, uid) -> + if isExpired && isPendingInvitation then Just uid else Nothing + ) + + usersPendingActivationRemoveMultiple $ + catMaybes + ( uids <&> \(isExpired, _isPendingInvitation, uid) -> + if isExpired then Just uid else Nothing + ) + + threadDelayRandom + where + safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () + safeForever funName action = + forever $ + action `catchAny` \exc -> do + err $ "error" .= show exc ~~ msg (val $ cs funName <> " failed") + -- pause to keep worst-case noise in logs manageable + threadDelay 60_000_000 + + forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () + forExpirationsPaged f = do + go =<< usersPendingActivationList + where + go :: (Page UserPendingActivation) -> AppIO () + go (Page hasMore result nextPage) = do + f result + when hasMore $ + go =<< liftClient nextPage + + threadDelayRandom :: AppIO () + threadDelayRandom = do + cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings + let d = realToFrac cleanupTimeout + randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * d, d)) + threadDelay (randomSecs * 1_000_000) + + hours :: Double -> Timeout + hours n = realToFrac (n * 60 * 60) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs new file mode 100644 index 00000000000..a63cbff86fd --- /dev/null +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module API.UserPendingActivation where + +import API.Team.Util (getTeams) +import Bilge hiding (query) +import Bilge.Assert (( Manager -> ClientState -> Brig -> Galley -> Spar -> IO TestTree +tests opts m db brig galley spar = do + return $ + testGroup + "cleanExpiredPendingInvitations" + [ test m "expired users get cleaned" (testCleanExpiredPendingInvitations opts db brig galley spar), + test m "users that register dont get cleaned" (testRegisteredUsersNotCleaned opts db brig galley spar) + ] + +testCleanExpiredPendingInvitations :: Opts -> ClientState -> Brig -> Galley -> Spar -> Http () +testCleanExpiredPendingInvitations opts db brig galley spar = do + (owner, tid) <- createUserWithTeamDisableSSO brig galley + tok <- createScimToken spar owner + uid <- do + email <- randomEmail + scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) + (scimStoredUser, _inv, _inviteeCode) <- createUserStep spar brig tok tid scimUser email + pure $ (Scim.id . Scim.thing) scimStoredUser + assertUserExist "user should exist" db uid True + waitUserExpiration opts + assertUserExist "user should be removed" db uid False + +testRegisteredUsersNotCleaned :: Opts -> ClientState -> Brig -> Galley -> Spar -> Http () +testRegisteredUsersNotCleaned opts db brig galley spar = do + (owner, tid) <- createUserWithTeamDisableSSO brig galley + tok <- createScimToken spar owner + email <- randomEmail + scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) + (scimStoredUser, _inv, inviteeCode) <- createUserStep spar brig tok tid scimUser email + let uid = (Scim.id . Scim.thing) scimStoredUser + assertUserExist "user should exist" db uid True + registerInvitation brig email (Name "Alice") inviteeCode True + waitUserExpiration opts + assertUserExist "user should still exist" db uid True + +createScimToken :: Spar -> UserId -> HttpT IO ScimToken +createScimToken spar' owner = do + CreateScimTokenResponse tok _ <- + createToken spar' owner $ + CreateScimToken + { createScimTokenDescr = "testCreateToken", + createScimTokenPassword = Just defPassword + } + pure tok + +createUserStep :: Spar -> Brig -> ScimToken -> TeamId -> Scim.User.User SparTag -> Email -> HttpT IO (WithMeta (WithId UserId (Scim.User.User SparTag)), Invitation, InvitationCode) +createUserStep spar' brig' tok tid scimUser email = do + scimStoredUser <- createUser spar' tok scimUser + inv <- getInvitationByEmail brig' email + Just inviteeCode <- getInvitationCode brig' tid (inInvitation inv) + pure (scimStoredUser, inv, inviteeCode) + +assertUserExist :: HasCallStack => String -> ClientState -> UserId -> Bool -> HttpT IO () +assertUserExist msg db' uid shouldExist = liftIO $ do + exists <- aFewTimes 12 (runClient db' (userExists uid)) (== shouldExist) + assertEqual msg shouldExist exists + +waitUserExpiration :: (MonadIO m, MonadUnliftIO m) => Opts -> m () +waitUserExpiration opts' = do + let timeoutSecs = round @Double . realToFrac . setTeamInvitationTimeout . optSettings $ opts' + Control.Exception.assert (timeoutSecs < 30) $ do + threadDelay $ (timeoutSecs + 3) * 1_000_000 + +userExists :: MonadClient m => UserId -> m Bool +userExists uid = do + x <- retry x1 (query1 usersSelect (params Quorum (Identity uid))) + pure $ + case x of + Nothing -> False + Just (_, mbStatus) -> + maybe True (/= Deleted) mbStatus + where + usersSelect :: PrepQuery R (Identity UserId) (UserId, Maybe AccountStatus) + usersSelect = "SELECT id, status FROM user where id = ?" + +getInvitationByEmail :: Brig -> Email -> Http Invitation +getInvitationByEmail brig email = + responseJsonUnsafe + <$> ( Bilge.get (brig . path "/i/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) + Brig -> Galley -> m (UserId, TeamId) +createUserWithTeamDisableSSO brg gly = do + e <- randomEmail + n <- UUID.toString <$> liftIO UUID.nextRandom + let p = + RequestBodyLBS . Aeson.encode $ + object + [ "name" .= n, + "email" .= Brig.fromEmail e, + "password" .= defPassword, + "team" .= newTeam + ] + bdy <- selfUser . responseJsonUnsafe <$> post (brg . path "/i/users" . contentJson . body p) + let (uid, Just tid) = (Brig.userId bdy, Brig.userTeam bdy) + (team : _) <- (^. Galley.teamListTeams) <$> getTeams uid gly + () <- + Control.Exception.assert {- "Team ID in registration and team table do not match" -} (tid == team ^. Galley.teamId) $ + pure () + selfTeam <- Brig.userTeam . Brig.selfUser <$> getSelfProfile brg uid + () <- + Control.Exception.assert {- "Team ID in self profile and team table do not match" -} (selfTeam == Just tid) $ + pure () + return (uid, tid) + +randomScimUser :: (HasCallStack, MonadRandom m, MonadIO m) => m (Scim.User.User SparTag) +randomScimUser = fst <$> randomScimUserWithSubject + +-- | Like 'randomScimUser', but also returns the intended subject ID that the user should +-- have. It's already available as 'Scim.User.externalId' but it's not structured. +randomScimUserWithSubject :: + (HasCallStack, MonadRandom m, MonadIO m) => + m (Scim.User.User SparTag, SAML.UnqualifiedNameID) +randomScimUserWithSubject = do + randomScimUserWithSubjectAndRichInfo =<< liftIO (generate arbitrary) + +-- | See 'randomScimUser', 'randomScimUserWithSubject'. +randomScimUserWithSubjectAndRichInfo :: + (HasCallStack, MonadRandom m, MonadIO m) => + RichInfo -> + m (Scim.User.User SparTag, SAML.UnqualifiedNameID) +randomScimUserWithSubjectAndRichInfo richInfo = do + suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) + emails <- getRandomR (0, 3) >>= \n -> replicateM n randomScimEmail + phones <- getRandomR (0, 3) >>= \n -> replicateM n randomScimPhone + -- Related, but non-trivial to re-use here: 'nextSubject' + (externalId, subj) <- + getRandomR (0, 1 :: Int) <&> \case + 0 -> + ( "scimuser_extid_" <> suffix <> "@example.com", + either (error . show) id $ + SAML.mkUNameIDEmail ("scimuser_extid_" <> suffix <> "@example.com") + ) + 1 -> + ( "scimuser_extid_" <> suffix, + SAML.mkUNameIDUnspecified ("scimuser_extid_" <> suffix) + ) + _ -> error "randomScimUserWithSubject: impossible" + pure + ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra richInfo)) + { Scim.User.displayName = Just ("ScimUser" <> suffix), + Scim.User.externalId = Just externalId, + Scim.User.emails = emails, + Scim.User.phoneNumbers = phones + }, + subj + ) + +randomScimEmail :: MonadRandom m => m Email.Email +randomScimEmail = do + let typ :: Maybe Text = Nothing + -- TODO: where should we catch users with more than one + -- primary email? + primary :: Maybe Scim.ScimBool = Nothing + value :: Email.EmailAddress2 <- do + localpart <- cs <$> replicateM 15 (getRandomR ('a', 'z')) + domainpart <- (<> ".com") . cs <$> replicateM 15 (getRandomR ('a', 'z')) + pure . Email.EmailAddress2 $ Email.unsafeEmailAddress localpart domainpart + pure Email.Email {..} + +randomScimPhone :: MonadRandom m => m Phone.Phone +randomScimPhone = do + let typ :: Maybe Text = Nothing + value :: Maybe Text <- do + let mkdigits n = replicateM n (getRandomR ('0', '9')) + mini <- mkdigits 8 + maxi <- mkdigits =<< getRandomR (0, 7) + pure $ Just (cs ('+' : mini <> maxi)) + pure Phone.Phone {..} + +-- | Create a user. +createUser :: + HasCallStack => + Spar -> + ScimToken -> + Scim.User.User SparTag -> + Http (Scim.StoredUser SparTag) +createUser spar tok user = do + r <- + createUser_ spar (Just tok) user + -- | Authentication + Maybe ScimToken -> + -- | User data + Scim.User.User SparTag -> + -- | Spar endpoint + Http ResponseLBS +createUser_ spar auth user = do + -- NB: we don't use 'mkEmailRandomLocalSuffix' here, because emails + -- shouldn't be submitted via SCIM anyway. + -- TODO: what's the consequence of this? why not update emails via + -- SCIM? how else should they be submitted? i think this there is + -- still some confusion here about the distinction between *validated* + -- emails and *scim-provided* emails, which are two entirely + -- different things. + post $ + ( spar + . paths ["scim", "v2", "Users"] + . scimAuth auth + . contentScim + . json user + . acceptScim + ) + +-- | Add SCIM authentication to a request. +scimAuth :: Maybe ScimToken -> Request -> Request +scimAuth Nothing = id +scimAuth (Just auth) = header "Authorization" (toHeader auth) + +-- | Signal that the body is an SCIM payload. +contentScim :: Request -> Request +contentScim = content "application/scim+json" + +-- | Signal that the response type is expected to be an SCIM payload. +acceptScim :: Request -> Request +acceptScim = accept "application/scim+json" + +getInvitationCode :: + (MonadIO m, MonadHttp m, HasCallStack) => + Brig -> + TeamId -> + InvitationId -> + m (Maybe InvitationCode) +getInvitationCode brig t ref = do + r <- + Bilge.get + ( brig + . path "/i/teams/invitation-code" + . queryItem "team" (toByteString' t) + . queryItem "invitation_id" (toByteString' ref) + ) + let lbs = fromMaybe "" $ responseBody r + return $ fromByteString . fromMaybe (error "No code?") $ encodeUtf8 <$> (lbs ^? key "code" . _String) + +-- | Create a SCIM token. +createToken_ :: + Spar -> + -- | User + UserId -> + CreateScimToken -> + -- | Spar endpoint + Http ResponseLBS +createToken_ spar userid payload = do + post $ + ( spar + . paths ["scim", "auth-tokens"] + . zUser userid + . contentJson + . json payload + . acceptJson + ) + +-- | Create a SCIM token. +createToken :: + HasCallStack => + Spar -> + UserId -> + CreateScimToken -> + Http CreateScimTokenResponse +createToken spar zusr payload = do + r <- + createToken_ + spar + zusr + payload + Email -> Name -> InvitationCode -> Bool -> Http () +registerInvitation brig email name inviteeCode shouldSucceed = do + void $ + post + ( brig . path "/register" + . contentJson + . json (acceptWithName name email inviteeCode) + ) + Email -> InvitationCode -> Aeson.Value +acceptWithName name email code = + Aeson.object + [ "name" Aeson..= fromName name, + "email" Aeson..= fromEmail email, + "password" Aeson..= defPassword, + "team_code" Aeson..= code + ] + +-- | Run a probe several times, until a "good" value materializes or until patience runs out +aFewTimes :: + (HasCallStack, MonadIO m) => + -- | Number of retries. Exponentially: 11 ~ total of 2 secs delay, 12 ~ 4 secs delay, ... + Int -> + m a -> + (a -> Bool) -> + m a +aFewTimes + retries + action + good = do + retrying + (exponentialBackoff 1000 <> limitRetries retries) + (\_ -> pure . not . good) + (\_ -> action) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index b9815a1db48..4a20ce64468 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -27,6 +27,7 @@ import qualified API.Search as Search import qualified API.Settings as Settings import qualified API.Team as Team import qualified API.User as User +import qualified API.UserPendingActivation as UserPendingActivation import Bilge hiding (header) import Brig.API (sitemap) import qualified Brig.AWS as AWS @@ -62,6 +63,7 @@ data Config = Config cargohold :: Endpoint, galley :: Endpoint, nginz :: Endpoint, + spar :: Endpoint, -- external provider provider :: Provider.Config } @@ -81,6 +83,7 @@ runTests iConf bConf otherArgs = do ch <- mkRequest <$> optOrEnv cargohold iConf (local . read) "CARGOHOLD_WEB_PORT" g <- mkRequest <$> optOrEnv galley iConf (local . read) "GALLEY_WEB_PORT" n <- mkRequest <$> optOrEnv nginz iConf (local . read) "NGINZ_WEB_PORT" + s <- mkRequest <$> optOrEnv spar iConf (local . read) "SPAR_WEB_PORT" turnFile <- optOrEnv (Opts.servers . Opts.turn) bConf id "TURN_SERVERS" turnFileV2 <- optOrEnv (Opts.serversV2 . Opts.turn) bConf id "TURN_SERVERS_V2" casHost <- optOrEnv (\v -> (Opts.cassandra v) ^. casEndpoint . epHost) bConf pack "BRIG_CASSANDRA_HOST" @@ -100,6 +103,7 @@ runTests iConf bConf otherArgs = do metricsApi <- Metrics.tests mg b settingsApi <- Settings.tests brigOpts mg b g createIndex <- Index.Create.spec brigOpts + userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" @@ -115,7 +119,8 @@ runTests iConf bConf otherArgs = do turnApi, metricsApi, settingsApi, - createIndex + createIndex, + userPendingActivation ] where mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index f61798825b7..f32561eeaeb 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -79,6 +79,8 @@ type Galley = Request -> Request type Nginz = Request -> Request +type Spar = Request -> Request + instance ToJSON SESBounceType where toJSON BounceUndetermined = String "Undetermined" toJSON BouncePermanent = String "Permanent" diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index a30a3a1203c..f404280e7d7 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -188,7 +188,7 @@ specCreateUser = describe "POST /Users" $ do testCreateUserNoIdP it "fails if no email can be extraced from externalId" $ do testCreateUserNoIdPNoEmail - it "doesn't list users that exceed their invivtation period, and allows recreating them" $ do + it "doesn't list users that exceed their invitation period, and allows recreating them" $ do testCreateUserTimeout context "team has one SAML IdP" $ do it "creates a user in an existing team" $ do @@ -637,7 +637,7 @@ testCreateUserTimeout = do waitUserExpiration searchUser tok scimUser email False - registerInvitation email userName inviteeCode False + aFewTimesRecover $ registerInvitation email userName inviteeCode False searchUser tok scimUser email False (scimStoredUser2, _inv, inviteeCode2) <- createUser'step tok tid scimUser email @@ -646,7 +646,7 @@ testCreateUserTimeout = do let id2 = (Scim.id . Scim.thing) scimStoredUser2 liftIO $ id1 `shouldNotBe` id2 - registerInvitation email userName inviteeCode2 True + aFewTimesRecover $ registerInvitation email userName inviteeCode2 True searchUser tok scimUser email True waitUserExpiration searchUser tok scimUser email True diff --git a/services/spar/test-integration/Util/Invitation.hs b/services/spar/test-integration/Util/Invitation.hs index 4253fdd1324..061737e294b 100644 --- a/services/spar/test-integration/Util/Invitation.hs +++ b/services/spar/test-integration/Util/Invitation.hs @@ -36,12 +36,12 @@ import Imports import Util import Wire.API.Team.Invitation (Invitation (..)) -headInvitation404 :: BrigReq -> Email -> Http () +headInvitation404 :: HasCallStack => BrigReq -> Email -> Http () headInvitation404 brig email = do Bilge.head (brig . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) !!! const 404 === statusCode -getInvitation :: BrigReq -> Email -> Http Invitation +getInvitation :: HasCallStack => BrigReq -> Email -> Http Invitation getInvitation brig email = responseJsonUnsafe <$> Bilge.get @@ -67,7 +67,7 @@ getInvitationCode brig t ref = do let lbs = fromMaybe "" $ responseBody r return $ fromByteString . fromMaybe (error "No code?") $ encodeUtf8 <$> (lbs ^? key "code" . _String) -registerInvitation :: Email -> Name -> InvitationCode -> Bool -> TestSpar () +registerInvitation :: HasCallStack => Email -> Name -> InvitationCode -> Bool -> TestSpar () registerInvitation email name inviteeCode shouldSucceed = do env <- ask let brig = env ^. teBrig