Fix bug: clients without prekeys are not deleted competely

changelog.d/3-bug-fixes/pr-2758

@@ -0,0 +1 @@
+Clients without any prekeys are not deleted completely

services/brig/src/Brig/API.hs

@@ -32,15 +32,17 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore)
 import qualified Data.Swagger.Build.Api as Doc
 import Network.Wai.Routing (Routes)
 import Polysemy
+import Wire.Sem.Concurrency
 
 sitemap ::
   forall r p.
   Members
-    '[ CodeStore,
-       PasswordResetStore,
+    '[ BlacklistPhonePrefixStore,
        BlacklistStore,
-       BlacklistPhonePrefixStore,
        GalleyProvider,
+       CodeStore,
+       Concurrency 'Unsafe,
+       PasswordResetStore,
        UserPendingActivationStore p
      ]
     r =>

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

@@ -46,8 +46,6 @@ module Brig.API.Client
   )
 where
 
-import Bilge.IO
-import Bilge.RPC
 import Brig.API.Types
 import Brig.API.Util
 import Brig.App
@@ -76,7 +74,6 @@ import Brig.User.Email
 import Cassandra (MonadClient)
 import Control.Error
 import Control.Lens (view)
-import Control.Monad.Catch
 import Data.ByteString.Conversion
 import Data.Code as Code
 import Data.Domain (Domain)
@@ -96,7 +93,6 @@ import Polysemy (Member, Members)
 import Servant (Link, ToHttpApiData (toUrlPiece))
 import System.Logger.Class (field, msg, val, (~~))
 import qualified System.Logger.Class as Log
-import UnliftIO.Async (Concurrently (Concurrently, runConcurrently))
 import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients))
 import Wire.API.Federation.Error
 import Wire.API.MLS.Credential (ClientIdentity (..))
@@ -109,6 +105,7 @@ import Wire.API.User.Client
 import Wire.API.User.Client.DPoPAccessToken
 import Wire.API.User.Client.Prekey
 import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap))
+import Wire.Sem.Concurrency
 import Wire.Sem.FromUTC (FromUTC (fromUTCTime))
 import Wire.Sem.Now as Now
 
@@ -241,40 +238,26 @@ rmClient u con clt pw =
       lift $ execDelete u (Just con) client
 
 claimPrekey ::
-  ( MonadReader Env m,
-    MonadMask m,
-    MonadHttp m,
-    HasRequestId m,
-    Log.MonadLogger m,
-    MonadClient m
-  ) =>
   LegalholdProtectee ->
   UserId ->
   Domain ->
   ClientId ->
-  ExceptT ClientError m (Maybe ClientPrekey)
+  ExceptT ClientError (AppT r) (Maybe ClientPrekey)
 claimPrekey protectee u d c = do
   isLocalDomain <- (d ==) <$> viewFederationDomain
   if isLocalDomain
     then claimLocalPrekey protectee u c
-    else claimRemotePrekey (Qualified u d) c
+    else wrapClientE $ claimRemotePrekey (Qualified u d) c
 
 claimLocalPrekey ::
-  ( MonadClient m,
-    MonadReader Env m,
-    MonadMask m,
-    MonadHttp m,
-    HasRequestId m,
-    Log.MonadLogger m
-  ) =>
   LegalholdProtectee ->
   UserId ->
   ClientId ->
-  ExceptT ClientError m (Maybe ClientPrekey)
+  ExceptT ClientError (AppT r) (Maybe ClientPrekey)
 claimLocalPrekey protectee user client = do
   guardLegalhold protectee (mkUserClients [(user, [client])])
   lift $ do
-    prekey <- Data.claimPrekey user client
+    prekey <- wrapHttpClient $ Data.claimPrekey user client
     when (isNothing prekey) (noPrekeys user client)
     pure prekey
 
@@ -298,14 +281,19 @@ claimPrekeyBundle protectee domain uid = do
 claimLocalPrekeyBundle :: LegalholdProtectee -> UserId -> ExceptT ClientError (AppT r) PrekeyBundle
 claimLocalPrekeyBundle protectee u = do
   clients <- map clientId <$> lift (wrapClient (Data.lookupClients u))
