From bbdbdc85096578824d55eb0c478ff4c361eb38a3 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 30 Nov 2020 14:21:54 +0100 Subject: [PATCH 01/47] Add cleanup --- libs/types-common/src/Data/Misc.hs | 20 ++++- services/brig/brig.cabal | 3 + services/brig/package.yaml | 1 + services/brig/schema/src/Main.hs | 4 +- .../src/V62_users_pending_activation.hs | 38 +++++++++ services/brig/src/Brig/API/User.hs | 10 ++- .../brig/src/Brig/Data/PendingActivation.hs | 79 +++++++++++++++++++ services/brig/src/Brig/Run.hs | 52 +++++++++++- 8 files changed, 201 insertions(+), 6 deletions(-) create mode 100644 services/brig/schema/src/V62_users_pending_activation.hs create mode 100644 services/brig/src/Brig/Data/PendingActivation.hs diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index 3a0b6106445..f75a0537a4c 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -44,12 +44,15 @@ module Data.Misc mkHttpsUrl, ensureHttpsUrl, + -- * PlainTextPassword + PlainTextPassword (..), + -- * Fingerprint Fingerprint (..), Rsa, - -- * PlainTextPassword - PlainTextPassword (..), + -- * ModJulianDay + ModJulianDay (..), -- * Swagger modelLocation, @@ -71,6 +74,7 @@ import Data.Range import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Calendar (Day (..)) import Imports import Test.QuickCheck (Arbitrary (arbitrary)) import qualified Test.QuickCheck as QC @@ -322,3 +326,15 @@ instance FromJSON PlainTextPassword where instance Arbitrary PlainTextPassword where -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars arbitrary = PlainTextPassword . fromRange <$> genRangeText @6 @1024 arbitrary + +-------------------------------------------------------------------------------- +-- ModJulianDay + +newtype ModJulianDay = ModJulianDay {fromUTCDay :: Day} + deriving stock (Eq, Show) + +instance Cql ModJulianDay where + ctype = Tagged IntColumn + toCql (ModJulianDay (ModifiedJulianDay n)) = CqlInt (fromIntegral n) + fromCql (CqlInt n) = return . ModJulianDay . ModifiedJulianDay . fromIntegral $ n + fromCql _ = Left "ModJulianDay: expected CqlInt" diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 5a0bd6db59d..b564e26d535 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -48,6 +48,7 @@ library Brig.Data.Instances Brig.Data.LoginCode Brig.Data.PasswordReset + Brig.Data.PendingActivation Brig.Data.Properties Brig.Data.Types Brig.Data.User @@ -189,6 +190,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 @@ -416,6 +418,7 @@ executable brig-schema V59 V60_AddFederationIdMapping V61_team_invitation_email + V62_users_pending_activation V9 Paths_brig hs-source-dirs: diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 49146f745fc..7c4ada276e4 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 diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 27ab06b5b0f..0dc6813ef19 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -71,6 +71,7 @@ import qualified V58 import qualified V59 import qualified V60_AddFederationIdMapping import qualified V61_team_invitation_email +import qualified V62_users_pending_activation import qualified V9 main :: IO () @@ -131,7 +132,8 @@ main = do V58.migration, V59.migration, V60_AddFederationIdMapping.migration, - V61_team_invitation_email.migration + V61_team_invitation_email.migration, + V62_users_pending_activation.migration -- 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/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs new file mode 100644 index 00000000000..506dd80edf8 --- /dev/null +++ b/services/brig/schema/src/V62_users_pending_activation.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 V62_users_pending_activation (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = + Migration 62 "Add users_pending_activation" $ + schema' + [r| + CREATE TABLE users_pending_activation + ( + expires_at_day int + , expires_at timestamp + , user uuid + , team uuid + , primary key (expires_at_day, expires_at, user) + ) + with clustering order by (expires_at ASC, user ASC) + |] diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 8d8b98f395e..ff2d4263796 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -97,6 +97,8 @@ import qualified Brig.Data.Blacklist as Blacklist import qualified Brig.Data.Client as Data import qualified Brig.Data.Connection as Data import qualified Brig.Data.PasswordReset as Data +import Brig.Data.PendingActivation (PendingActivationExpiration (..)) +import qualified Brig.Data.PendingActivation as Data import qualified Brig.Data.Properties as Data import Brig.Data.User import qualified Brig.Data.User as Data @@ -134,7 +136,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map 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 @@ -363,6 +365,12 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca -- the SCIM user. True lift $ Data.insertAccount account Nothing Nothing activated + + ttl <- setTeamInvitationTimeout <$> view settings + now <- liftIO =<< view currentTime + let expiresAt = addUTCTime (realToFrac ttl) now + lift $ Data.trackExpiration (PendingActivationExpiration uid expiresAt tid) + return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. diff --git a/services/brig/src/Brig/Data/PendingActivation.hs b/services/brig/src/Brig/Data/PendingActivation.hs new file mode 100644 index 00000000000..c29077064d9 --- /dev/null +++ b/services/brig/src/Brig/Data/PendingActivation.hs @@ -0,0 +1,79 @@ +-- 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.PendingActivation + ( trackExpiration, + searchTrackedExpirations, + removeTrackedExpirations, + PendingActivationExpiration (..), + ) +where + +import Brig.App (AppIO) +import Cassandra +import Data.Id (TeamId, UserId) +import Data.Misc (ModJulianDay (..)) +import Data.Time (UTCTime (utctDay)) +import Data.Time.Calendar (Day) +import Data.Tuple.Extra (uncurry3) +import Imports + +data PendingActivationExpiration + = PendingActivationExpiration + !UserId + !UTCTime + !TeamId + deriving stock (Eq) + +-- | Same as clustering order +instance Ord PendingActivationExpiration where + (PendingActivationExpiration uid t _) <= (PendingActivationExpiration uid2 t2 _) = + (t, uid) <= (t2, uid2) + +-- | Note: Call this function only after an invitation for the user has been created +trackExpiration :: PendingActivationExpiration -> AppIO () +trackExpiration (PendingActivationExpiration uid expiresAt tid) = do + retry x5 . write insertExpiration . params Quorum $ (ModJulianDay (utctDay expiresAt), expiresAt, uid, tid) + where + insertExpiration :: PrepQuery W (ModJulianDay, UTCTime, UserId, TeamId) () + insertExpiration = "INSERT INTO users_pending_activation (expires_at_day, expires_at, user, team) VALUES (?, ?, ?, ?)" + +searchTrackedExpirations :: Day -> Maybe PendingActivationExpiration -> AppIO [PendingActivationExpiration] +searchTrackedExpirations dayExpired mbAfter = do + uncurry3 PendingActivationExpiration + <$$> case mbAfter of + Nothing -> retry x1 (query selectExpired (params Quorum (Identity (ModJulianDay dayExpired)))) + Just (PendingActivationExpiration uid t _) -> + retry x1 (query selectExpiredAfter (params Quorum (ModJulianDay dayExpired, t, uid))) + where + selectExpired :: PrepQuery R (Identity ModJulianDay) (UserId, UTCTime, TeamId) + selectExpired = + "SELECT user, expires_at, team FROM users_pending_activation \ + \WHERE expires_at_day = ? LIMIT 100" + + selectExpiredAfter :: PrepQuery R (ModJulianDay, UTCTime, UserId) (UserId, UTCTime, TeamId) + selectExpiredAfter = + "SELECT user, expires_at, team FROM users_pending_activation \ + \WHERE expires_at_day = ? and expires_at > ? and user > ? LIMIT 100" + +removeTrackedExpirations :: Day -> PendingActivationExpiration -> AppIO () +removeTrackedExpirations day (PendingActivationExpiration uid t _) = + retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, t, uid) + where + deleteExpired :: PrepQuery W (ModJulianDay, UTCTime, UserId) () + deleteExpired = + "DELETE FROM users_pending_activation WHERE expires_at_day = ? and expires_at <= ? and user <= ?" diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 2d379cc22a4..841a8998947 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,22 +26,31 @@ where import Brig.API (sitemap) import Brig.API.Handler import Brig.API.Public (ServantAPI, servantSitemap) +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.PendingActivation (PendingActivationExpiration (..), removeTrackedExpirations, searchTrackedExpirations) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue +import qualified Brig.Team.DB as Data 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 Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Id (RequestId (..)) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) +import Data.String.Conversions (cs) import Data.Text (unpack) +import Data.Time.Calendar (Day (..)) +import Data.Time.Clock (UTCTime (..)) import Imports hiding (head) import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gunzip as GZip @@ -49,6 +60,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 +82,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) + expiryCleanup <- Async.async $ (runAppT e cleanUpExpired) + runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener Async.cancel internalEventListener mapM_ Async.cancel sftDiscovery + Async.cancel expiryCleanup closeEnv e where endpoint = brig o @@ -103,3 +119,35 @@ lookupRequestIdMiddleware :: (RequestId -> Wai.Application) -> Wai.Application lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont + +forTrackedExpirations :: Day -> (NonEmpty PendingActivationExpiration -> AppIO ()) -> AppIO () +forTrackedExpirations day f = do + exps <- searchTrackedExpirations day Nothing + go exps + where + go (e : es) = do + let exps = e :| es + f exps + go =<< searchTrackedExpirations day (Just (maximum exps)) + go [] = pure () + +cleanUpExpired :: AppIO () +cleanUpExpired = do + -- err $ msg ("############## Started clean up thread" :: Text) + safeForever "cleanUpExpired" $ do + today <- utctDay <$> (liftIO =<< view currentTime) + forTrackedExpirations today $ \exps -> do + for_ exps $ \(PendingActivationExpiration uid _ tid) -> do + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + -- TODO: check is pending invitation + when invExpired $ do + API.deleteUserNoVerify uid + removeTrackedExpirations today (maximum exps) + liftIO $ threadDelay 1_000_000 + +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") + threadDelay 60_000_000 -- pause to keep worst-case noise in logs manageable From ade94562ddd6cf9cb8b05b76ba97788accbd80cc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 30 Nov 2020 19:02:57 +0100 Subject: [PATCH 02/47] go back multiple days --- services/brig/src/Brig/Run.hs | 61 +++++++++++++++++++---------------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 841a8998947..3b7e9898f91 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -33,10 +33,12 @@ import qualified Brig.AWS.SesNotification as SesNotification import Brig.App import qualified Brig.Calling as Calling import Brig.Data.PendingActivation (PendingActivationExpiration (..), removeTrackedExpirations, searchTrackedExpirations) +import Brig.Data.User (lookupStatus) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue import qualified Brig.Team.DB as Data +import Brig.Types.Intra (AccountStatus (..)) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) @@ -49,7 +51,7 @@ import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) import Data.String.Conversions (cs) import Data.Text (unpack) -import Data.Time.Calendar (Day (..)) +import Data.Time.Calendar (Day (..), addDays) import Data.Time.Clock (UTCTime (..)) import Imports hiding (head) import qualified Network.Wai as Wai @@ -82,7 +84,7 @@ 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) - expiryCleanup <- Async.async $ (runAppT e cleanUpExpired) + expiryCleanup <- Async.async (runAppT e cleanUpExpired) runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener @@ -120,34 +122,39 @@ lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont -forTrackedExpirations :: Day -> (NonEmpty PendingActivationExpiration -> AppIO ()) -> AppIO () -forTrackedExpirations day f = do - exps <- searchTrackedExpirations day Nothing - go exps - where - go (e : es) = do - let exps = e :| es - f exps - go =<< searchTrackedExpirations day (Just (maximum exps)) - go [] = pure () - cleanUpExpired :: AppIO () cleanUpExpired = do - -- err $ msg ("############## Started clean up thread" :: Text) + let nDays = 7 safeForever "cleanUpExpired" $ do today <- utctDay <$> (liftIO =<< view currentTime) - forTrackedExpirations today $ \exps -> do - for_ exps $ \(PendingActivationExpiration uid _ tid) -> do - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - -- TODO: check is pending invitation - when invExpired $ do - API.deleteUserNoVerify uid - removeTrackedExpirations today (maximum exps) + for_ [0 .. (nDays -1)] $ \i -> + cleanUpDay (addDays (- i) today) liftIO $ threadDelay 1_000_000 + where + cleanUpDay :: Day -> AppIO () + cleanUpDay day = + forTrackedExpirations day $ \exps -> do + for_ exps $ \(PendingActivationExpiration uid _ tid) -> do + isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when (isPendingInvitation && invExpired) $ + API.deleteUserNoVerify uid + removeTrackedExpirations day (maximum exps) + + forTrackedExpirations :: Day -> (NonEmpty PendingActivationExpiration -> AppIO ()) -> AppIO () + forTrackedExpirations day f = do + exps <- searchTrackedExpirations day Nothing + go exps + where + go (e : es) = do + let exps = e :| es + f exps + go =<< searchTrackedExpirations day (Just (maximum exps)) + go [] = pure () -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") - threadDelay 60_000_000 -- pause to keep worst-case noise in logs manageable + 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") + threadDelay 60_000_000 -- pause to keep worst-case noise in logs manageable From 49b5010b77e640d29be4cc9d89355fa4ddeb09b1 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 1 Dec 2020 14:17:52 +0100 Subject: [PATCH 03/47] query by day, delete by day and user --- .../src/V62_users_pending_activation.hs | 4 +- .../brig/src/Brig/Data/PendingActivation.hs | 28 ++++----- services/brig/src/Brig/Run.hs | 57 +++++++++++++------ 3 files changed, 51 insertions(+), 38 deletions(-) diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index 506dd80edf8..a3ee27d204d 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -32,7 +32,7 @@ migration = , expires_at timestamp , user uuid , team uuid - , primary key (expires_at_day, expires_at, user) + , primary key (expires_at_day, user) ) - with clustering order by (expires_at ASC, user ASC) + with clustering order by (user ASC) |] diff --git a/services/brig/src/Brig/Data/PendingActivation.hs b/services/brig/src/Brig/Data/PendingActivation.hs index c29077064d9..945767d6687 100644 --- a/services/brig/src/Brig/Data/PendingActivation.hs +++ b/services/brig/src/Brig/Data/PendingActivation.hs @@ -18,7 +18,7 @@ module Brig.Data.PendingActivation ( trackExpiration, searchTrackedExpirations, - removeTrackedExpirations, + removeTrackedExpiration, PendingActivationExpiration (..), ) where @@ -52,28 +52,20 @@ trackExpiration (PendingActivationExpiration uid expiresAt tid) = do insertExpiration :: PrepQuery W (ModJulianDay, UTCTime, UserId, TeamId) () insertExpiration = "INSERT INTO users_pending_activation (expires_at_day, expires_at, user, team) VALUES (?, ?, ?, ?)" -searchTrackedExpirations :: Day -> Maybe PendingActivationExpiration -> AppIO [PendingActivationExpiration] -searchTrackedExpirations dayExpired mbAfter = do +searchTrackedExpirations :: MonadClient f => Day -> f (Page PendingActivationExpiration) +searchTrackedExpirations dayExpired = do uncurry3 PendingActivationExpiration - <$$> case mbAfter of - Nothing -> retry x1 (query selectExpired (params Quorum (Identity (ModJulianDay dayExpired)))) - Just (PendingActivationExpiration uid t _) -> - retry x1 (query selectExpiredAfter (params Quorum (ModJulianDay dayExpired, t, uid))) + <$$> retry x1 (paginate selectExpired (params Quorum (Identity (ModJulianDay dayExpired)))) where selectExpired :: PrepQuery R (Identity ModJulianDay) (UserId, UTCTime, TeamId) selectExpired = "SELECT user, expires_at, team FROM users_pending_activation \ - \WHERE expires_at_day = ? LIMIT 100" + \WHERE expires_at_day = ?" - selectExpiredAfter :: PrepQuery R (ModJulianDay, UTCTime, UserId) (UserId, UTCTime, TeamId) - selectExpiredAfter = - "SELECT user, expires_at, team FROM users_pending_activation \ - \WHERE expires_at_day = ? and expires_at > ? and user > ? LIMIT 100" - -removeTrackedExpirations :: Day -> PendingActivationExpiration -> AppIO () -removeTrackedExpirations day (PendingActivationExpiration uid t _) = - retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, t, uid) +removeTrackedExpiration :: Day -> UserId -> AppIO () +removeTrackedExpiration day uid = + retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, uid) where - deleteExpired :: PrepQuery W (ModJulianDay, UTCTime, UserId) () + deleteExpired :: PrepQuery W (ModJulianDay, UserId) () deleteExpired = - "DELETE FROM users_pending_activation WHERE expires_at_day = ? and expires_at <= ? and user <= ?" + "DELETE FROM users_pending_activation WHERE expires_at_day = ? and user = ?" diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 3b7e9898f91..8d8b9b74070 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -32,17 +32,19 @@ 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.PendingActivation (PendingActivationExpiration (..), removeTrackedExpirations, searchTrackedExpirations) +import Brig.Data.PendingActivation (PendingActivationExpiration (..), removeTrackedExpiration, searchTrackedExpirations) import Brig.Data.User (lookupStatus) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue import qualified Brig.Team.DB as Data import Brig.Types.Intra (AccountStatus (..)) +import Cassandra.Exec (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) +import Control.Monad.Random (Random (randomRIO)) import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Id (RequestId (..)) @@ -124,37 +126,56 @@ lookupRequestIdMiddleware mkapp req cont = do cleanUpExpired :: AppIO () cleanUpExpired = do - let nDays = 7 safeForever "cleanUpExpired" $ do + err $ msg ("!!!Checking..." :: Text) today <- utctDay <$> (liftIO =<< view currentTime) - for_ [0 .. (nDays -1)] $ \i -> + for_ [0 .. 9] $ \i -> cleanUpDay (addDays (- i) today) - liftIO $ threadDelay 1_000_000 + + -- let delay = secondsToNominalDiffTime 3 + -- threadDelayNominalDiffTime =<< randomDiffTime (realToFrac (0.5 :: Double) * delay, delay) + let d :: Int = 2 + randomSecs <- liftIO $ round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d) + threadDelay (randomSecs * 1_000_000) where + -- liftIO $ threadDelay 1_000_000 + cleanUpDay :: Day -> AppIO () cleanUpDay day = forTrackedExpirations day $ \exps -> do - for_ exps $ \(PendingActivationExpiration uid _ tid) -> do - isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when (isPendingInvitation && invExpired) $ - API.deleteUserNoVerify uid - removeTrackedExpirations day (maximum exps) + let d t = err $ msg (t :: Text) + for_ exps $ \(PendingActivationExpiration uid expiresAt tid) -> do + d "found a candidate" + isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) + when (not isExpired) $ + d "not yet" + when isExpired $ do + d "it is expired" + isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when (isPendingInvitation && invExpired) $ do + d ("delete it!" :: Text) + API.deleteUserNoVerify uid + d "removing it" + removeTrackedExpiration day uid forTrackedExpirations :: Day -> (NonEmpty PendingActivationExpiration -> AppIO ()) -> AppIO () forTrackedExpirations day f = do - exps <- searchTrackedExpirations day Nothing - go exps + page <- searchTrackedExpirations day + go page where - go (e : es) = do - let exps = e :| es - f exps - go =<< searchTrackedExpirations day (Just (maximum exps)) - go [] = pure () + go :: Page PendingActivationExpiration -> AppIO () + go (Page hasMore result nextPage) = do + case result of + (e : es) -> f (e :| es) + [] -> pure () + when hasMore $ + go =<< liftClient nextPage 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") - threadDelay 60_000_000 -- pause to keep worst-case noise in logs manageable + -- pause to keep worst-case noise in logs manageable + threadDelay 60_000_000 From 7ad2f4e8d1219644f97c917e5372c1a738c20ea4 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 1 Dec 2020 14:50:09 +0100 Subject: [PATCH 04/47] Batch deletion into 1 query per day, remove debugging, 24h delay --- .../brig/src/Brig/Data/PendingActivation.hs | 10 ++-- services/brig/src/Brig/Run.hs | 57 ++++++++----------- 2 files changed, 30 insertions(+), 37 deletions(-) diff --git a/services/brig/src/Brig/Data/PendingActivation.hs b/services/brig/src/Brig/Data/PendingActivation.hs index 945767d6687..50ef694f295 100644 --- a/services/brig/src/Brig/Data/PendingActivation.hs +++ b/services/brig/src/Brig/Data/PendingActivation.hs @@ -62,10 +62,10 @@ searchTrackedExpirations dayExpired = do "SELECT user, expires_at, team FROM users_pending_activation \ \WHERE expires_at_day = ?" -removeTrackedExpiration :: Day -> UserId -> AppIO () -removeTrackedExpiration day uid = - retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, uid) +removeTrackedExpiration :: Day -> [UserId] -> AppIO () +removeTrackedExpiration day uids = + retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, uids) where - deleteExpired :: PrepQuery W (ModJulianDay, UserId) () + deleteExpired :: PrepQuery W (ModJulianDay, [UserId]) () deleteExpired = - "DELETE FROM users_pending_activation WHERE expires_at_day = ? and user = ?" + "DELETE FROM users_pending_activation WHERE expires_at_day = ? and user in ?" diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 8d8b9b74070..8e2d0f35f36 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -44,11 +44,12 @@ import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) +-- import Control.Monad.Random (Random (randomRIO)) + import Control.Monad.Random (Random (randomRIO)) import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Id (RequestId (..)) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) import Data.String.Conversions (cs) @@ -86,7 +87,7 @@ 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) - expiryCleanup <- Async.async (runAppT e cleanUpExpired) + expiryCleanup <- Async.async (runAppT e cleanExpiredPendingInvitations) runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener @@ -124,51 +125,43 @@ lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont -cleanUpExpired :: AppIO () -cleanUpExpired = do - safeForever "cleanUpExpired" $ do - err $ msg ("!!!Checking..." :: Text) +cleanExpiredPendingInvitations :: AppIO () +cleanExpiredPendingInvitations = do + safeForever "cleanExpiredPendingInvitations" $ do today <- utctDay <$> (liftIO =<< view currentTime) for_ [0 .. 9] $ \i -> cleanUpDay (addDays (- i) today) - - -- let delay = secondsToNominalDiffTime 3 - -- threadDelayNominalDiffTime =<< randomDiffTime (realToFrac (0.5 :: Double) * delay, delay) - let d :: Int = 2 - randomSecs <- liftIO $ round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d) + let d :: Int = 24 * 60 * 60 + randomSecs <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) threadDelay (randomSecs * 1_000_000) where - -- liftIO $ threadDelay 1_000_000 - cleanUpDay :: Day -> AppIO () cleanUpDay day = forTrackedExpirations day $ \exps -> do - let d t = err $ msg (t :: Text) - for_ exps $ \(PendingActivationExpiration uid expiresAt tid) -> do - d "found a candidate" - isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) - when (not isExpired) $ - d "not yet" - when isExpired $ do - d "it is expired" - isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when (isPendingInvitation && invExpired) $ do - d ("delete it!" :: Text) - API.deleteUserNoVerify uid - d "removing it" - removeTrackedExpiration day uid + expiredEntries <- + catMaybes + <$> ( for exps $ \(PendingActivationExpiration uid expiresAt tid) -> do + isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) + if isExpired + then do + isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when (isPendingInvitation && invExpired) $ do + API.deleteUserNoVerify uid + pure (Just uid) + else pure Nothing + ) + unless (null expiredEntries) $ + removeTrackedExpiration day expiredEntries - forTrackedExpirations :: Day -> (NonEmpty PendingActivationExpiration -> AppIO ()) -> AppIO () + forTrackedExpirations :: Day -> ([PendingActivationExpiration] -> AppIO ()) -> AppIO () forTrackedExpirations day f = do page <- searchTrackedExpirations day go page where go :: Page PendingActivationExpiration -> AppIO () go (Page hasMore result nextPage) = do - case result of - (e : es) -> f (e :| es) - [] -> pure () + f result when hasMore $ go =<< liftClient nextPage From 99fbcb0ed3ec84f891ef92696abb3ddbe75089f2 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 1 Dec 2020 15:16:19 +0100 Subject: [PATCH 05/47] Move delete of entries outside of the pagination of them --- services/brig/src/Brig/Run.hs | 50 +++++++++++++++++------------------ 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 8e2d0f35f36..a4e30b5b5f6 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -49,7 +49,7 @@ import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (Random (randomRIO)) import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Id (RequestId (..)) +import Data.Id (RequestId (..), UserId) import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) import Data.String.Conversions (cs) @@ -136,34 +136,34 @@ cleanExpiredPendingInvitations = do threadDelay (randomSecs * 1_000_000) where cleanUpDay :: Day -> AppIO () - cleanUpDay day = - forTrackedExpirations day $ \exps -> do - expiredEntries <- - catMaybes - <$> ( for exps $ \(PendingActivationExpiration uid expiresAt tid) -> do - isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) - if isExpired - then do - isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when (isPendingInvitation && invExpired) $ do - API.deleteUserNoVerify uid - pure (Just uid) - else pure Nothing - ) - unless (null expiredEntries) $ - removeTrackedExpiration day expiredEntries + cleanUpDay day = do + expiredEntries <- forTrackedExpirations day $ \exps -> + catMaybes + <$> ( for exps $ \(PendingActivationExpiration uid expiresAt tid) -> do + isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) + if isExpired + then do + isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when (isPendingInvitation && invExpired) $ do + API.deleteUserNoVerify uid + pure (Just uid) + else pure Nothing + ) + unless (null expiredEntries) $ + removeTrackedExpiration day expiredEntries - forTrackedExpirations :: Day -> ([PendingActivationExpiration] -> AppIO ()) -> AppIO () + forTrackedExpirations :: Day -> ([PendingActivationExpiration] -> AppIO [UserId]) -> AppIO [UserId] forTrackedExpirations day f = do page <- searchTrackedExpirations day - go page + go [] page where - go :: Page PendingActivationExpiration -> AppIO () - go (Page hasMore result nextPage) = do - f result - when hasMore $ - go =<< liftClient nextPage + go :: [UserId] -> Page PendingActivationExpiration -> AppIO [UserId] + go users (Page hasMore result nextPage) = do + users' <- (<> users) <$> f result + if hasMore + then go users' =<< liftClient nextPage + else pure users' safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () safeForever funName action = From 076bb751ff7451ae9847932de028e70e36297296 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 1 Dec 2020 18:22:26 +0100 Subject: [PATCH 06/47] Clean only past dates, no longer need to compare timestamps --- .../brig/src/Brig/Data/PendingActivation.hs | 5 ---- services/brig/src/Brig/Run.hs | 23 ++++++------------- 2 files changed, 7 insertions(+), 21 deletions(-) diff --git a/services/brig/src/Brig/Data/PendingActivation.hs b/services/brig/src/Brig/Data/PendingActivation.hs index 50ef694f295..dc469a89770 100644 --- a/services/brig/src/Brig/Data/PendingActivation.hs +++ b/services/brig/src/Brig/Data/PendingActivation.hs @@ -39,11 +39,6 @@ data PendingActivationExpiration !TeamId deriving stock (Eq) --- | Same as clustering order -instance Ord PendingActivationExpiration where - (PendingActivationExpiration uid t _) <= (PendingActivationExpiration uid2 t2 _) = - (t, uid) <= (t2, uid2) - -- | Note: Call this function only after an invitation for the user has been created trackExpiration :: PendingActivationExpiration -> AppIO () trackExpiration (PendingActivationExpiration uid expiresAt tid) = do diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index a4e30b5b5f6..178535fc2f1 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -33,12 +33,10 @@ import qualified Brig.AWS.SesNotification as SesNotification import Brig.App import qualified Brig.Calling as Calling import Brig.Data.PendingActivation (PendingActivationExpiration (..), removeTrackedExpiration, searchTrackedExpirations) -import Brig.Data.User (lookupStatus) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue import qualified Brig.Team.DB as Data -import Brig.Types.Intra (AccountStatus (..)) import Cassandra.Exec (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -129,27 +127,20 @@ cleanExpiredPendingInvitations :: AppIO () cleanExpiredPendingInvitations = do safeForever "cleanExpiredPendingInvitations" $ do today <- utctDay <$> (liftIO =<< view currentTime) - for_ [0 .. 9] $ \i -> + for_ [1 .. 9] $ \i -> cleanUpDay (addDays (- i) today) let d :: Int = 24 * 60 * 60 randomSecs <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) threadDelay (randomSecs * 1_000_000) where - cleanUpDay :: Day -> AppIO () + cleanUpDay :: Day -> AppIO () -- Call this function only with dates from the past cleanUpDay day = do expiredEntries <- forTrackedExpirations day $ \exps -> - catMaybes - <$> ( for exps $ \(PendingActivationExpiration uid expiresAt tid) -> do - isExpired <- (expiresAt <=) <$> (liftIO =<< view currentTime) - if isExpired - then do - isPendingInvitation <- (Just PendingInvitation ==) <$> lookupStatus uid - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when (isPendingInvitation && invExpired) $ do - API.deleteUserNoVerify uid - pure (Just uid) - else pure Nothing - ) + for exps $ \(PendingActivationExpiration uid _ tid) -> do + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when invExpired $ + API.deleteUserNoVerify uid + pure uid unless (null expiredEntries) $ removeTrackedExpiration day expiredEntries From b4f0358e9631646c9e161c5df9c2ec87b9371314 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 1 Dec 2020 18:31:15 +0100 Subject: [PATCH 07/47] Remove check for PendingInvitation --- services/brig/src/Brig/Run.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 178535fc2f1..20ddd7be582 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -36,7 +36,6 @@ import Brig.Data.PendingActivation (PendingActivationExpiration (..), removeTrac import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue -import qualified Brig.Team.DB as Data import Cassandra.Exec (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) @@ -45,7 +44,6 @@ import Control.Monad.Catch (MonadCatch, finally) -- import Control.Monad.Random (Random (randomRIO)) import Control.Monad.Random (Random (randomRIO)) -import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Id (RequestId (..), UserId) import qualified Data.Metrics.Middleware.Prometheus as Metrics @@ -136,10 +134,8 @@ cleanExpiredPendingInvitations = do cleanUpDay :: Day -> AppIO () -- Call this function only with dates from the past cleanUpDay day = do expiredEntries <- forTrackedExpirations day $ \exps -> - for exps $ \(PendingActivationExpiration uid _ tid) -> do - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when invExpired $ - API.deleteUserNoVerify uid + for exps $ \(PendingActivationExpiration uid _ _) -> do + API.deleteUserNoVerify uid pure uid unless (null expiredEntries) $ removeTrackedExpiration day expiredEntries From a76974dcb6a2ef131ac095622e4975791f851df2 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 2 Dec 2020 19:50:31 +0100 Subject: [PATCH 08/47] ... --- services/brig/brig.cabal | 3 +- .../src/V62_users_pending_activation.hs | 7 ++- services/brig/src/Brig/API/User.hs | 10 ++-- ...Activation.hs => UserPendingActivation.hs} | 44 ++++++++-------- services/brig/src/Brig/Run.hs | 50 ++++++++++--------- 5 files changed, 61 insertions(+), 53 deletions(-) rename services/brig/src/Brig/Data/{PendingActivation.hs => UserPendingActivation.hs} (58%) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index b564e26d535..ed3580538b9 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -48,11 +48,11 @@ library Brig.Data.Instances Brig.Data.LoginCode Brig.Data.PasswordReset - Brig.Data.PendingActivation Brig.Data.Properties Brig.Data.Types Brig.Data.User Brig.Data.UserKey + Brig.Data.UserPendingActivation Brig.Email Brig.Index.Eval Brig.Index.Migrations @@ -314,6 +314,7 @@ executable brig-integration , cassandra-util , containers , cookie + , cql-io , data-timeout , exceptions , extra diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index a3ee27d204d..74a8fa2321f 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -24,12 +24,15 @@ import Text.RawString.QQ migration :: Migration migration = Migration 62 "Add users_pending_activation" $ + -- | Column expires_at_day is the date of column expires_at + -- We use int for the encoding instead of date, + -- because the cql-io lib doesn't seem to implement date literals + -- TODO(stefan) try 'date' schema' [r| CREATE TABLE users_pending_activation ( - expires_at_day int - , expires_at timestamp + expires_at_day date , user uuid , team uuid , primary key (expires_at_day, user) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ff2d4263796..52070885624 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -97,13 +97,13 @@ import qualified Brig.Data.Blacklist as Blacklist import qualified Brig.Data.Client as Data import qualified Brig.Data.Connection as Data import qualified Brig.Data.PasswordReset as Data -import Brig.Data.PendingActivation (PendingActivationExpiration (..)) -import qualified Brig.Data.PendingActivation as Data import qualified Brig.Data.Properties as Data 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 (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) @@ -136,7 +136,7 @@ import Data.List1 (List1) import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) import Data.Qualified -import Data.Time.Clock (addUTCTime, diffUTCTime) +import Data.Time.Clock (addUTCTime, diffUTCTime, utctDay) import Data.UUID.V4 (nextRandom) import qualified Galley.Types.Teams as Team import qualified Galley.Types.Teams.Intra as Team @@ -368,8 +368,8 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca ttl <- setTeamInvitationTimeout <$> view settings now <- liftIO =<< view currentTime - let expiresAt = addUTCTime (realToFrac ttl) now - lift $ Data.trackExpiration (PendingActivationExpiration uid expiresAt tid) + let expiresAtDay = utctDay . addUTCTime (realToFrac ttl) $ now + lift $ Data.trackExpiration (UserPendingActivation expiresAtDay uid tid) return account diff --git a/services/brig/src/Brig/Data/PendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs similarity index 58% rename from services/brig/src/Brig/Data/PendingActivation.hs rename to services/brig/src/Brig/Data/UserPendingActivation.hs index dc469a89770..7d889f468d2 100644 --- a/services/brig/src/Brig/Data/PendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH @@ -15,11 +17,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Data.PendingActivation +module Brig.Data.UserPendingActivation ( trackExpiration, searchTrackedExpirations, - removeTrackedExpiration, - PendingActivationExpiration (..), + removeTrackedExpirations, + UserPendingActivation (..), ) where @@ -27,38 +29,36 @@ import Brig.App (AppIO) import Cassandra import Data.Id (TeamId, UserId) import Data.Misc (ModJulianDay (..)) -import Data.Time (UTCTime (utctDay)) import Data.Time.Calendar (Day) -import Data.Tuple.Extra (uncurry3) import Imports -data PendingActivationExpiration - = PendingActivationExpiration +data UserPendingActivation + = UserPendingActivation + !Day !UserId - !UTCTime !TeamId deriving stock (Eq) -- | Note: Call this function only after an invitation for the user has been created -trackExpiration :: PendingActivationExpiration -> AppIO () -trackExpiration (PendingActivationExpiration uid expiresAt tid) = do - retry x5 . write insertExpiration . params Quorum $ (ModJulianDay (utctDay expiresAt), expiresAt, uid, tid) +trackExpiration :: UserPendingActivation -> AppIO () +trackExpiration (UserPendingActivation expiresAtDay uid tid) = do + retry x5 . write insertExpiration . params Quorum $ (ModJulianDay expiresAtDay, uid, tid) where - insertExpiration :: PrepQuery W (ModJulianDay, UTCTime, UserId, TeamId) () - insertExpiration = "INSERT INTO users_pending_activation (expires_at_day, expires_at, user, team) VALUES (?, ?, ?, ?)" + insertExpiration :: PrepQuery W (ModJulianDay, UserId, TeamId) () + insertExpiration = "INSERT INTO users_pending_activation (expires_at_day, user, team) VALUES (?, ?, ?)" -searchTrackedExpirations :: MonadClient f => Day -> f (Page PendingActivationExpiration) -searchTrackedExpirations dayExpired = do - uncurry3 PendingActivationExpiration - <$$> retry x1 (paginate selectExpired (params Quorum (Identity (ModJulianDay dayExpired)))) +searchTrackedExpirations :: MonadClient f => Day -> Int -> f [UserPendingActivation] +searchTrackedExpirations dayExpired pageSize = do + (\(ModJulianDay d, uid, tid) -> UserPendingActivation d uid tid) + <$$> retry x1 (query selectExpired (params Quorum (ModJulianDay dayExpired, fromIntegral pageSize))) where - selectExpired :: PrepQuery R (Identity ModJulianDay) (UserId, UTCTime, TeamId) + selectExpired :: PrepQuery R (ModJulianDay, Int32) (ModJulianDay, UserId, TeamId) selectExpired = - "SELECT user, expires_at, team FROM users_pending_activation \ - \WHERE expires_at_day = ?" + "SELECT expires_at, user, team FROM users_pending_activation \ + \WHERE expires_at_day = ? LIMIT ?" -removeTrackedExpiration :: Day -> [UserId] -> AppIO () -removeTrackedExpiration day uids = +removeTrackedExpirations :: Day -> [UserId] -> AppIO () +removeTrackedExpirations day uids = retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, uids) where deleteExpired :: PrepQuery W (ModJulianDay, [UserId]) () diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 20ddd7be582..706fb99e3bd 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -32,20 +32,19 @@ 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.PendingActivation (PendingActivationExpiration (..), removeTrackedExpiration, searchTrackedExpirations) +import Brig.Data.UserPendingActivation (UserPendingActivation (..), removeTrackedExpirations, searchTrackedExpirations) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue -import Cassandra.Exec (Page (Page), liftClient) +import Brig.Team.DB as Data import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) --- import Control.Monad.Random (Random (randomRIO)) - import Control.Monad.Random (Random (randomRIO)) +import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Id (RequestId (..), UserId) +import Data.Id (RequestId (..)) import qualified Data.Metrics.Middleware.Prometheus as Metrics import Data.Proxy (Proxy (Proxy)) import Data.String.Conversions (cs) @@ -128,29 +127,34 @@ cleanExpiredPendingInvitations = do for_ [1 .. 9] $ \i -> cleanUpDay (addDays (- i) today) let d :: Int = 24 * 60 * 60 - randomSecs <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) - threadDelay (randomSecs * 1_000_000) + _randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) + threadDelay (10 * 1_000_000) where + throttleDelay :: MonadIO m => Double -> m () + throttleDelay itemsPerSecond = + let secs = 1.0 / itemsPerSecond + in liftIO $ threadDelay (round (1_000_000 * secs)) + cleanUpDay :: Day -> AppIO () -- Call this function only with dates from the past - cleanUpDay day = do - expiredEntries <- forTrackedExpirations day $ \exps -> - for exps $ \(PendingActivationExpiration uid _ _) -> do - API.deleteUserNoVerify uid + cleanUpDay day = + forExpirationsBatched day 1000 $ \exps -> do + userIds <- for exps $ \(UserPendingActivation _ uid tid) -> do + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + when invExpired $ + API.deleteUserNoVerify uid + throttleDelay 2.0 pure uid - unless (null expiredEntries) $ - removeTrackedExpiration day expiredEntries + removeTrackedExpirations day userIds - forTrackedExpirations :: Day -> ([PendingActivationExpiration] -> AppIO [UserId]) -> AppIO [UserId] - forTrackedExpirations day f = do - page <- searchTrackedExpirations day - go [] page + forExpirationsBatched :: Day -> Int -> ([UserPendingActivation] -> AppIO ()) -> AppIO () + forExpirationsBatched day pageSize f = do + go =<< searchTrackedExpirations day pageSize where - go :: [UserId] -> Page PendingActivationExpiration -> AppIO [UserId] - go users (Page hasMore result nextPage) = do - users' <- (<> users) <$> f result - if hasMore - then go users' =<< liftClient nextPage - else pure users' + go :: [UserPendingActivation] -> AppIO () + go [] = pure () + go entries = do + f entries + go =<< searchTrackedExpirations day pageSize safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () safeForever funName action = From 59593df084648d51709551739101370a788d2623 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 2 Dec 2020 19:52:02 +0100 Subject: [PATCH 09/47] use int in schema --- services/brig/schema/src/V62_users_pending_activation.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index 74a8fa2321f..a6f0c5abc78 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -27,12 +27,11 @@ migration = -- | Column expires_at_day is the date of column expires_at -- We use int for the encoding instead of date, -- because the cql-io lib doesn't seem to implement date literals - -- TODO(stefan) try 'date' schema' [r| CREATE TABLE users_pending_activation ( - expires_at_day date + expires_at_day int , user uuid , team uuid , primary key (expires_at_day, user) From 6eea058f422b9694e8e3b535b0ca24888ff0c410 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 2 Dec 2020 20:04:47 +0100 Subject: [PATCH 10/47] ... --- services/brig/brig.cabal | 1 - services/brig/schema/src/V62_users_pending_activation.hs | 9 ++++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index ed3580538b9..1c89447bfb1 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -314,7 +314,6 @@ executable brig-integration , cassandra-util , containers , cookie - , cql-io , data-timeout , exceptions , extra diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index a6f0c5abc78..d1fd9ff9d8c 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -24,9 +24,12 @@ import Text.RawString.QQ migration :: Migration migration = Migration 62 "Add users_pending_activation" $ - -- | Column expires_at_day is the date of column expires_at - -- We use int for the encoding instead of date, - -- because the cql-io lib doesn't seem to implement date literals + -- | 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. + + -- The column expires_at_day is the date of expiry. + -- It is encoded as 'int' because cql-io doesn't seem to work with 'date' types. schema' [r| CREATE TABLE users_pending_activation From d6b98fe4e5499ad7c65698329b546601e75a58cf Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 2 Dec 2020 20:08:11 +0100 Subject: [PATCH 11/47] update schema version --- services/brig/src/Brig/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index c808312cba3..bd0874322f0 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -130,7 +130,7 @@ import Util.Options import Wire.API.User.Identity (Email) schemaVersion :: Int32 -schemaVersion = 61 +schemaVersion = 62 ------------------------------------------------------------------------------- -- Environment From d9d1c106e13154a603c8e5688ef160c6476297c1 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 10:29:29 +0100 Subject: [PATCH 12/47] rename expirCleanup->scimInvitationCleanup --- services/brig/src/Brig/Run.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 706fb99e3bd..d203ccc5475 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -82,13 +82,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) - expiryCleanup <- Async.async (runAppT e cleanExpiredPendingInvitations) + scimInvitationCleanup <- Async.async (runAppT e cleanExpiredPendingInvitations) runSettingsWithShutdown s app 5 `finally` do mapM_ Async.cancel emailListener Async.cancel internalEventListener mapM_ Async.cancel sftDiscovery - Async.cancel expiryCleanup + Async.cancel scimInvitationCleanup closeEnv e where endpoint = brig o From 7ac7167322bb71b8fa1a65398e0667132d905abc Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 11:23:28 +0100 Subject: [PATCH 13/47] Add delteUsersNoVerify with metric; Remove delay --- services/brig/src/Brig/API/User.hs | 9 +++++++ .../src/Brig/Data/UserPendingActivation.hs | 10 +++---- services/brig/src/Brig/Run.hs | 26 ++++++++----------- 3 files changed, 25 insertions(+), 20 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 52070885624..f45935323d0 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, @@ -134,6 +135,7 @@ 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 (addUTCTime, diffUTCTime, utctDay) @@ -1014,6 +1016,13 @@ deleteUserNoVerify uid = do queue <- view internalEvents Queue.enqueue queue (Internal.DeleteUser uid) +deleteUsersNoVerify :: [UserId] -> AppIO () +deleteUsersNoVerify uids = do + Log.info $ msg (val "Deleting users") + for_ uids deleteUserNoVerify + m <- view metrics + Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.multideleted") 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/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 7d889f468d2..6c1bc63b5cb 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -32,11 +32,11 @@ import Data.Misc (ModJulianDay (..)) import Data.Time.Calendar (Day) import Imports -data UserPendingActivation - = UserPendingActivation - !Day - !UserId - !TeamId +data UserPendingActivation = UserPendingActivation + { upaDay :: !Day, + upaUserId :: !UserId, + upaTeamId :: !TeamId + } deriving stock (Eq) -- | Note: Call this function only after an invitation for the user has been created diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index d203ccc5475..d89b6a9b8ae 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -127,24 +127,20 @@ cleanExpiredPendingInvitations = do for_ [1 .. 9] $ \i -> cleanUpDay (addDays (- i) today) let d :: Int = 24 * 60 * 60 - _randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) - threadDelay (10 * 1_000_000) + randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) + threadDelay (randomSecs * 1_000_000) where - throttleDelay :: MonadIO m => Double -> m () - throttleDelay itemsPerSecond = - let secs = 1.0 / itemsPerSecond - in liftIO $ threadDelay (round (1_000_000 * secs)) - cleanUpDay :: Day -> AppIO () -- Call this function only with dates from the past cleanUpDay day = - forExpirationsBatched day 1000 $ \exps -> do - userIds <- for exps $ \(UserPendingActivation _ uid tid) -> do - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - when invExpired $ - API.deleteUserNoVerify uid - throttleDelay 2.0 - pure uid - removeTrackedExpirations day userIds + forExpirationsBatched day 100 $ \exps -> do + expiredUsers <- + catMaybes + <$> ( for exps $ \(UserPendingActivation _ uid tid) -> do + invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) + pure $ if invExpired then Just uid else Nothing + ) + API.deleteUsersNoVerify expiredUsers + removeTrackedExpirations day (upaUserId <$> exps) forExpirationsBatched :: Day -> Int -> ([UserPendingActivation] -> AppIO ()) -> AppIO () forExpirationsBatched day pageSize f = do From bba0c4ad185c30cb5539396555a05ab884271159 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 13:41:37 +0100 Subject: [PATCH 14/47] ... --- .../src/V62_users_pending_activation.hs | 12 ++-- services/brig/src/Brig/API/User.hs | 9 +-- .../src/Brig/Data/UserPendingActivation.hs | 47 +++++++------- services/brig/src/Brig/Run.hs | 61 ++++++++++--------- 4 files changed, 66 insertions(+), 63 deletions(-) diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index d1fd9ff9d8c..c7648a817c6 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -27,17 +27,13 @@ migration = -- | 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. - - -- The column expires_at_day is the date of expiry. - -- It is encoded as 'int' because cql-io doesn't seem to work with 'date' types. schema' [r| CREATE TABLE users_pending_activation ( - expires_at_day int - , user uuid - , team uuid - , primary key (expires_at_day, user) + user uuid + , expires_at timestamp + , primary key (user) ) - with clustering order by (user ASC) + with clustering order by (expires_at ASC) |] diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index f45935323d0..33d74ce6676 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -103,7 +103,7 @@ 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 (UserPendingActivation (..)) +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 @@ -138,7 +138,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) import Data.Qualified -import Data.Time.Clock (addUTCTime, diffUTCTime, utctDay) +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 @@ -332,6 +332,7 @@ createUser new@NewUser {..} = do field "user" (toByteString uid) . field "team" (toByteString $ Team.iiTeam ii) . msg (val "Accepting invitation") + Data.removeTrackedExpiration uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam @@ -370,8 +371,8 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca ttl <- setTeamInvitationTimeout <$> view settings now <- liftIO =<< view currentTime - let expiresAtDay = utctDay . addUTCTime (realToFrac ttl) $ now - lift $ Data.trackExpiration (UserPendingActivation expiresAtDay uid tid) + let expiresAt = addUTCTime (realToFrac ttl) $ now + lift $ Data.trackExpiration (UserPendingActivation uid expiresAt) return account diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 6c1bc63b5cb..c4f5735eecf 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -19,7 +19,8 @@ module Brig.Data.UserPendingActivation ( trackExpiration, - searchTrackedExpirations, + getAllTrackedExpirations, + removeTrackedExpiration, removeTrackedExpirations, UserPendingActivation (..), ) @@ -27,40 +28,40 @@ where import Brig.App (AppIO) import Cassandra -import Data.Id (TeamId, UserId) -import Data.Misc (ModJulianDay (..)) -import Data.Time.Calendar (Day) +import Data.Id (UserId) +import Data.Time (UTCTime) import Imports data UserPendingActivation = UserPendingActivation - { upaDay :: !Day, - upaUserId :: !UserId, - upaTeamId :: !TeamId + { upaUserId :: !UserId, + upaDay :: !UTCTime } deriving stock (Eq) -- | Note: Call this function only after an invitation for the user has been created trackExpiration :: UserPendingActivation -> AppIO () -trackExpiration (UserPendingActivation expiresAtDay uid tid) = do - retry x5 . write insertExpiration . params Quorum $ (ModJulianDay expiresAtDay, uid, tid) +trackExpiration (UserPendingActivation uid expiresAt) = do + retry x5 . write insertExpiration . params Quorum $ (uid, expiresAt) where - insertExpiration :: PrepQuery W (ModJulianDay, UserId, TeamId) () - insertExpiration = "INSERT INTO users_pending_activation (expires_at_day, user, team) VALUES (?, ?, ?)" + insertExpiration :: PrepQuery W (UserId, UTCTime) () + insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" -searchTrackedExpirations :: MonadClient f => Day -> Int -> f [UserPendingActivation] -searchTrackedExpirations dayExpired pageSize = do - (\(ModJulianDay d, uid, tid) -> UserPendingActivation d uid tid) - <$$> retry x1 (query selectExpired (params Quorum (ModJulianDay dayExpired, fromIntegral pageSize))) +getAllTrackedExpirations :: MonadClient f => f (Page UserPendingActivation) +getAllTrackedExpirations = do + uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params Quorum ())) where - selectExpired :: PrepQuery R (ModJulianDay, Int32) (ModJulianDay, UserId, TeamId) + selectExpired :: PrepQuery R () (UserId, UTCTime) selectExpired = - "SELECT expires_at, user, team FROM users_pending_activation \ - \WHERE expires_at_day = ? LIMIT ?" + "SELECT expires_at_day, user, team FROM users_pending_activation \ + \WHERE expires_at_day = ?" -removeTrackedExpirations :: Day -> [UserId] -> AppIO () -removeTrackedExpirations day uids = - retry x5 . write deleteExpired . params Quorum $ (ModJulianDay day, uids) +removeTrackedExpiration :: UserId -> AppIO () +removeTrackedExpiration uid = removeTrackedExpirations [uid] + +removeTrackedExpirations :: [UserId] -> AppIO () +removeTrackedExpirations uids = + retry x5 . write deleteExpired . params Quorum $ (Identity uids) where - deleteExpired :: PrepQuery W (ModJulianDay, [UserId]) () + deleteExpired :: PrepQuery W (Identity [UserId]) () deleteExpired = - "DELETE FROM users_pending_activation WHERE expires_at_day = ? and user in ?" + "DELETE FROM users_pending_activation WHERE user IN ?" diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index d89b6a9b8ae..ba7eaf1e646 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -32,25 +32,23 @@ 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 (..), removeTrackedExpirations, searchTrackedExpirations) +import Brig.Data.UserPendingActivation (UserPendingActivation (..), getAllTrackedExpirations, removeTrackedExpirations) import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Queue as Queue -import Brig.Team.DB as Data +import Brig.Types.Intra (AccountStatus (PendingInvitation)) +import Cassandra (Page (Page), liftClient) import qualified Control.Concurrent.Async as Async import Control.Exception.Safe (catchAny) import Control.Lens (view, (.~), (^.)) import Control.Monad.Catch (MonadCatch, finally) import Control.Monad.Random (Random (randomRIO)) -import Data.Coerce (coerce) 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 Data.Time.Calendar (Day (..), addDays) -import Data.Time.Clock (UTCTime (..)) import Imports hiding (head) import qualified Network.Wai as Wai import qualified Network.Wai.Middleware.Gunzip as GZip @@ -123,34 +121,41 @@ lookupRequestIdMiddleware mkapp req cont = do cleanExpiredPendingInvitations :: AppIO () cleanExpiredPendingInvitations = do safeForever "cleanExpiredPendingInvitations" $ do - today <- utctDay <$> (liftIO =<< view currentTime) - for_ [1 .. 9] $ \i -> - cleanUpDay (addDays (- i) today) + now <- liftIO =<< view currentTime + + forExpirationsPaged $ \exps -> do + expiredUsers <- + catMaybes + <$> ( for exps $ \(UserPendingActivation uid expiresAt) -> do + isPendingInvitation <- (Just PendingInvitation ==) <$> API.lookupStatus uid + pure $ + if (expiresAt < now) && isPendingInvitation + then Just uid + else Nothing + ) + API.deleteUsersNoVerify expiredUsers + removeTrackedExpirations (upaUserId <$> exps) + + -- TODO(add to settings) let d :: Int = 24 * 60 * 60 randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) threadDelay (randomSecs * 1_000_000) where - cleanUpDay :: Day -> AppIO () -- Call this function only with dates from the past - cleanUpDay day = - forExpirationsBatched day 100 $ \exps -> do - expiredUsers <- - catMaybes - <$> ( for exps $ \(UserPendingActivation _ uid tid) -> do - invExpired <- isNothing <$> Data.lookupInvitation tid (coerce uid) - pure $ if invExpired then Just uid else Nothing - ) - API.deleteUsersNoVerify expiredUsers - removeTrackedExpirations day (upaUserId <$> exps) - - forExpirationsBatched :: Day -> Int -> ([UserPendingActivation] -> AppIO ()) -> AppIO () - forExpirationsBatched day pageSize f = do - go =<< searchTrackedExpirations day pageSize + forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () + forExpirationsPaged f = do + go =<< getAllTrackedExpirations where - go :: [UserPendingActivation] -> AppIO () - go [] = pure () - go entries = do - f entries - go =<< searchTrackedExpirations day pageSize + go :: (Page UserPendingActivation) -> AppIO () + go (Page hasMore result nextPage) = do + f result + when hasMore $ + go =<< liftClient nextPage + + -- go :: [UserPendingActivation] -> AppIO () + -- go [] = pure () + -- go entries = do + -- f entries + -- go =<< searchTrackedExpirations day pageSize safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () safeForever funName action = From f5ff416197a33101751da76bd7e81c84fe2a3bcb Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 13:48:08 +0100 Subject: [PATCH 15/47] Fix broken docstring --- services/brig/schema/src/V62_users_pending_activation.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index c7648a817c6..6ede3b9ac61 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -24,9 +24,9 @@ import Text.RawString.QQ migration :: Migration migration = Migration 62 "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. + -- 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 From 0f11d80e10e4ae04a72f6c392ba35b75f9c6cd60 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 16:07:33 +0100 Subject: [PATCH 16/47] Add expires_at to primary key to allow clustering order --- services/brig/schema/src/V62_users_pending_activation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/schema/src/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index 6ede3b9ac61..bc80a95df29 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -33,7 +33,7 @@ migration = ( user uuid , expires_at timestamp - , primary key (user) + , primary key (user, expires_at) ) with clustering order by (expires_at ASC) |] From b21d5ea9853ab22bff6552f0e328120148f48757 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 3 Dec 2020 18:13:42 +0100 Subject: [PATCH 17/47] ... --- services/brig/brig.cabal | 3 +- .../src/Brig/Data/UserPendingActivation.hs | 3 +- .../integration/API/UserPendingActivation.hs | 114 ++++++++++++++++++ services/brig/test/integration/Main.hs | 5 +- 4 files changed, 121 insertions(+), 4 deletions(-) create mode 100644 services/brig/test/integration/API/UserPendingActivation.hs diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 1c89447bfb1..0c0b9cca7b0 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: 9f982304b3e4de02c3a782a8053c4d3d2e0ab19d3e6bd497684f37ceaaf7215a +-- hash: 2a946b006de5d7699402b61eb57cad8d94535feba655e40f6375a2c0c7749b70 name: brig version: 1.35.0 @@ -289,6 +289,7 @@ executable brig-integration API.User.Property API.User.RichInfo API.User.Util + API.UserPendingActivation Index.Create Util Util.AWS diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index c4f5735eecf..f90b9236030 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -52,8 +52,7 @@ getAllTrackedExpirations = do where selectExpired :: PrepQuery R () (UserId, UTCTime) selectExpired = - "SELECT expires_at_day, user, team FROM users_pending_activation \ - \WHERE expires_at_day = ?" + "SELECT expires_at, user FROM users_pending_activation" removeTrackedExpiration :: UserId -> AppIO () removeTrackedExpiration uid = removeTrackedExpirations [uid] diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs new file mode 100644 index 00000000000..d1901c8c896 --- /dev/null +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -0,0 +1,114 @@ +module API.UserPendingActivation where + +-- import Brig.Types +-- import Brig.Types.Intra +-- import Brig.Types.Team.Invitation +-- import Brig.Types.User.Auth + +-- import API.Team.Util +-- import Bilge hiding (accept, timeout) +-- import Bilge.Assert +-- import Brig.Options (Opts) +-- import qualified Brig.Options as Opt +-- import Brig.Types (Email (..), User (..), userEmail) +-- import Control.Arrow ((&&&)) +-- import Control.Lens +-- import Data.Aeson +-- import Data.Aeson.Lens +-- import qualified Data.ByteString.Char8 as C8 +-- import Data.ByteString.Conversion +-- import Data.Id +-- import qualified Data.Set as Set +-- import qualified Galley.Types.Teams as Team + +-- import Test.Tasty hiding (Timeout) +-- import Test.Tasty.HUnit + +import API.Team.Util (getTeams) +import Bilge (MonadHttp, post, responseJsonUnsafe) +import Bilge.Request +import Brig.Types +import qualified Brig.Types as Brig +import Cassandra +import Control.Lens ((^.)) +import Data.Aeson +import qualified Data.Aeson as Aeson +import Data.Id (TeamId, UserId) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID +import Galley.Types.Teams (newTeam) +import qualified Galley.Types.Teams as Galley +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import Util + +tests :: ClientState -> Brig -> Galley -> IO TestTree +tests db brig galley = do + return $ + testGroup + "cleanExpiredPendingInvitations" + [testCase "works" (testCleanExpiredPendingInvitations db brig galley)] + +testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> IO () +testCleanExpiredPendingInvitations _db brig galley = do + (uid, tid) <- createUserWithTeamDisableSSO brig galley + pure () + +-- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) + +createUserWithTeamDisableSSO :: (HasCallStack, MonadCatch m, MonadHttp m, MonadIO m, MonadFail m) => 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 + return (uid, tid) + +-- 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) + +-- createUserWithTeam :: (HasCallStack, MonadHttp m, MonadIO m, MonadFail m) => BrigReq -> GalleyReq -> m (UserId, TeamId) +-- createUserWithTeam brg gly = do +-- (uid, tid) <- createUserWithTeamDisableSSO brg gly +-- putSSOEnabledInternal gly tid TeamFeatureEnabled +-- pure (uid, tid) + +-- email <- randomEmail + +-- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} +-- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) + +-- pure () + +-- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} +-- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) + +-- 1. get scim token and call spar +-- 2. create + +-- 1. call +-- post "/i/teams/:tid/invitations" (continue createInvitationViaScimH) $ +-- accept "application" "json" +-- .&. jsonRequest @NewUserScimInvitation + +-- 2. get check db for users +-- 3. wait for time out +-- 4. check db for user diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index b9815a1db48..142039df876 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 @@ -100,6 +101,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 db b g withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" @@ -115,7 +117,8 @@ runTests iConf bConf otherArgs = do turnApi, metricsApi, settingsApi, - createIndex + createIndex, + userPendingActivation ] where mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p From b16d4b02e395ca3113b5a7a032bf12160f30b2ee Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 4 Dec 2020 11:49:42 +0100 Subject: [PATCH 18/47] make randomScimUser compile in brig-integration --- services/brig/brig.cabal | 8 +- services/brig/package.yaml | 6 + .../integration/API/UserPendingActivation.hs | 175 +++++++++++------- services/brig/test/integration/Main.hs | 2 +- 4 files changed, 119 insertions(+), 72 deletions(-) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 0c0b9cca7b0..d8e20bf6837 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: 2a946b006de5d7699402b61eb57cad8d94535feba655e40f6375a2c0c7749b70 +-- hash: 4f8ad3720f55015133207eff6aca1d7ac75f5543707178bce8634d670cb68124 name: brig version: 1.35.0 @@ -300,6 +300,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 @@ -316,11 +318,13 @@ executable brig-integration , containers , cookie , data-timeout + , email-validate , exceptions , extra , filepath >=1.4 , galley-types , gundeck-types + , hscim , http-client , http-client-tls >=0.2 , http-types @@ -337,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 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 7c4ada276e4..66a02fe58f4 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -198,12 +198,14 @@ executables: - containers - cookie - data-timeout + - email-validate - extra - exceptions - filepath >=1.4 - galley-types - gundeck-types - HsOpenSSL + - hscim - http-client - http-client-tls >=0.2 - http-types @@ -212,15 +214,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/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index d1901c8c896..ffedd8dcb38 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -1,62 +1,65 @@ -module API.UserPendingActivation where - --- import Brig.Types --- import Brig.Types.Intra --- import Brig.Types.Team.Invitation --- import Brig.Types.User.Auth - --- import API.Team.Util --- import Bilge hiding (accept, timeout) --- import Bilge.Assert --- import Brig.Options (Opts) --- import qualified Brig.Options as Opt --- import Brig.Types (Email (..), User (..), userEmail) --- import Control.Arrow ((&&&)) --- import Control.Lens --- import Data.Aeson --- import Data.Aeson.Lens --- import qualified Data.ByteString.Char8 as C8 --- import Data.ByteString.Conversion --- import Data.Id --- import qualified Data.Set as Set --- import qualified Galley.Types.Teams as Team +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} --- import Test.Tasty hiding (Timeout) --- import Test.Tasty.HUnit +module API.UserPendingActivation where import API.Team.Util (getTeams) -import Bilge (MonadHttp, post, responseJsonUnsafe) +import Bilge (Http, MonadHttp, post, responseJsonUnsafe) +import Bilge.IO (Manager) import Bilge.Request import Brig.Types import qualified Brig.Types as Brig import Cassandra +import qualified Control.Exception import Control.Lens ((^.)) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Random +import Control.Monad.Random.Class (MonadRandom) import Data.Aeson import qualified Data.Aeson as Aeson import Data.Id (TeamId, UserId) +import Data.Range (unsafeRange) +import Data.String.Conversions (cs) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID -import Galley.Types.Teams (newTeam) import qualified Galley.Types.Teams as Galley import Imports +import qualified SAML2.WebSSO as SAML +import Spar.Scim (ScimUserExtra, SparTag, userSchemas) +import Spar.Scim.Types (ScimUserExtra (ScimUserExtra)) +import Test.QuickCheck import Test.Tasty -import Test.Tasty.HUnit +import qualified Text.Email.Parser as Email import Util +import qualified Web.Scim.Schema.User as Scim.User +import qualified Web.Scim.Schema.User.Email as Email +import qualified Web.Scim.Schema.User.Phone as Phone +import Wire.API.User.RichInfo (RichInfo (RichInfo)) + +-- import SAML2.WebSSO.Types -tests :: ClientState -> Brig -> Galley -> IO TestTree -tests db brig galley = do +-- import qualified Web.Scim.Schema.User as Scim.User + +tests :: Manager -> ClientState -> Brig -> Galley -> IO TestTree +tests m db brig galley = do return $ testGroup "cleanExpiredPendingInvitations" - [testCase "works" (testCleanExpiredPendingInvitations db brig galley)] + [test m "works" (testCleanExpiredPendingInvitations db brig galley)] -testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> IO () +testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> Http () testCleanExpiredPendingInvitations _db brig galley = do - (uid, tid) <- createUserWithTeamDisableSSO brig galley + _email <- randomEmail + -- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} + (_uid, _tid) <- createUserWithTeamDisableSSO brig galley pure () -- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) +newTeam :: Galley.BindingNewTeam +newTeam = Galley.BindingNewTeam $ Galley.newNewTeam (unsafeRange "teamName") (unsafeRange "defaultIcon") + createUserWithTeamDisableSSO :: (HasCallStack, MonadCatch m, MonadHttp m, MonadIO m, MonadFail m) => Brig -> Galley -> m (UserId, TeamId) createUserWithTeamDisableSSO brg gly = do e <- randomEmail @@ -72,43 +75,75 @@ createUserWithTeamDisableSSO brg gly = do 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) --- 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) - --- createUserWithTeam :: (HasCallStack, MonadHttp m, MonadIO m, MonadFail m) => BrigReq -> GalleyReq -> m (UserId, TeamId) --- createUserWithTeam brg gly = do --- (uid, tid) <- createUserWithTeamDisableSSO brg gly --- putSSOEnabledInternal gly tid TeamFeatureEnabled --- pure (uid, tid) - --- email <- randomEmail - --- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} --- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - --- pure () - --- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} --- (owner, tid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley) - --- 1. get scim token and call spar --- 2. create - --- 1. call --- post "/i/teams/:tid/invitations" (continue createInvitationViaScimH) $ --- accept "application" "json" --- .&. jsonRequest @NewUserScimInvitation - --- 2. get check db for users --- 3. wait for time out --- 4. check db for user +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 + primary :: Maybe Bool = Nothing -- TODO: where should we catch users with more than one + -- primary email? + 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 {..} diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 142039df876..b597ff220e6 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -101,7 +101,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 db b g + userPendingActivation <- UserPendingActivation.tests mg db b g withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" From 533c82793c796fba88dc3fdd5b39f8391453fed2 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 4 Dec 2020 14:33:53 +0100 Subject: [PATCH 19/47] make createUser' (part of it) compile --- services/brig/brig.cabal | 3 +- services/brig/brig.integration.yaml | 4 + services/brig/package.yaml | 2 + .../integration/API/UserPendingActivation.hs | 130 ++++++++++++++++-- services/brig/test/integration/Main.hs | 4 +- services/brig/test/integration/Util.hs | 2 + 6 files changed, 130 insertions(+), 15 deletions(-) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index d8e20bf6837..526560ce16f 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: 4f8ad3720f55015133207eff6aca1d7ac75f5543707178bce8634d670cb68124 +-- hash: 36a3557728c446d2768baa6d557c8663c553bf087d9fb937afc052fdc8ea3d78 name: brig version: 1.35.0 @@ -325,6 +325,7 @@ executable brig-integration , galley-types , gundeck-types , hscim + , http-api-data , http-client , http-client-tls >=0.2 , http-types diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index 438dea8989e..cc6151e5774 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -24,6 +24,10 @@ gundeck: host: 127.0.0.1 port: 8086 +spar: + host: 127.0.0.1 + port: 8088 + # federator: # host: 127.0.0.1 # port: 8097 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 66a02fe58f4..25e694b03cf 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -183,6 +183,7 @@ executables: source-dirs: test/integration dependencies: - aeson + - lens-aeson - async - attoparsec - bilge @@ -206,6 +207,7 @@ executables: - gundeck-types - HsOpenSSL - hscim + - http-api-data - http-client - http-client-tls >=0.2 - http-types diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index ffedd8dcb38..00464899385 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -1,26 +1,38 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} module API.UserPendingActivation where import API.Team.Util (getTeams) -import Bilge (Http, MonadHttp, post, responseJsonUnsafe) +-- import Web.HttpApiData (toHeader) + +import Bilge (Http, MonadHttp, Response (responseBody), post, responseJsonUnsafe) +import Bilge.Assert ((!!!), ( ClientState -> Brig -> Galley -> IO TestTree -tests m db brig galley = do +tests :: Manager -> ClientState -> Brig -> Galley -> Spar -> IO TestTree +tests m db brig galley spar = do return $ testGroup "cleanExpiredPendingInvitations" - [test m "works" (testCleanExpiredPendingInvitations db brig galley)] + [test m "works" (testCleanExpiredPendingInvitations db brig galley spar)] -testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> Http () -testCleanExpiredPendingInvitations _db brig galley = do - _email <- randomEmail - -- scimUser <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} +testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> Spar -> Http () +testCleanExpiredPendingInvitations _db brig galley spar = do + email <- randomEmail (_uid, _tid) <- createUserWithTeamDisableSSO brig galley + _scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) + (scimStoredUser1, _inv, inviteeCode) <- createUser'step spar brig tok tid scimUser email pure () + where + createUser'step spar brig tok tid scimUser email = do + -- scimStoredUser <- aFewTimesRecover (createUser tok scimUser) + scimStoredUser <- (createUser spar tok scimUser) + inv <- getInvitationByEmail brig email + Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + pure (scimStoredUser, inv, inviteeCode) + +getInvitationByEmail :: Brig -> Email -> Http Invitation +getInvitationByEmail brig email = + responseJsonUnsafe + <$> ( Bilge.get (brig . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) + 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) +scimAuth (Just _auth) = undefined -- TODO + +-- | 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" + +-- -- | Get ID of a user returned from SCIM. +-- scimUserId :: Scim.StoredUser SparTag -> UserId +-- scimUserId = Scim.id . Scim.thing + +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) diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index b597ff220e6..02d987f4a01 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -63,6 +63,7 @@ data Config = Config cargohold :: Endpoint, galley :: Endpoint, nginz :: Endpoint, + spar :: Endpoint, -- external provider provider :: Provider.Config } @@ -82,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" @@ -101,7 +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 mg db b g + userPendingActivation <- UserPendingActivation.tests mg db b g s withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" 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" From ade3d6c39a1379e56399ec2c4d50228c07dab455 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 4 Dec 2020 15:06:08 +0100 Subject: [PATCH 20/47] make createToken compile --- .../integration/API/UserPendingActivation.hs | 73 ++++++++++++++----- 1 file changed, 56 insertions(+), 17 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 00464899385..c806474242c 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -1,9 +1,10 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-unused-local-binds #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} + +-- {-# OPTIONS_GHC -Wno-name-shadowing #-} +-- {-# OPTIONS_GHC -Wno-unused-imports #-} +-- {-# OPTIONS_GHC -Wno-unused-local-binds #-} +-- {-# OPTIONS_GHC -Wno-unused-matches #-} module API.UserPendingActivation where @@ -11,7 +12,7 @@ import API.Team.Util (getTeams) -- import Web.HttpApiData (toHeader) import Bilge (Http, MonadHttp, Response (responseBody), post, responseJsonUnsafe) -import Bilge.Assert ((!!!), ( Brig -> Galley -> Spar -> Http () testCleanExpiredPendingInvitations _db brig galley spar = do email <- randomEmail - (_uid, _tid) <- createUserWithTeamDisableSSO brig galley - _scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) + (owner, tid) <- createUserWithTeamDisableSSO brig galley + CreateScimTokenResponse tok _ <- + createToken spar owner $ + CreateScimToken + { createScimTokenDescr = "testCreateToken", + createScimTokenPassword = Just defPassword + } + scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) (scimStoredUser1, _inv, inviteeCode) <- createUser'step spar brig tok tid scimUser email - pure () + print scimStoredUser1 + print inviteeCode where - createUser'step spar brig tok tid scimUser email = do + createUser'step spar' brig' tok tid scimUser email = do -- scimStoredUser <- aFewTimesRecover (createUser tok scimUser) - scimStoredUser <- (createUser spar tok scimUser) - inv <- getInvitationByEmail brig email + scimStoredUser <- (createUser spar' tok scimUser) + inv <- getInvitationByEmail brig' email Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) pure (scimStoredUser, inv, inviteeCode) @@ -85,8 +92,6 @@ getInvitationByEmail brig email = (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 + Date: Fri, 4 Dec 2020 15:14:30 +0100 Subject: [PATCH 21/47] Fix: get invitions is not public --- services/brig/test/integration/API/UserPendingActivation.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index c806474242c..ffb78e5fa15 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -46,6 +46,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) import Test.Tasty import qualified Text.Email.Parser as Email import Util hiding (createUser) +import Web.HttpApiData (toHeader) import qualified Web.Scim.Class.User as Scim import qualified Web.Scim.Schema.User as Scim.User import qualified Web.Scim.Schema.User.Email as Email @@ -88,7 +89,7 @@ testCleanExpiredPendingInvitations _db brig galley spar = do getInvitationByEmail :: Brig -> Email -> Http Invitation getInvitationByEmail brig email = responseJsonUnsafe - <$> ( Bilge.get (brig . path "/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) + <$> ( Bilge.get (brig . path "/i/teams/invitations/by-email" . contentJson . queryItem "email" (toByteString' email)) Request -> Request scimAuth Nothing = id --- scimAuth (Just auth) = header "Authorization" (toHeader auth) -scimAuth (Just _auth) = undefined -- TODO +scimAuth (Just auth) = header "Authorization" (toHeader auth) -- | Signal that the body is an SCIM payload. contentScim :: Request -> Request From cc7c0baa2cea90084dd8f6d04306fc50c01c370e Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 4 Dec 2020 15:56:11 +0100 Subject: [PATCH 22/47] Add user check --- .../integration/API/UserPendingActivation.hs | 50 +++++++++++-------- 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index ffb78e5fa15..300cfe18f8e 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -11,14 +11,11 @@ module API.UserPendingActivation where import API.Team.Util (getTeams) -- import Web.HttpApiData (toHeader) -import Bilge (Http, MonadHttp, Response (responseBody), post, responseJsonUnsafe) +import Bilge hiding (query) import Bilge.Assert (( ClientState -> Brig -> Galley -> Spar -> IO TestTree tests m db brig galley spar = do return $ @@ -65,8 +61,7 @@ tests m db brig galley spar = do [test m "works" (testCleanExpiredPendingInvitations db brig galley spar)] testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> Spar -> Http () -testCleanExpiredPendingInvitations _db brig galley spar = do - email <- randomEmail +testCleanExpiredPendingInvitations db brig galley spar = do (owner, tid) <- createUserWithTeamDisableSSO brig galley CreateScimTokenResponse tok _ <- createToken spar owner $ @@ -74,18 +69,37 @@ testCleanExpiredPendingInvitations _db brig galley spar = do { createScimTokenDescr = "testCreateToken", createScimTokenPassword = Just defPassword } - scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) - (scimStoredUser1, _inv, inviteeCode) <- createUser'step spar brig tok tid scimUser email - print scimStoredUser1 - print inviteeCode + + uid <- do + email <- randomEmail + scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) + (scimStoredUser, _inv, _inviteeCode) <- createUser'step spar brig tok tid scimUser email + pure $ (Scim.id . Scim.thing) scimStoredUser + + assertUserExist "user should exist" db uid True where createUser'step spar' brig' tok tid scimUser email = do - -- scimStoredUser <- aFewTimesRecover (createUser tok scimUser) scimStoredUser <- (createUser spar' tok scimUser) inv <- getInvitationByEmail brig' email Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) pure (scimStoredUser, inv, inviteeCode) + assertUserExist msg db' uid shouldExist = do + exists <- runClient db' (userExists uid) + liftIO $ assertEqual msg exists shouldExist + +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 @@ -236,10 +250,6 @@ contentScim = content "application/scim+json" acceptScim :: Request -> Request acceptScim = accept "application/scim+json" --- -- | Get ID of a user returned from SCIM. --- scimUserId :: Scim.StoredUser SparTag -> UserId --- scimUserId = Scim.id . Scim.thing - getInvitationCode :: (MonadIO m, MonadHttp m, HasCallStack) => Brig -> From 0a0570547eac24ba925bd0da43e04b1b5dfff284 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 4 Dec 2020 17:07:15 +0100 Subject: [PATCH 23/47] Add debug --- deploy/services-demo/conf/brig.demo.yaml | 7 +++++ services/brig/brig.integration.yaml | 4 --- .../src/Brig/Data/UserPendingActivation.hs | 4 +-- services/brig/src/Brig/Run.hs | 14 ++++----- .../integration/API/UserPendingActivation.hs | 29 +++++++++++++------ services/brig/test/integration/Main.hs | 2 +- 6 files changed, 37 insertions(+), 23 deletions(-) diff --git a/deploy/services-demo/conf/brig.demo.yaml b/deploy/services-demo/conf/brig.demo.yaml index 7eb7996395a..7b5b85adcc5 100644 --- a/deploy/services-demo/conf/brig.demo.yaml +++ b/deploy/services-demo/conf/brig.demo.yaml @@ -113,6 +113,13 @@ optSettings: setMaxTeamSize: 128 setMaxConvSize: 128 setEmailVisibility: visible_to_self + # Federation domain is used to qualify local IDs and handles, + # e.g. 0c4d8944-70fa-480e-a8b7-9d929862d18c@wire.com and somehandle@wire.com. + # It should also match the SRV DNS records under which other wire-server installations can find this backend: + # _wire-server._tcp. + # Once set, DO NOT change it: if you do, existing users may have a broken experience and/or stop working + # Remember to keep it the same in Galley. + setFederationDomain: example.com logLevel: Debug logNetStrings: false diff --git a/services/brig/brig.integration.yaml b/services/brig/brig.integration.yaml index cc6151e5774..438dea8989e 100644 --- a/services/brig/brig.integration.yaml +++ b/services/brig/brig.integration.yaml @@ -24,10 +24,6 @@ gundeck: host: 127.0.0.1 port: 8086 -spar: - host: 127.0.0.1 - port: 8088 - # federator: # host: 127.0.0.1 # port: 8097 diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index f90b9236030..a48fb828fa0 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -36,7 +36,7 @@ data UserPendingActivation = UserPendingActivation { upaUserId :: !UserId, upaDay :: !UTCTime } - deriving stock (Eq) + deriving stock (Eq, Show, Ord) -- | Note: Call this function only after an invitation for the user has been created trackExpiration :: UserPendingActivation -> AppIO () @@ -52,7 +52,7 @@ getAllTrackedExpirations = do where selectExpired :: PrepQuery R () (UserId, UTCTime) selectExpired = - "SELECT expires_at, user FROM users_pending_activation" + "SELECT user, expires_at FROM users_pending_activation" removeTrackedExpiration :: UserId -> AppIO () removeTrackedExpiration uid = removeTrackedExpirations [uid] diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index ba7eaf1e646..03069637570 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -60,6 +60,7 @@ import Servant ((:<|>) (..)) import qualified Servant import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) +import qualified System.Logger.Class as Log import Util.Options -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -120,8 +121,11 @@ lookupRequestIdMiddleware mkapp req cont = do cleanExpiredPendingInvitations :: AppIO () cleanExpiredPendingInvitations = do + Log.info $ Log.msg $ Log.val "clean loop start" + safeForever "cleanExpiredPendingInvitations" $ do now <- liftIO =<< view currentTime + Log.info $ Log.msg $ Log.val "clean loop iteration" forExpirationsPaged $ \exps -> do expiredUsers <- @@ -135,9 +139,11 @@ cleanExpiredPendingInvitations = do ) API.deleteUsersNoVerify expiredUsers removeTrackedExpirations (upaUserId <$> exps) + Log.info $ Log.msg $ Log.val (cs . show $ (expiredUsers, exps)) -- TODO(add to settings) - let d :: Int = 24 * 60 * 60 + -- let d :: Int = 24 * 60 * 60 + let d :: Int = 1 randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) threadDelay (randomSecs * 1_000_000) where @@ -151,12 +157,6 @@ cleanExpiredPendingInvitations = do when hasMore $ go =<< liftClient nextPage - -- go :: [UserPendingActivation] -> AppIO () - -- go [] = pure () - -- go entries = do - -- f entries - -- go =<< searchTrackedExpirations day pageSize - safeForever :: (MonadIO m, MonadLogger m, MonadCatch m) => String -> m () -> m () safeForever funName action = forever $ diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 300cfe18f8e..f95cc5ef2f0 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -9,10 +11,9 @@ module API.UserPendingActivation where import API.Team.Util (getTeams) --- import Web.HttpApiData (toHeader) - import Bilge hiding (query) import Bilge.Assert (( ClientState -> Brig -> Galley -> Spar -> IO TestTree -tests m db brig galley spar = do +tests :: Opts -> Manager -> ClientState -> Brig -> Galley -> Spar -> IO TestTree +tests opts m db brig galley spar = do return $ testGroup "cleanExpiredPendingInvitations" - [test m "works" (testCleanExpiredPendingInvitations db brig galley spar)] + [test m "works" (testCleanExpiredPendingInvitations opts db brig galley spar)] -testCleanExpiredPendingInvitations :: ClientState -> Brig -> Galley -> Spar -> Http () -testCleanExpiredPendingInvitations db brig galley spar = do +testCleanExpiredPendingInvitations :: Opts -> ClientState -> Brig -> Galley -> Spar -> Http () +testCleanExpiredPendingInvitations opts db brig galley spar = do (owner, tid) <- createUserWithTeamDisableSSO brig galley CreateScimTokenResponse tok _ <- createToken spar owner $ @@ -77,16 +78,26 @@ testCleanExpiredPendingInvitations db brig galley spar = do pure $ (Scim.id . Scim.thing) scimStoredUser assertUserExist "user should exist" db uid True + waitUserExpiration opts where + -- assertUserExist "user should be deleted" db uid False + createUser'step 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 = do exists <- runClient db' (userExists uid) - liftIO $ assertEqual msg exists shouldExist + liftIO $ 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 diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 02d987f4a01..4a20ce64468 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -103,7 +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 mg db b g s + userPendingActivation <- UserPendingActivation.tests brigOpts mg db b g s withArgs otherArgs . defaultMain $ testGroup "Brig API Integration" From 574a09f5478133fdd5a67bdf4fe4104a2b78223e Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 09:46:46 +0100 Subject: [PATCH 24/47] Fix bug: user is removed from expiry tracking too soon --- services/brig/src/Brig/Run.hs | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 03069637570..c943f665493 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -128,18 +128,29 @@ cleanExpiredPendingInvitations = do Log.info $ Log.msg $ Log.val "clean loop iteration" forExpirationsPaged $ \exps -> do - expiredUsers <- - catMaybes - <$> ( for exps $ \(UserPendingActivation uid expiresAt) -> do - isPendingInvitation <- (Just PendingInvitation ==) <$> API.lookupStatus uid - pure $ - if (expiresAt < now) && isPendingInvitation - then Just uid - else Nothing + uids <- + ( for exps $ \(UserPendingActivation uid expiresAt) -> do + isPendingInvitation <- (Just PendingInvitation ==) <$> API.lookupStatus uid + pure $ + ( expiresAt < now, + isPendingInvitation, + uid ) - API.deleteUsersNoVerify expiredUsers - removeTrackedExpirations (upaUserId <$> exps) - Log.info $ Log.msg $ Log.val (cs . show $ (expiredUsers, exps)) + ) + + API.deleteUsersNoVerify + ( catMaybes + ( uids <&> \(isExpired, isPendingInvitation, uid) -> + if isExpired && isPendingInvitation then Just uid else Nothing + ) + ) + + removeTrackedExpirations + ( catMaybes + ( uids <&> \(isExpired, _isPendingInvitation, uid) -> + if isExpired then Just uid else Nothing + ) + ) -- TODO(add to settings) -- let d :: Int = 24 * 60 * 60 From 7a84c0a7ebccb0be74f14844f8dd8a0a49ab56bd Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 10:06:22 +0100 Subject: [PATCH 25/47] Add test: Users that register in time dont get cleaned --- .../integration/API/UserPendingActivation.hs | 89 +++++++++++++------ 1 file changed, 64 insertions(+), 25 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index f95cc5ef2f0..477020d1fa7 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -14,7 +14,7 @@ import API.Team.Util (getTeams) import Bilge hiding (query) import Bilge.Assert (( ClientState -> Brig -> Galley -> Spar -> Http () testCleanExpiredPendingInvitations opts db brig galley spar = do (owner, tid) <- createUserWithTeamDisableSSO brig galley - CreateScimTokenResponse tok _ <- - createToken spar owner $ - CreateScimToken - { createScimTokenDescr = "testCreateToken", - createScimTokenPassword = Just defPassword - } - + tok <- createScimToken spar owner uid <- do email <- randomEmail scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) (scimStoredUser, _inv, _inviteeCode) <- createUser'step 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) <- createUser'step 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 - where - -- assertUserExist "user should be deleted" db uid False + assertUserExist "user should still exist" db uid True - createUser'step 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) +createScimToken :: Spar -> UserId -> HttpT IO ScimToken +createScimToken spar' owner = do + CreateScimTokenResponse tok _ <- + createToken spar' owner $ + CreateScimToken + { createScimTokenDescr = "testCreateToken", + createScimTokenPassword = Just defPassword + } + pure tok - assertUserExist :: HasCallStack => String -> ClientState -> UserId -> Bool -> HttpT IO () - assertUserExist msg db' uid shouldExist = do - exists <- runClient db' (userExists uid) - liftIO $ assertEqual msg shouldExist exists +createUser'step :: Spar -> Brig -> ScimToken -> TeamId -> Scim.User.User SparTag -> Email -> HttpT IO (WithMeta (WithId UserId (Scim.User.User SparTag)), Invitation, InvitationCode) +createUser'step 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) - 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 +assertUserExist :: HasCallStack => String -> ClientState -> UserId -> Bool -> HttpT IO () +assertUserExist msg db' uid shouldExist = do + exists <- runClient db' (userExists uid) + liftIO $ 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 @@ -311,3 +331,22 @@ createToken spar zusr payload = do 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 + ] From b68b328a9639ad83f9969bf081387cf532747d9b Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 10:37:27 +0100 Subject: [PATCH 26/47] Add setExpiredUserCleanupTimeout --- services/brig/brig.integration.yaml | 1 + services/brig/src/Brig/API/User.hs | 1 - services/brig/src/Brig/Options.hs | 2 + services/brig/src/Brig/Run.hs | 57 +++++++++---------- .../integration/API/UserPendingActivation.hs | 5 -- 5 files changed, 31 insertions(+), 35 deletions(-) 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/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 33d74ce6676..841bc56f733 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1019,7 +1019,6 @@ deleteUserNoVerify uid = do deleteUsersNoVerify :: [UserId] -> AppIO () deleteUsersNoVerify uids = do - Log.info $ msg (val "Deleting users") for_ uids deleteUserNoVerify m <- view metrics Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.multideleted") m diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index d82ef720d28..41efeb63c7b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -397,6 +397,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 c943f665493..45a72f79caf 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -60,7 +60,6 @@ import Servant ((:<|>) (..)) import qualified Servant import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) -import qualified System.Logger.Class as Log import Util.Options -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -121,12 +120,8 @@ lookupRequestIdMiddleware mkapp req cont = do cleanExpiredPendingInvitations :: AppIO () cleanExpiredPendingInvitations = do - Log.info $ Log.msg $ Log.val "clean loop start" - safeForever "cleanExpiredPendingInvitations" $ do now <- liftIO =<< view currentTime - Log.info $ Log.msg $ Log.val "clean loop iteration" - forExpirationsPaged $ \exps -> do uids <- ( for exps $ \(UserPendingActivation uid expiresAt) -> do @@ -138,26 +133,28 @@ cleanExpiredPendingInvitations = do ) ) - API.deleteUsersNoVerify - ( catMaybes - ( uids <&> \(isExpired, isPendingInvitation, uid) -> - if isExpired && isPendingInvitation then Just uid else Nothing - ) - ) + API.deleteUsersNoVerify $ + catMaybes + ( uids <&> \(isExpired, isPendingInvitation, uid) -> + if isExpired && isPendingInvitation then Just uid else Nothing + ) - removeTrackedExpirations - ( catMaybes - ( uids <&> \(isExpired, _isPendingInvitation, uid) -> - if isExpired then Just uid else Nothing - ) - ) + removeTrackedExpirations $ + catMaybes + ( uids <&> \(isExpired, _isPendingInvitation, uid) -> + if isExpired then Just uid else Nothing + ) - -- TODO(add to settings) - -- let d :: Int = 24 * 60 * 60 - let d :: Int = 1 - randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * fromIntegral d, fromIntegral d)) - threadDelay (randomSecs * 1_000_000) + 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 =<< getAllTrackedExpirations @@ -168,10 +165,12 @@ cleanExpiredPendingInvitations = do when hasMore $ go =<< liftClient nextPage - 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 + 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 index 477020d1fa7..6e9323b2105 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -3,11 +3,6 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- {-# OPTIONS_GHC -Wno-name-shadowing #-} --- {-# OPTIONS_GHC -Wno-unused-imports #-} --- {-# OPTIONS_GHC -Wno-unused-local-binds #-} --- {-# OPTIONS_GHC -Wno-unused-matches #-} - module API.UserPendingActivation where import API.Team.Util (getTeams) From eb04525f7be2bbbeedf9ae9454f3c8310dc8ee8b Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 10:51:42 +0100 Subject: [PATCH 27/47] Revert brig.demo.yaml --- deploy/services-demo/conf/brig.demo.yaml | 7 ------- 1 file changed, 7 deletions(-) diff --git a/deploy/services-demo/conf/brig.demo.yaml b/deploy/services-demo/conf/brig.demo.yaml index 7b5b85adcc5..7eb7996395a 100644 --- a/deploy/services-demo/conf/brig.demo.yaml +++ b/deploy/services-demo/conf/brig.demo.yaml @@ -113,13 +113,6 @@ optSettings: setMaxTeamSize: 128 setMaxConvSize: 128 setEmailVisibility: visible_to_self - # Federation domain is used to qualify local IDs and handles, - # e.g. 0c4d8944-70fa-480e-a8b7-9d929862d18c@wire.com and somehandle@wire.com. - # It should also match the SRV DNS records under which other wire-server installations can find this backend: - # _wire-server._tcp. - # Once set, DO NOT change it: if you do, existing users may have a broken experience and/or stop working - # Remember to keep it the same in Galley. - setFederationDomain: example.com logLevel: Debug logNetStrings: false From add552d13f58462701fb95ffedea0d9f5f9fae19 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 10:52:00 +0100 Subject: [PATCH 28/47] Consistency --- services/brig/src/Brig/Data/UserPendingActivation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index a48fb828fa0..255112b3412 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -46,7 +46,7 @@ trackExpiration (UserPendingActivation uid expiresAt) = do insertExpiration :: PrepQuery W (UserId, UTCTime) () insertExpiration = "INSERT INTO users_pending_activation (user, expires_at) VALUES (?, ?)" -getAllTrackedExpirations :: MonadClient f => f (Page UserPendingActivation) +getAllTrackedExpirations :: AppIO (Page UserPendingActivation) getAllTrackedExpirations = do uncurry UserPendingActivation <$$> retry x1 (paginate selectExpired (params Quorum ())) where From 8e5312a15266c53672bbb7a7a25321bf234ebbcd Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Mon, 7 Dec 2020 11:03:09 +0100 Subject: [PATCH 29/47] add metric: calls to deleteUserNoVerify --- services/brig/src/Brig/API/User.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 841bc56f733..bab575b818e 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1021,7 +1021,8 @@ deleteUsersNoVerify :: [UserId] -> AppIO () deleteUsersNoVerify uids = do for_ uids deleteUserNoVerify m <- view metrics - Metrics.counterAdd (fromIntegral . length $ uids) (Metrics.path "user.multideleted") m + 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) From df7e28cbb62f2b11c015bafc9c9fa97609c7b7f2 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 15:28:50 +0100 Subject: [PATCH 30/47] Rename data fns with userPendingActivation prefix --- services/brig/src/Brig/API/User.hs | 4 ++-- .../src/Brig/Data/UserPendingActivation.hs | 24 +++++++++---------- services/brig/src/Brig/Run.hs | 6 ++--- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index bab575b818e..15afc8dc190 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -332,7 +332,7 @@ createUser new@NewUser {..} = do field "user" (toByteString uid) . field "team" (toByteString $ Team.iiTeam ii) . msg (val "Accepting invitation") - Data.removeTrackedExpiration uid + Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError AppIO CreateUserTeam @@ -372,7 +372,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca ttl <- setTeamInvitationTimeout <$> view settings now <- liftIO =<< view currentTime let expiresAt = addUTCTime (realToFrac ttl) $ now - lift $ Data.trackExpiration (UserPendingActivation uid expiresAt) + lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) return account diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index 255112b3412..d1170c0267b 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -18,10 +18,10 @@ -- with this program. If not, see . module Brig.Data.UserPendingActivation - ( trackExpiration, - getAllTrackedExpirations, - removeTrackedExpiration, - removeTrackedExpirations, + ( usersPendingActivationAdd, + usersPendingActivationList, + usersPendingActivationRemove, + usersPendingActivationRemoveMultiple, UserPendingActivation (..), ) where @@ -39,26 +39,26 @@ data UserPendingActivation = UserPendingActivation deriving stock (Eq, Show, Ord) -- | Note: Call this function only after an invitation for the user has been created -trackExpiration :: UserPendingActivation -> AppIO () -trackExpiration (UserPendingActivation uid expiresAt) = do +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 (?, ?)" -getAllTrackedExpirations :: AppIO (Page UserPendingActivation) -getAllTrackedExpirations = do +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" -removeTrackedExpiration :: UserId -> AppIO () -removeTrackedExpiration uid = removeTrackedExpirations [uid] +usersPendingActivationRemove :: UserId -> AppIO () +usersPendingActivationRemove uid = usersPendingActivationRemoveMultiple [uid] -removeTrackedExpirations :: [UserId] -> AppIO () -removeTrackedExpirations uids = +usersPendingActivationRemoveMultiple :: [UserId] -> AppIO () +usersPendingActivationRemoveMultiple uids = retry x5 . write deleteExpired . params Quorum $ (Identity uids) where deleteExpired :: PrepQuery W (Identity [UserId]) () diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 7417b943a69..8436fb4e705 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -32,7 +32,7 @@ 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 (..), getAllTrackedExpirations, removeTrackedExpirations) +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 @@ -147,7 +147,7 @@ cleanExpiredPendingInvitations = do if isExpired && isPendingInvitation then Just uid else Nothing ) - removeTrackedExpirations $ + usersPendingActivationRemoveMultiple $ catMaybes ( uids <&> \(isExpired, _isPendingInvitation, uid) -> if isExpired then Just uid else Nothing @@ -165,7 +165,7 @@ cleanExpiredPendingInvitations = do forExpirationsPaged :: ([UserPendingActivation] -> AppIO ()) -> AppIO () forExpirationsPaged f = do - go =<< getAllTrackedExpirations + go =<< usersPendingActivationList where go :: (Page UserPendingActivation) -> AppIO () go (Page hasMore result nextPage) = do From 6785c0af929350d33bbe8adccf2cec84c71e94e8 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 15:32:13 +0100 Subject: [PATCH 31/47] remove superfluous $ --- services/brig/src/Brig/API/User.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 15afc8dc190..82d62a208e7 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -371,7 +371,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca ttl <- setTeamInvitationTimeout <$> view settings now <- liftIO =<< view currentTime - let expiresAt = addUTCTime (realToFrac ttl) $ now + let expiresAt = addUTCTime (realToFrac ttl) now lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) return account From 644687aa97ed2fa3f49168b321df2c38e5a9f90c Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 15:47:56 +0100 Subject: [PATCH 32/47] Remove incorrect note --- services/brig/src/Brig/Data/UserPendingActivation.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/Data/UserPendingActivation.hs b/services/brig/src/Brig/Data/UserPendingActivation.hs index d1170c0267b..f56025ccd26 100644 --- a/services/brig/src/Brig/Data/UserPendingActivation.hs +++ b/services/brig/src/Brig/Data/UserPendingActivation.hs @@ -38,7 +38,6 @@ data UserPendingActivation = UserPendingActivation } deriving stock (Eq, Show, Ord) --- | Note: Call this function only after an invitation for the user has been created usersPendingActivationAdd :: UserPendingActivation -> AppIO () usersPendingActivationAdd (UserPendingActivation uid expiresAt) = do retry x5 . write insertExpiration . params Quorum $ (uid, expiresAt) From 1a3f61cc4bf7376dc2021c8eaaf9ec7e93f046d4 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 18:19:27 +0100 Subject: [PATCH 33/47] Consitent naming --- services/brig/src/Brig/Run.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 8436fb4e705..97860be15e5 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -80,13 +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) - scimInvitationCleanup <- Async.async (runAppT e cleanExpiredPendingInvitations) + 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 scimInvitationCleanup + Async.cancel pendingActivationCleanupAsync closeEnv e where endpoint = brig o @@ -126,9 +126,9 @@ lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont -cleanExpiredPendingInvitations :: AppIO () -cleanExpiredPendingInvitations = do - safeForever "cleanExpiredPendingInvitations" $ do +pendingActivationCleanup :: AppIO () +pendingActivationCleanup = do + safeForever "pendingActivationCleanup" $ do now <- liftIO =<< view currentTime forExpirationsPaged $ \exps -> do uids <- From a5c47bc7a03a879bc881ab2f3013f9c3e6ba5839 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 18:29:56 +0100 Subject: [PATCH 34/47] createUser'step -> createUserStep --- .../brig/test/integration/API/UserPendingActivation.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 6e9323b2105..a641d24ead3 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -67,7 +67,7 @@ testCleanExpiredPendingInvitations opts db brig galley spar = do uid <- do email <- randomEmail scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) - (scimStoredUser, _inv, _inviteeCode) <- createUser'step spar brig tok tid scimUser 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 @@ -79,7 +79,7 @@ testRegisteredUsersNotCleaned opts db brig galley spar = do tok <- createScimToken spar owner email <- randomEmail scimUser <- lift (randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email}) - (scimStoredUser, _inv, inviteeCode) <- createUser'step spar brig tok tid scimUser 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 @@ -96,8 +96,8 @@ createScimToken spar' owner = do } pure tok -createUser'step :: Spar -> Brig -> ScimToken -> TeamId -> Scim.User.User SparTag -> Email -> HttpT IO (WithMeta (WithId UserId (Scim.User.User SparTag)), Invitation, InvitationCode) -createUser'step spar' brig' tok tid scimUser email = do +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) From 0ca1fac982ec2fe00e0436c7cc6e3dc99aee5f2f Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 18:32:14 +0100 Subject: [PATCH 35/47] don't pollute scope --- services/brig/src/Brig/API/User.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 82d62a208e7..fa63a791be7 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -369,9 +369,10 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca True lift $ Data.insertAccount account Nothing Nothing activated - ttl <- setTeamInvitationTimeout <$> view settings - now <- liftIO =<< view currentTime - let expiresAt = addUTCTime (realToFrac ttl) now + expiresAt <- do + ttl <- setTeamInvitationTimeout <$> view settings + now <- liftIO =<< view currentTime + pure $ addUTCTime (realToFrac ttl) now lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) return account From 180a28712a4169520b6650312e7285584f9d21b7 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Tue, 15 Dec 2020 18:33:24 +0100 Subject: [PATCH 36/47] syntax --- services/brig/test/integration/API/UserPendingActivation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index a641d24ead3..26a88a96bc1 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -98,7 +98,7 @@ createScimToken spar' owner = do 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) + scimStoredUser <- createUser spar' tok scimUser inv <- getInvitationByEmail brig' email Just inviteeCode <- getInvitationCode brig' tid (inInvitation inv) pure (scimStoredUser, inv, inviteeCode) From a516416ae0d97d35c7ee79f27d412123423992df Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 16 Dec 2020 10:49:07 +0100 Subject: [PATCH 37/47] Update users_pending_activation primary key to (user) --- services/brig/schema/src/Main.hs | 3 +++ services/brig/schema/src/V62_users_pending_activation.hs | 3 +-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 0dc6813ef19..91596a1874f 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -134,6 +134,9 @@ main = do V60_AddFederationIdMapping.migration, V61_team_invitation_email.migration, V62_users_pending_activation.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/V62_users_pending_activation.hs b/services/brig/schema/src/V62_users_pending_activation.hs index bc80a95df29..cb0242a2c9d 100644 --- a/services/brig/schema/src/V62_users_pending_activation.hs +++ b/services/brig/schema/src/V62_users_pending_activation.hs @@ -33,7 +33,6 @@ migration = ( user uuid , expires_at timestamp - , primary key (user, expires_at) + , primary key (user) ) - with clustering order by (expires_at ASC) |] From 1d6a309dcd82e426d0f2eaea6f61ce9e9ba6d601 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Wed, 16 Dec 2020 17:40:05 +0100 Subject: [PATCH 38/47] Remove unused ModJulianDay --- libs/types-common/src/Data/Misc.hs | 20 ++------------------ 1 file changed, 2 insertions(+), 18 deletions(-) diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index f75a0537a4c..3a0b6106445 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -44,15 +44,12 @@ module Data.Misc mkHttpsUrl, ensureHttpsUrl, - -- * PlainTextPassword - PlainTextPassword (..), - -- * Fingerprint Fingerprint (..), Rsa, - -- * ModJulianDay - ModJulianDay (..), + -- * PlainTextPassword + PlainTextPassword (..), -- * Swagger modelLocation, @@ -74,7 +71,6 @@ import Data.Range import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time.Calendar (Day (..)) import Imports import Test.QuickCheck (Arbitrary (arbitrary)) import qualified Test.QuickCheck as QC @@ -326,15 +322,3 @@ instance FromJSON PlainTextPassword where instance Arbitrary PlainTextPassword where -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars arbitrary = PlainTextPassword . fromRange <$> genRangeText @6 @1024 arbitrary - --------------------------------------------------------------------------------- --- ModJulianDay - -newtype ModJulianDay = ModJulianDay {fromUTCDay :: Day} - deriving stock (Eq, Show) - -instance Cql ModJulianDay where - ctype = Tagged IntColumn - toCql (ModJulianDay (ModifiedJulianDay n)) = CqlInt (fromIntegral n) - fromCql (CqlInt n) = return . ModJulianDay . ModifiedJulianDay . fromIntegral $ n - fromCql _ = Left "ModJulianDay: expected CqlInt" From 2a64d2825a101c181907417b2df6374035ef7834 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 16 Dec 2020 22:48:12 +0100 Subject: [PATCH 39/47] Fix possible race condition. --- services/brig/src/Brig/API/User.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 2fcfea81682..7eb74a5bb03 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -361,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' @@ -369,12 +378,6 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca True lift $ Data.insertAccount account Nothing Nothing activated - expiresAt <- do - ttl <- setTeamInvitationTimeout <$> view settings - now <- liftIO =<< view currentTime - pure $ addUTCTime (realToFrac ttl) now - lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) - return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. From be2afab7a5b5891ce7f911e4b20d6e981999f103 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Thu, 17 Dec 2020 15:08:57 +0100 Subject: [PATCH 40/47] Hello CI From d4c20266e67fd7a0ad70654987be1d0d0e414632 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 18 Dec 2020 10:45:52 +0100 Subject: [PATCH 41/47] Add retries to assertUserExist --- .../integration/API/UserPendingActivation.hs | 26 ++++++++++++++++--- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 26a88a96bc1..0f1d0dfc362 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -14,10 +14,11 @@ import qualified Brig.Types as Brig import Brig.Types.Intra (AccountStatus (Deleted)) import Brig.Types.Team.Invitation (Invitation (inInvitation)) import Cassandra -import qualified Control.Exception +import Control.Exception (assert) import Control.Lens ((^.), (^?)) import Control.Monad.Catch (MonadCatch) import Control.Monad.Random +import Control.Retry (exponentialBackoff, limitRetries, retrying) import Data.Aeson hiding (json) import qualified Data.Aeson as Aeson import Data.Aeson.Lens (key, _String) @@ -104,9 +105,9 @@ createUserStep spar' brig' tok tid scimUser email = do pure (scimStoredUser, inv, inviteeCode) assertUserExist :: HasCallStack => String -> ClientState -> UserId -> Bool -> HttpT IO () -assertUserExist msg db' uid shouldExist = do - exists <- runClient db' (userExists uid) - liftIO $ assertEqual msg shouldExist exists +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 @@ -345,3 +346,20 @@ acceptWithName name email code = "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) From 1d015e20cf584f520b78c45b4e216904f7fe0090 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 18 Dec 2020 12:40:35 +0100 Subject: [PATCH 42/47] add debug output --- services/brig/src/Brig/Run.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 97860be15e5..c3e973164ff 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -59,7 +59,7 @@ 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 System.Logger.Class (MonadLogger, err, info) import Util.Options -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -176,6 +176,8 @@ pendingActivationCleanup = do threadDelayRandom :: AppIO () threadDelayRandom = do cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings + -- TODO(stefan): remove this + info $ msg (val $ "cleanupTimeout is " <> cs (show cleanupTimeout)) let d = realToFrac cleanupTimeout randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * d, d)) threadDelay (randomSecs * 1_000_000) From 2b16e0e25c333e70fb2ff813f8bcb02446c57e29 Mon Sep 17 00:00:00 2001 From: Stefan Matting Date: Fri, 18 Dec 2020 14:55:15 +0100 Subject: [PATCH 43/47] Revert "add debug output" This reverts commit 1d015e20cf584f520b78c45b4e216904f7fe0090. --- services/brig/src/Brig/Run.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index c3e973164ff..97860be15e5 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -59,7 +59,7 @@ import qualified Network.Wai.Utilities.Server as Server import Servant ((:<|>) (..)) import qualified Servant import System.Logger (msg, val, (.=), (~~)) -import System.Logger.Class (MonadLogger, err, info) +import System.Logger.Class (MonadLogger, err) import Util.Options -- FUTUREWORK: If any of these async threads die, we will have no clue about it @@ -176,8 +176,6 @@ pendingActivationCleanup = do threadDelayRandom :: AppIO () threadDelayRandom = do cleanupTimeout <- fromMaybe (hours 24) . setExpiredUserCleanupTimeout <$> view settings - -- TODO(stefan): remove this - info $ msg (val $ "cleanupTimeout is " <> cs (show cleanupTimeout)) let d = realToFrac cleanupTimeout randomSecs :: Int <- liftIO (round <$> randomRIO @Double (0.5 * d, d)) threadDelay (randomSecs * 1_000_000) From 8009177552de8dc0fbac016b56d11257572de759 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 21 Dec 2020 11:59:59 +0100 Subject: [PATCH 44/47] Add HasCallStack constraints. --- services/spar/test-integration/Util/Invitation.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From 22f33592e73519761e60a1960104220c19ec9dcd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 21 Dec 2020 12:00:15 +0100 Subject: [PATCH 45/47] Fix typo. --- services/spar/test-integration/Test/Spar/Scim/UserSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 943fc970dd6..6f2dde0b4c9 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 From 0b71fc77c7f05ef75d19df7c174b0ad5c647f369 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 21 Dec 2020 12:02:59 +0100 Subject: [PATCH 46/47] Try to fix race condition in integration tests. --- services/spar/test-integration/Test/Spar/Scim/UserSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 6f2dde0b4c9..ae935ef19dd 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -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 From 730f7bcae4bc3f5b44623b76350c82b48401c376 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 21 Dec 2020 12:36:48 +0100 Subject: [PATCH 47/47] Fix merge error. --- services/brig/test/integration/API/UserPendingActivation.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index 0f1d0dfc362..a63cbff86fd 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -207,8 +207,9 @@ randomScimUserWithSubjectAndRichInfo richInfo = do randomScimEmail :: MonadRandom m => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing - primary :: Maybe Bool = Nothing -- TODO: where should we catch users with more than one + -- 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'))