[Polysemy] Effects Around the User Query Effect

changelog.d/5-internal/user-effects

@@ -0,0 +1 @@
+Add the UserQuery and supporting effects

libs/brig-types/src/Brig/Types/Common.hs

@@ -29,6 +29,15 @@ module Brig.Types.Common
     isValidPhonePrefix,
     allPrefixes,
     ExcludedPrefix (..),
+
+    -- * misc
+    foldKey,
+    keyText,
+    mkPhoneKey,
+    mkEmailKey,
+    EmailKey (..),
+    PhoneKey (..),
+    UserKey (..),
   )
 where
 
@@ -39,6 +48,7 @@ import Data.ByteString.Conversion
 import qualified Data.Text as Text
 import Data.Time.Clock (NominalDiffTime)
 import Imports
+import Wire.API.User.Identity
 
 ------------------------------------------------------------------------------
 --- PhoneBudgetTimeout
@@ -111,3 +121,74 @@ instance FromJSON ExcludedPrefix where
 
 instance ToJSON ExcludedPrefix where
   toJSON (ExcludedPrefix p c) = object ["phone_prefix" .= p, "comment" .= c]
+
+-------------------------------------------------------------------------------
+-- Unique Keys
+
+-- | An 'EmailKey' is an 'Email' in a form that serves as a unique lookup key.
+data EmailKey = EmailKey
+  { emailKeyUniq :: !Text,
+    emailKeyOrig :: !Email
+  }
+
+instance Show EmailKey where
+  showsPrec _ = shows . emailKeyUniq
+
+instance Eq EmailKey where
+  (EmailKey k _) == (EmailKey k' _) = k == k'
+
+-- | Turn an 'Email' into an 'EmailKey'.
+--
+-- The following transformations are performed:
+--
+--   * Both local and domain parts are forced to lowercase to make
+--     e-mail addresses fully case-insensitive.
+--   * "+" suffixes on the local part are stripped unless the domain
+--     part is contained in a trusted whitelist.
+mkEmailKey :: Email -> EmailKey
+mkEmailKey orig@(Email localPart domain) =
+  let uniq = Text.toLower localPart' <> "@" <> Text.toLower domain
+   in EmailKey uniq orig
+  where
+    localPart'
+      | domain `notElem` trusted = Text.takeWhile (/= '+') localPart
+      | otherwise = localPart
+    trusted = ["wearezeta.com", "wire.com", "simulator.amazonses.com"]
+
+data PhoneKey = PhoneKey
+  { -- | canonical form of 'phoneKeyOrig', without whitespace.
+    phoneKeyUniq :: !Text,
+    -- | phone number with whitespace.
+    phoneKeyOrig :: !Phone
+  }
+
+instance Show PhoneKey where
+  showsPrec _ = shows . phoneKeyUniq
+
+instance Eq PhoneKey where
+  (PhoneKey k _) == (PhoneKey k' _) = k == k'
+
+mkPhoneKey :: Phone -> PhoneKey
+mkPhoneKey orig =
+  let uniq = Text.filter (not . isSpace) (fromPhone orig)
+   in PhoneKey uniq orig
+
+-- | A natural identifier (i.e. unique key) of a user.
+data UserKey
+  = UserEmailKey !EmailKey
+  | UserPhoneKey !PhoneKey
+
+instance Eq UserKey where
+  (UserEmailKey k) == (UserEmailKey k') = k == k'
+  (UserPhoneKey k) == (UserPhoneKey k') = k == k'
+  _ == _ = False
+
+-- | Get the normalised text of a 'UserKey'.
+keyText :: UserKey -> Text
+keyText (UserEmailKey k) = emailKeyUniq k
+keyText (UserPhoneKey k) = phoneKeyUniq k
+
+foldKey :: (Email -> a) -> (Phone -> a) -> UserKey -> a
+foldKey f g k = case k of
+  UserEmailKey ek -> f (emailKeyOrig ek)
+  UserPhoneKey pk -> g (phoneKeyOrig pk)

services/brig/brig.cabal

@@ -41,7 +41,6 @@ library
       Brig.AWS
       Brig.AWS.SesNotification
       Brig.AWS.Types
-      Brig.Budget
       Brig.Calling
       Brig.Calling.API
       Brig.Calling.Internal
@@ -88,11 +87,37 @@ library
       Brig.Queue.Stomp
       Brig.Queue.Types
       Brig.RPC
+      Brig.RPC.Decode
       Brig.Run
+      Brig.Sem.ActivationKeyStore
+      Brig.Sem.ActivationKeyStore.Cassandra
+      Brig.Sem.ActivationSupply
+      Brig.Sem.ActivationSupply.IO
+      Brig.Sem.BudgetStore
+      Brig.Sem.BudgetStore.Cassandra
       Brig.Sem.CodeStore
       Brig.Sem.CodeStore.Cassandra
+      Brig.Sem.Common
+      Brig.Sem.GalleyAccess
+      Brig.Sem.GalleyAccess.Http
+      Brig.Sem.GundeckAccess
+      Brig.Sem.GundeckAccess.Http
       Brig.Sem.PasswordResetStore
       Brig.Sem.PasswordResetStore.CodeStore
+      Brig.Sem.PasswordResetSupply
+      Brig.Sem.PasswordResetSupply.IO
+      Brig.Sem.Twilio
+      Brig.Sem.Twilio.IO
+      Brig.Sem.UniqueClaimsStore
+      Brig.Sem.UniqueClaimsStore.Cassandra
+      Brig.Sem.UserHandleStore
+      Brig.Sem.UserHandleStore.Cassandra
+      Brig.Sem.UserKeyStore
+      Brig.Sem.UserKeyStore.Cassandra
+      Brig.Sem.UserQuery
+      Brig.Sem.UserQuery.Cassandra
+      Brig.Sem.VerificationCodeStore
+      Brig.Sem.VerificationCodeStore.Cassandra
       Brig.SMTP
       Brig.Team.API
       Brig.Team.DB
@@ -223,6 +248,7 @@ library
     , imports
     , insert-ordered-containers
     , iproute >=1.5
+    , iso3166-country-codes
     , iso639 >=0.1
     , lens >=3.8
     , lens-aeson >=1.0
@@ -239,6 +265,8 @@ library
     , optparse-applicative >=0.11
     , pem >=0.2
     , polysemy
+    , polysemy-conc
+    , polysemy-time
     , polysemy-wire-zoo
     , proto-lens >=0.1
     , random-shuffle >=0.0.3

services/brig/package.yaml

@@ -68,6 +68,7 @@ library:
   - imports
   - insert-ordered-containers
   - iproute >=1.5
+  - iso3166-country-codes
   - iso639 >=0.1
   - lens >=3.8
   - lens-aeson >=1.0
@@ -85,6 +86,8 @@ library:
   - optparse-applicative >=0.11
   - pem >=0.2
   - polysemy
+  - polysemy-conc
+  - polysemy-time
   - polysemy-wire-zoo
   - proto-lens >=0.1
   - random-shuffle >=0.0.3

services/brig/src/Brig/API.hs

@@ -23,20 +23,58 @@ where
 import Brig.API.Handler (Handler)
 import qualified Brig.API.Internal as Internal
 import qualified Brig.API.Public as Public
+import Brig.API.Types
 import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore)
 import Brig.Effects.BlacklistStore (BlacklistStore)
+import Brig.Sem.ActivationKeyStore
+import Brig.Sem.ActivationSupply
+import Brig.Sem.BudgetStore
 import Brig.Sem.CodeStore
+import Brig.Sem.GalleyAccess
 import Brig.Sem.PasswordResetStore (PasswordResetStore)
+import Brig.Sem.PasswordResetSupply (PasswordResetSupply)
+import Brig.Sem.Twilio
+import Brig.Sem.UniqueClaimsStore
+import Brig.Sem.UserHandleStore
+import Brig.Sem.UserKeyStore
+import Brig.Sem.UserQuery
+import Brig.Sem.VerificationCodeStore
+import Data.Qualified
 import qualified Data.Swagger.Build.Api as Doc
 import Network.Wai.Routing (Routes)
 import Polysemy
+import Polysemy.Async
+import Polysemy.Conc.Effect.Race
+import Polysemy.Error
+import Polysemy.Input
+import Polysemy.Resource
+import qualified Polysemy.TinyLog as P
+import qualified Ropes.Twilio as Twilio
 
 sitemap ::
   Members
-    '[ CodeStore,
-       PasswordResetStore,
+    '[ ActivationKeyStore,
+       ActivationSupply,
+       Async,
        BlacklistStore,
-       BlacklistPhonePrefixStore
+       BlacklistPhonePrefixStore,
+       BudgetStore,
+       CodeStore,
+       Error ReAuthError,
+       Error Twilio.ErrorResponse,
+       GalleyAccess,
+       Input (Local ()),
+       P.TinyLog,
+       PasswordResetStore,
+       PasswordResetSupply,
+       Race,
+       Resource,
+       Twilio,
+       UniqueClaimsStore,
+       UserHandleStore,
+       UserKeyStore,
+       UserQuery,
+       VerificationCodeStore
      ]
     r =>
   Routes Doc.ApiBuilder (Handler r) ()

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

@@ -57,6 +57,9 @@ import qualified Brig.Federation.Client as Federation
 import Brig.IO.Intra (guardLegalhold)
 import qualified Brig.IO.Intra as Intra
 import qualified Brig.Options as Opt
+import Brig.Sem.GalleyAccess
+import Brig.Sem.UserQuery (UserQuery)
+import Brig.Sem.VerificationCodeStore
 import Brig.Types.Intra
 import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..))
 import Brig.Types.User.Event