-  mapExceptT wrapHttp $ guardLegalhold protectee (mkUserClients [(u, clients)])
+  guardLegalhold protectee (mkUserClients [(u, clients)])
   PrekeyBundle u . catMaybes <$> lift (mapM (wrapHttp . Data.claimPrekey u) clients)
 
 claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppT r) PrekeyBundle
 claimRemotePrekeyBundle quser = do
   Federation.claimPrekeyBundle quser !>> ClientFederationError
 
-claimMultiPrekeyBundles :: LegalholdProtectee -> QualifiedUserClients -> ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMap
+claimMultiPrekeyBundles ::
+  forall r.
+  Members '[Concurrency 'Unsafe] r =>
+  LegalholdProtectee ->
+  QualifiedUserClients ->
+  ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMap
 claimMultiPrekeyBundles protectee quc = do
   loc <- qualifyLocal ()
   let (locals, remotes) =
@@ -341,11 +329,13 @@ claimMultiPrekeyBundles protectee quc = do
         <$> claimLocalMultiPrekeyBundles protectee (tUnqualified luc)
 
 claimLocalMultiPrekeyBundles ::
+  forall r.
+  Members '[Concurrency 'Unsafe] r =>
   LegalholdProtectee ->
   UserClients ->
   ExceptT ClientError (AppT r) UserClientPrekeyMap
 claimLocalMultiPrekeyBundles protectee userClients = do
-  mapExceptT wrapHttp $ guardLegalhold protectee userClients
+  guardLegalhold protectee userClients
   lift
     . fmap mkUserClientPrekeyMap
     . foldMap (getChunk . Map.fromList)
@@ -355,34 +345,27 @@ claimLocalMultiPrekeyBundles protectee userClients = do
     $ userClients
   where
     getChunk :: Map UserId (Set ClientId) -> AppT r (Map UserId (Map ClientId (Maybe Prekey)))
-    getChunk =
-      wrapHttpClient . runConcurrently . Map.traverseWithKey (\u -> Concurrently . getUserKeys u)
+    getChunk m = do
+      e <- ask
+      AppT $
+        lift $
+          fmap (Map.fromListWith (<>)) $
+            unsafePooledMapConcurrentlyN
+              16
+              (\(u, cids) -> (u,) <$> lowerAppT e (getUserKeys u cids))
+              (Map.toList m)
     getUserKeys ::
-      ( MonadClient m,
-        Log.MonadLogger m,
-        MonadMask m,
-        MonadReader Env m,
-        MonadHttp m,
-        HasRequestId m
-      ) =>
       UserId ->
       Set ClientId ->
-      m (Map ClientId (Maybe Prekey))
+      (AppT r) (Map ClientId (Maybe Prekey))
     getUserKeys u =
       sequenceA . Map.fromSet (getClientKeys u)
     getClientKeys ::
-      ( MonadClient m,
-        Log.MonadLogger m,
-        MonadMask m,
-        MonadReader Env m,
-        MonadHttp m,
-        HasRequestId m
-      ) =>
       UserId ->
       ClientId ->
-      m (Maybe Prekey)
+      (AppT r) (Maybe Prekey)
     getClientKeys u c = do
-      key <- fmap prekeyData <$> Data.claimPrekey u c
+      key <- fmap prekeyData <$> wrapHttpClient (Data.claimPrekey u c)
       when (isNothing key) $ noPrekeys u c
       pure key
 
@@ -402,28 +385,23 @@ execDelete u con c = do
 -- thus repairing any inconsistencies related to distributed
 -- (and possibly duplicated) client data.
 noPrekeys ::
-  ( MonadReader Env m,
-    MonadMask m,
-    MonadHttp m,
-    HasRequestId m,
-    Log.MonadLogger m,
-    MonadClient m
-  ) =>
   UserId ->
   ClientId ->
-  m ()
+  (AppT r) ()
 noPrekeys u c = do
