[WPB-24977] Allow suspended users to keep their cookies.

changelog.d/2-features/WPB-24977-allow-suspended-apps-to-keep-their-cookies

@@ -0,0 +1 @@
+Allow suspended users to keep their cookies.

integration/test/Test/Apps.hs

@@ -561,3 +561,47 @@ testAppReceivesMemberJoinNotification = do
     memberJoinApp <- awaitMatch isTeamMemberJoinNotif wsApp
     memberJoinApp %. "payload.0.team" `shouldMatch` tid
     memberJoinApp %. "payload.0.data.user" `shouldMatch` objId newMember
+
+testZauthAndApps :: (HasCallStack) => App ()
+testZauthAndApps = do
+  (owner, tid, []) <- createTeam OwnDomain 1
+  (app, cookie) <- createIt owner tid
+
+  refreshSucceeds app cookie
+  suspendApp app >> refreshFails app cookie
+  unsuspendApp app >> refreshSucceeds app cookie
+  where
+    createIt :: (HasCallStack, MakesValue owner) => owner -> String -> App (Value, String)
+    createIt owner tid =
+      createApp owner tid new `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 200
+        app <- resp.json %. "user"
+        cookie <- resp.json %. "cookie" & asString
+        pure (app, cookie)
+      where
+        new :: NewApp =
+          def
+            { name = "chappie",
+              description = "some description of this app",
+              category = "ai"
+            }
+
+    suspendApp :: (HasCallStack, MakesValue app) => app -> App ()
+    suspendApp app =
+      BrigI.setAccountStatus app "suspended" `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 200
+
+    unsuspendApp :: (HasCallStack, MakesValue app) => app -> App ()
+    unsuspendApp app =
+      BrigI.setAccountStatus app "active" `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 200
+
+    refreshSucceeds :: (HasCallStack, MakesValue app) => app -> String -> App ()
+    refreshSucceeds app cookie =
+      renewToken app cookie `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 200
+
+    refreshFails :: (HasCallStack, MakesValue app) => app -> String -> App ()
+    refreshFails app cookie =
+      renewToken app cookie `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 403

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

@@ -78,6 +78,7 @@ data AuthenticationSubsystem m a where
     SameLabelPolicy ->
     AuthenticationSubsystem m (Either RetryAfter (Cookie (ZAuth.Token t)))
   RevokeCookies :: UserId -> [CookieId] -> [CookieLabel] -> AuthenticationSubsystem m ()
+  RevokeAllExpiredCookies :: UserId -> AuthenticationSubsystem m ()
   -- Verification Codes
   EnforceVerificationCodeEither :: Local UserId -> Maybe Code.Value -> VerificationAction -> AuthenticationSubsystem m (Either VerificationCodeError ())
   -- For testing

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

@@ -26,6 +26,7 @@ import Data.Vector qualified as Vector
 import Data.ZAuth.Creation qualified as ZC
 import Imports
 import Sodium.Crypto.Sign
+import Util.Timeout
 import Wire.API.Allowlists (AllowlistEmailDomains)
 import Wire.AuthenticationSubsystem.Cookie.Limit
 
@@ -35,7 +36,8 @@ data AuthenticationSubsystemConfig = AuthenticationSubsystemConfig
     zauthEnv :: ZAuthEnv,
     userCookieRenewAge :: Integer,
     userCookieLimit :: Int,
-    userCookieThrottle :: CookieThrottle
+    userCookieThrottle :: CookieThrottle,
+    suspendInactiveUsers :: Maybe Timeout
   }
 
 data ZAuthSettings = ZAuthSettings

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

@@ -19,12 +19,14 @@ module Wire.AuthenticationSubsystem.Cookie where
 
 import Data.Id
 import Data.RetryAfter
+import Data.Time
 import Data.ZAuth.CryptoSign (CryptoSign)
 import Data.ZAuth.Token
 import Imports
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
+import Util.Timeout
 import Wire.API.User.Auth
 import Wire.API.UserEvent (UserEvent (UserSessionRefreshSuggested))
 import Wire.AuthenticationSubsystem
@@ -142,3 +144,30 @@ revokeCookiesMatchingExcept u mself ids labels = do
         && ( c.cookieId `elem` ids
                || maybe False (`elem` labels) c.cookieLabel
            )
+
+-- Remove stale cookies.  Stale means either (1) cookie is expired, or
+-- (2) cookie creation time is further in the past than
+-- `env.suspendInactiveUsers` allows.
+revokeAllExpiredCookiesImpl ::
+  ( Member SessionStore r,
+    Member (Input AuthenticationSubsystemConfig) r,
+    Member Now r
+  ) =>
+  UserId ->
+  Sem r ()
+revokeAllExpiredCookiesImpl uid = do
+  now :: UTCTime <- Now.get
+  mbSuspendAge <- (.suspendInactiveUsers) <$> input
+
+  let dead :: Cookie () -> Bool
+      dead c = cookieExpired && userInactive
+        where
+          cookieExpired = c.cookieExpires < now
+          userInactive =
+            maybe
+              False
+              (\suspendAge -> c.cookieCreated < addUTCTime (-(timeoutDiff suspendAge)) now)
+              mbSuspendAge
+
+  cc <- filter dead <$> SessionStore.listCookies uid
+  SessionStore.deleteCookies uid cc

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

@@ -107,6 +107,7 @@ interpretAuthenticationSubsystem userSubsystemInterpreter =
         NewCookie uid mcid typ mLabel policy -> newCookieImpl uid mcid typ mLabel policy
         NewCookieLimited uid mcid typ mLabel policy -> runError $ newCookieLimitedImpl uid mcid typ mLabel policy
         RevokeCookies uid ids labels -> revokeCookiesImpl uid ids labels
+        RevokeAllExpiredCookies uid -> revokeAllExpiredCookiesImpl uid
         -- Verification Codes
         EnforceVerificationCodeEither luid mCode action -> runError $ enforceVerificationCodeImpl luid mCode action
         -- Testing

libs/wire-subsystems/test/unit/Wire/MiniBackend.hs

@@ -417,7 +417,8 @@ defaultAuthenticationSubsystemConfig =
       local = defaultLocalDomain,
       userCookieRenewAge = 2,
       userCookieLimit = 5,
-      userCookieThrottle = StdDevThrottle 5 3
+      userCookieThrottle = StdDevThrottle 5 3,
+      suspendInactiveUsers = Nothing
     }
 
 defaultLocalDomain :: Local ()

services/brig/src/Brig/API/Auth.hs

@@ -61,7 +61,6 @@ import Wire.EmailSubsystem (EmailSubsystem)
 import Wire.Error (HttpError (..))
 import Wire.Events (Events)
 import Wire.GalleyAPIAccess
-import Wire.Sem.Concurrency
 import Wire.Sem.Metrics (Metrics)
 import Wire.Sem.Now (Now)
 import Wire.Sem.Random (Random)
@@ -82,7 +81,6 @@ accessH ::
     Member (Embed IO) r,
     Member Metrics r,
     Member SessionStore r,
-    Member (Concurrency Unsafe) r,
     Member CryptoSign r,
     Member Now r,
     Member AuthenticationSubsystem r,
@@ -111,7 +109,6 @@ access ::
     Member (Embed IO) r,
     Member Metrics r,
     Member SessionStore r,
-    Member (Concurrency Unsafe) r,
     Member CryptoSign r,
     Member Now r,
     Member AuthenticationSubsystem r,
@@ -142,7 +139,6 @@ login ::
     Member ActivationCodeStore r,
     Member AuthenticationSubsystem r,
     Member (Input AuthenticationSubsystemConfig) r,
-    Member (Concurrency Unsafe) r,
     Member Now r,
     Member CryptoSign r,
     Member Random r
@@ -246,7 +242,6 @@ legalHoldLogin ::
     Member Events r,
     Member AuthenticationSubsystem r,
     Member (Input AuthenticationSubsystemConfig) r,
-    Member (Concurrency Unsafe) r,
     Member Now r,
     Member CryptoSign r,
     Member Random r,
@@ -265,7 +260,6 @@ ssoLogin ::
     Member UserSubsystem r,
     Member Events r,
     Member (Input AuthenticationSubsystemConfig) r,
-    Member (Concurrency Unsafe) r,
     Member Now r,
     Member CryptoSign r,
     Member Random r,

services/brig/src/Brig/API/Internal.hs

@@ -254,7 +254,6 @@ accountAPI ::
     Member RateLimit r,
     Member SparAPIAccess r,
     Member EnterpriseLoginSubsystem r,
-    Member (Concurrency Unsafe) r,
     Member ClientStore r,
     Member ClientSubsystem r
   ) =>
@@ -316,8 +315,8 @@ teamsAPI ::
     Member (Polysemy.Error UserSubsystemError) r,
     Member Events r,
     Member (Input (Local ())) r,
-    Member IndexedUserStore r,
-    Member AuthenticationSubsystem r
+    Member AuthenticationSubsystem r,
+    Member IndexedUserStore r
   ) =>
   ServerT BrigIRoutes.TeamsAPI (Handler r)
 teamsAPI =
@@ -347,7 +346,6 @@ authAPI ::
     Member UserSubsystem r,
     Member AuthenticationSubsystem r,
     Member (Input AuthenticationSubsystemConfig) r,
-    Member (Concurrency Unsafe) r,
     Member Now r,
     Member CryptoSign r,
     Member Random r,
@@ -785,9 +783,8 @@ getPasswordResetCode email =
 changeAccountStatusH ::
   ( Member UserSubsystem r,
     Member Events r,
-    Member (Concurrency Unsafe) r,
-    Member AuthenticationSubsystem r,
-    Member UserStore r
+    Member UserStore r,
+    Member AuthenticationSubsystem r
   ) =>
   UserId ->
   AccountStatusUpdate ->

services/brig/src/Brig/API/User.hs

@@ -90,7 +90,6 @@ import Data.Json.Util
 import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus)
 import Data.List.Extra
 import Data.List.NonEmpty (NonEmpty)
-import Data.List.NonEmpty qualified as NonEmpty
 import Data.Misc
 import Data.Qualified
 import Data.Range
@@ -121,6 +120,7 @@ import Wire.API.UserEvent
 import Wire.ActivationCodeStore
 import Wire.ActivationCodeStore qualified as ActivationCode
 import Wire.AuthenticationSubsystem (AuthenticationSubsystem, internalLookupPasswordResetCode)
+import Wire.AuthenticationSubsystem qualified as Auth
 import Wire.BackendNotificationQueueAccess
 import Wire.BlockListStore as BlockListStore
 import Wire.ClientStore (ClientStore)
@@ -627,57 +627,69 @@ changeAccountStatus ::
   ( Member (Concurrency 'Unsafe) r,
     Member UserSubsystem r,
     Member Events r,
-    Member AuthenticationSubsystem r,
-    Member UserStore r
+    Member UserStore r,
+    Member AuthenticationSubsystem r
   ) =>
   NonEmpty UserId ->
   AccountStatus ->
   ExceptT AccountStatusError (AppT r) ()
 changeAccountStatus usrs status = do
-  ev <- mkUserEvent usrs status
-  lift $ liftSem $ unsafePooledMapConcurrentlyN_ 16 (update ev) usrs
-  where
-    update ::
-      (UserId -> UserEvent) ->
-      UserId ->
-      Sem r ()
-    update ev u = do
-      UserStore.updateAccountStatus u status
-      User.internalUpdateSearchIndex u
-      Events.generateUserEvent u Nothing (ev u)
+  ev <- mkUserEvent status
+  lift $ liftSem $ unsafePooledMapConcurrentlyN_ 16 (changeSingleAccountStatusInternal status ev) usrs
 
 changeSingleAccountStatus ::
   ( Member UserSubsystem r,
     Member Events r,
-    Member (Concurrency Unsafe) r,
-    Member AuthenticationSubsystem r,
-    Member UserStore r
+    Member UserStore r,
+    Member AuthenticationSubsystem r
   ) =>
   UserId ->
   AccountStatus ->
   ExceptT AccountStatusError (AppT r) ()
 changeSingleAccountStatus uid status = do
   unlessM (lift . liftSem $ UserStore.doesUserExist uid) $ throwE AccountNotFound
-  ev <- mkUserEvent (NonEmpty.singleton uid) status
-  lift . liftSem $ do
-    UserStore.updateAccountStatus uid status
-    User.internalUpdateSearchIndex uid
-    Events.generateUserEvent uid Nothing (ev uid)
+  ev <- mkUserEvent status
+  lift . liftSem $ changeSingleAccountStatusInternal status ev uid
 
-mkUserEvent ::
-  ( Traversable t,
-    Member (Concurrency Unsafe) r,
+changeSingleAccountStatusInternal ::
+  ( Member UserSubsystem r,
+    Member Events r,
+    Member UserStore r,
     Member AuthenticationSubsystem r
   ) =>
-  t UserId ->
   AccountStatus ->
-  ExceptT AccountStatusError (AppT r) (UserId -> UserEvent)
-mkUserEvent usrs status =
+  (UserId -> UserEvent) ->
+  UserId ->
+  Sem r ()
+changeSingleAccountStatusInternal status ev u = do
+  -- It is safe to *not* revoke any cookies here; if no valid access
+  -- token is available, cookies are only validated when calling `POST
+  -- /access`, and access token refresh only works on unsuspended
+  -- users.
+  --
+  -- Evidence: `git grep -Hn --color=never 'UserToken\b' | grep libs/wire-api/src/Wire/API/Routes/Public/`.
+  --
+  -- Having that said, we need to remove all *expired* cookies here,
+  -- otherwise /login considers the user inactive, see
+  -- 'mustSuspendInactiveUser'.
+  --
+  -- The intuition is that every change of account status can be
+  -- considered an account activity, so users that have their status
+  -- changed recently should not be considered inactive, even if they
+  -- haven't taken any action themselves.
+  Auth.revokeAllExpiredCookies u
+  UserStore.updateAccountStatus u status
+  User.internalUpdateSearchIndex u
+  Events.generateUserEvent u Nothing (ev u)
+
+mkUserEvent ::
+  (Monad m) =>
+  AccountStatus ->
+  ExceptT AccountStatusError m (UserId -> UserEvent)
+mkUserEvent status =
   case status of
     Active -> pure UserResumed
-    Suspended -> do
-      lift $ liftSem (unsafePooledMapConcurrentlyN_ 16 Auth.revokeAllCookies usrs)
-      pure UserSuspended
+    Suspended -> pure UserSuspended
     Deleted -> throwE InvalidAccountStatus
     Ephemeral -> throwE InvalidAccountStatus
     PendingInvitation -> throwE InvalidAccountStatus

services/brig/src/Brig/CanonicalInterpreter.hs

@@ -28,7 +28,7 @@ import Brig.Effects.SFT (SFT, interpretSFT)
 import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore)
 import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra)
 import Brig.IO.Intra (runEvents)
-import Brig.Options (Settings (consumableNotifications), federationDomainConfigs, federationStrategy)
+import Brig.Options (Settings (consumableNotifications), SuspendInactiveUsers (..), federationDomainConfigs, federationStrategy)
 import Brig.Options qualified as Opt
 import Brig.Template (InvitationUrlTemplates)
 import Brig.User.Search.Index (IndexEnv (..))
@@ -338,7 +338,8 @@ runBrigToIO e (AppT ma) = do
             local = localUnit,
             userCookieRenewAge = e.settings.userCookieRenewAge,
             userCookieLimit = e.settings.userCookieLimit,
-            userCookieThrottle = e.settings.userCookieThrottle
+            userCookieThrottle = e.settings.userCookieThrottle,
+            suspendInactiveUsers = suspendTimeout <$> e.settings.suspendInactiveUsers
           }
       mainESEnv = e.indexEnv ^. to idxElastic
       indexedUserStoreConfig =

services/brig/src/Brig/Team/API.hs

@@ -69,7 +69,7 @@ import Wire.API.Team.Member qualified as Teams
 import Wire.API.Team.Permission (Perm (AddTeamMember))
 import Wire.API.Team.Size
 import Wire.API.User hiding (fromEmail)
-import Wire.AuthenticationSubsystem
+import Wire.AuthenticationSubsystem qualified as Auth
 import Wire.BlockListStore
 import Wire.EmailSubsystem.Interpreter (renderInvitationUrl)
 import Wire.Error
@@ -373,7 +373,7 @@ suspendTeam ::
     Member Events r,
     Member TinyLog r,
     Member InvitationStore r,
-    Member AuthenticationSubsystem r,
+    Member Auth.AuthenticationSubsystem r,
     Member UserStore r
   ) =>
   TeamId ->
@@ -394,7 +394,7 @@ unsuspendTeam ::
     Member UserSubsystem r,
     Member TeamSubsystem r,
     Member Events r,
-    Member AuthenticationSubsystem r,
+    Member Auth.AuthenticationSubsystem r,
     Member UserStore r
   ) =>
   TeamId ->
@@ -413,7 +413,7 @@ changeTeamAccountStatuses ::
     Member TeamSubsystem r,
     Member UserSubsystem r,
     Member Events r,
-    Member AuthenticationSubsystem r,
+    Member Auth.AuthenticationSubsystem r,
     Member UserStore r
   ) =>
   TeamId ->