@@ -79,7 +82,10 @@ import Data.Misc (PlainTextPassword (..))
 import Data.Qualified
 import qualified Data.Set as Set
 import Imports
-import Network.Wai.Utilities
+import Network.Wai.Utilities hiding (Error)
+import Polysemy
+import Polysemy.Error
+import Polysemy.Input
 import System.Logger.Class (field, msg, val, (~~))
 import qualified System.Logger.Class as Log
 import UnliftIO.Async (Concurrently (Concurrently, runConcurrently))
@@ -129,6 +135,7 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap (
 lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk
 
 addClient ::
+  Members '[GalleyAccess, Input (Local ()), UserQuery, VerificationCodeStore] r =>
   UserId ->
   Maybe ConnId ->
   Maybe IP ->
@@ -139,15 +146,18 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients
 -- nb. We must ensure that the set of clients known to brig is always
 -- a superset of the clients known to galley.
 addClientWithReAuthPolicy ::
+  forall r.
+  Members '[GalleyAccess, Input (Local ()), UserQuery, VerificationCodeStore] r =>
   Data.ReAuthPolicy ->
   UserId ->
   Maybe ConnId ->
   Maybe IP ->
   NewClient ->
   ExceptT ClientError (AppT r) Client
 addClientWithReAuthPolicy policy u con ip new = do
-  acc <- lift (wrapClient $ Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) pure
-  wrapHttpClientE $ verifyCode (newClientVerificationCode new) (userId . accountUser $ acc)
+  locale <- Opt.setDefaultUserLocale <$> view settings
+  acc <- lift (liftSem $ Data.lookupAccount locale u) >>= maybe (throwE (ClientUserNotFound u)) pure
+  verifyCodeThrow (newClientVerificationCode new) (userId . accountUser $ acc)
   loc <- maybe (pure Nothing) locationOf ip
   maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings
   let caps :: Maybe (Set ClientCapability)
@@ -159,8 +169,7 @@ addClientWithReAuthPolicy policy u con ip new = do
               else id
           lhcaps = ClientSupportsLegalholdImplicitConsent
   (clt0, old, count) <-
-    wrapClientE
-      (Data.addClientWithReAuthPolicy policy u clientId' new maxPermClients loc caps)
+    (Data.addClientWithReAuthPolicy policy u clientId' new maxPermClients loc caps)
       !>> ClientDataError
   let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new}
   let usr = accountUser acc
@@ -177,19 +186,11 @@ addClientWithReAuthPolicy policy u con ip new = do
   where
     clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new)
 
-    verifyCode ::
-      ( MonadReader Env m,
-        MonadMask m,
-        MonadHttp m,
-        MonadIO m,
-        HasRequestId m,
-        Log.MonadLogger m,
-        MonadClient m
-      ) =>
+    verifyCodeThrow ::
       Maybe Code.Value ->
       UserId ->
-      ExceptT ClientError m ()
-    verifyCode mbCode userId =
+      ExceptT ClientError (AppT r) ()
+    verifyCodeThrow mbCode userId =
       -- this only happens inside the login flow (in particular, when logging in from a new device)
       -- the code obtained for logging in is used a second time for adding the device
       UserAuth.verifyCode mbCode Code.Login userId `catchE` \case
@@ -212,18 +213,25 @@ updateClient u c r = do
 
 -- nb. We must ensure that the set of clients known to brig is always
 -- a superset of the clients known to galley.
-rmClient :: UserId -> ConnId -> ClientId -> Maybe PlainTextPassword -> ExceptT ClientError (AppT r) ()
+rmClient ::
+  Members '[Error ReAuthError, Input (Local ()), UserQuery] r =>
+  UserId ->
+  ConnId ->
+  ClientId ->
+  Maybe PlainTextPassword ->
+  ExceptT ClientError (AppT r) ()
 rmClient u con clt pw =
   maybe (throwE ClientNotFound) fn =<< lift (wrapClient $ Data.lookupClient u clt)
   where
     fn client = do
+      locale <- Opt.setDefaultUserLocale <$> view settings
       case clientType client of
         -- Legal hold clients can't be removed
         LegalHoldClientType -> throwE ClientLegalHoldCannotBeRemoved
         -- Temporary clients don't need to re-auth
         TemporaryClientType -> pure ()
         -- All other clients must authenticate
-        _ -> wrapClientE (Data.reauthenticate u pw) !>> ClientDataError . ClientReAuthError
+        _ -> lift (liftSem (Data.reauthenticate locale u pw)) !>> ClientDataError . ClientReAuthError
       lift $ execDelete u (Just con) client
 
 claimPrekey ::
@@ -380,7 +388,7 @@ claimLocalMultiPrekeyBundles protectee userClients = do
 -- Utilities
 
 -- | Perform an orderly deletion of an existing client.
-execDelete :: UserId -> Maybe ConnId -> Client -> (AppT r) ()
+execDelete :: UserId -> Maybe ConnId -> Client -> AppT r ()
 execDelete u con c = do
   wrapHttp $ Intra.rmClient u (clientId c)
   for_ (clientCookie c) $ \l -> wrapClient $ Auth.revokeCookies u [] [l]