-  Log.info $
-    field "user" (toByteString u)
-      ~~ field "client" (toByteString c)
-      ~~ msg (val "No prekey found. Ensuring client does not exist.")
-  Intra.rmClient u c
-  client <- Data.lookupClient u c
-  for_ client $ \_ ->
-    Log.err $
-      field "user" (toByteString u)
-        ~~ field "client" (toByteString c)
-        ~~ msg (val "Client exists without prekeys.")
+  mclient <- wrapClient $ Data.lookupClient u c
+  case mclient of
+    Nothing -> do
+      Log.warn $
+        field "user" (toByteString u)
+          ~~ field "client" (toByteString c)
+          ~~ msg (val "No prekey found. Client is missing, so doing nothing.")
+    Just client -> do
+      Log.warn $
+        field "user" (toByteString u)
+          ~~ field "client" (toByteString c)
+          ~~ msg (val "No prekey found. Deleting client.")
+      execDelete u Nothing client
 
 pubClient :: Client -> PubClient
 pubClient c =

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

@@ -47,7 +47,7 @@ import Data.Range
 import qualified Gundeck.Types.Push as Push
 import Imports
 import Network.Wai.Utilities.Error ((!>>))
-import Polysemy (Members)
+import Polysemy
 import Servant (ServerT)
 import Servant.API
 import UnliftIO.Async (pooledForConcurrentlyN_)
@@ -64,12 +64,14 @@ import Wire.API.User.Client
 import Wire.API.User.Client.Prekey
 import Wire.API.User.Search
 import Wire.API.UserMap (UserMap)
+import Wire.Sem.Concurrency
 
 type FederationAPI = "federation" :> BrigApi
 
 federationSitemap ::
   Members
-    '[ GalleyProvider
+    '[ GalleyProvider,
+       Concurrency 'Unsafe
      ]
     r =>
   ServerT FederationAPI (Handler r)
@@ -138,13 +140,17 @@ getUsersByIds _ uids =
 
 claimPrekey :: Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey)
 claimPrekey _ (user, client) = do
-  wrapHttpClientE (API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client) !>> clientError
+  API.claimLocalPrekey LegalholdPlusFederationNotImplemented user client !>> clientError
 
 claimPrekeyBundle :: Domain -> UserId -> (Handler r) PrekeyBundle
 claimPrekeyBundle _ user =
   API.claimLocalPrekeyBundle LegalholdPlusFederationNotImplemented user !>> clientError
 
-claimMultiPrekeyBundle :: Domain -> UserClients -> (Handler r) UserClientPrekeyMap
+claimMultiPrekeyBundle ::
+  Members '[Concurrency 'Unsafe] r =>
+  Domain ->
+  UserClients ->
+  Handler r UserClientPrekeyMap
 claimMultiPrekeyBundle _ uc = API.claimLocalMultiPrekeyBundles LegalholdPlusFederationNotImplemented uc !>> clientError
 
 fedClaimKeyPackages :: Domain -> ClaimKeyPackageRequest -> Handler r (Maybe KeyPackageBundle)

services/brig/src/Brig/API/MLS/KeyPackages.hs

@@ -76,10 +76,9 @@ claimLocalKeyPackages qusr skipOwn target = do
   foldQualified
     target
     ( \lusr ->
-        wrapHttpClientE $
-          guardLegalhold
-            (ProtectedUser (tUnqualified lusr))
-            (mkUserClients [(tUnqualified target, clients)])
+        guardLegalhold
+          (ProtectedUser (tUnqualified lusr))
+          (mkUserClients [(tUnqualified target, clients)])
     )
     (\_ -> pure ())
     qusr

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

@@ -163,16 +163,17 @@ swaggerDocsAPI Nothing = swaggerDocsAPI (Just maxBound)
 servantSitemap ::
   forall r p.
   Members
-    '[ BlacklistStore,
-       BlacklistPhonePrefixStore,
-       GalleyProvider,
-       UserPendingActivationStore p,
-       PasswordResetStore,
+    '[ BlacklistPhonePrefixStore,
+       BlacklistStore,
        CodeStore,
+       Concurrency 'Unsafe,
+       Concurrency 'Unsafe,
+       GalleyProvider,
        JwtTools,
+       Now,
+       PasswordResetStore,
        PublicKeyBundle,
-       Concurrency 'Unsafe,
-       Now
+       UserPendingActivationStore p
      ]
     r =>
   ServerT BrigAPI (Handler r)
@@ -293,11 +294,12 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey
 
 sitemap ::
   Members
-    '[ CodeStore,
-       PasswordResetStore,
+    '[ BlacklistPhonePrefixStore,
        BlacklistStore,
-       BlacklistPhonePrefixStore,
-       GalleyProvider
+       CodeStore,
+       Concurrency 'Unsafe,
+       GalleyProvider,
+       PasswordResetStore
      ]
     r =>
   Routes Doc.ApiBuilder (Handler r) ()
@@ -310,11 +312,12 @@ sitemap = do
 apiDocs ::
   forall r.
   Members
-    '[ CodeStore,
-       PasswordResetStore,
+    '[ BlacklistPhonePrefixStore,
        BlacklistStore,
-       BlacklistPhonePrefixStore,
-       GalleyProvider
+       CodeStore,
+       Concurrency 'Unsafe,
+       GalleyProvider,
+       PasswordResetStore
      ]
     r =>
   Routes Doc.ApiBuilder (Handler r) ()
@@ -394,7 +397,7 @@ getPrekeyUnqualifiedH zusr user client = do
 
 getPrekeyH :: UserId -> Qualified UserId -> ClientId -> (Handler r) Public.ClientPrekey
 getPrekeyH zusr (Qualified user domain) client = do
-  mPrekey <- wrapHttpClientE $ API.claimPrekey (ProtectedUser zusr) user domain client !>> clientError
+  mPrekey <- API.claimPrekey (ProtectedUser zusr) user domain client !>> clientError
   ifNothing (notFound "prekey not found") mPrekey
 
 getPrekeyBundleUnqualifiedH :: UserId -> UserId -> (Handler r) Public.PrekeyBundle
@@ -406,14 +409,22 @@ getPrekeyBundleH :: UserId -> Qualified UserId -> (Handler r) Public.PrekeyBundl
 getPrekeyBundleH zusr (Qualified uid domain) =
   API.claimPrekeyBundle (ProtectedUser zusr) domain uid !>> clientError
 
-getMultiUserPrekeyBundleUnqualifiedH :: UserId -> Public.UserClients -> (Handler r) Public.UserClientPrekeyMap
+getMultiUserPrekeyBundleUnqualifiedH ::
+  Members '[Concurrency 'Unsafe] r =>
+  UserId ->
+  Public.UserClients ->
+  Handler r Public.UserClientPrekeyMap
 getMultiUserPrekeyBundleUnqualifiedH zusr userClients = do
   maxSize <- fromIntegral . setMaxConvSize <$> view settings
   when (Map.size (Public.userClients userClients) > maxSize) $
     throwStd (errorToWai @'E.TooManyClients)
   API.claimLocalMultiPrekeyBundles (ProtectedUser zusr) userClients !>> clientError
 
-getMultiUserPrekeyBundleH :: UserId -> Public.QualifiedUserClients -> (Handler r) Public.QualifiedUserClientPrekeyMap
+getMultiUserPrekeyBundleH ::
+  Members '[Concurrency 'Unsafe] r =>
+  UserId ->
+  Public.QualifiedUserClients ->
+  (Handler r) Public.QualifiedUserClientPrekeyMap
 getMultiUserPrekeyBundleH zusr qualUserClients = do
   maxSize <- fromIntegral . setMaxConvSize <$> view settings
   let Sum (size :: Int) =

services/brig/src/Brig/CanonicalInterpreter.hs

@@ -27,8 +27,8 @@ import Imports
 import Polysemy (Embed, Final, embedToFinal, runFinal)
 import Polysemy.Error (Error, mapError, runError)
 import Polysemy.TinyLog (TinyLog)
-import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe))
-import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency)
+import Wire.Sem.Concurrency
+import Wire.Sem.Concurrency.IO
 import Wire.Sem.Logger.TinyLog (loggerToTinyLog)
 import Wire.Sem.Now (Now)
 import Wire.Sem.Now.IO (nowToIOAction)