diff --git a/changelog.d/5-internal/user-effects b/changelog.d/5-internal/user-effects new file mode 100644 index 0000000000..3e6804c19d --- /dev/null +++ b/changelog.d/5-internal/user-effects @@ -0,0 +1 @@ +Add the UserQuery and supporting effects diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index 2b95cb7639..532c3e1c8a 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/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) diff --git a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal index 17108388e5..fefacb9d49 100644 --- a/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal +++ b/libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal @@ -13,6 +13,12 @@ build-type: Simple library exposed-modules: Polysemy.TinyLog + Wire.Sem.Concurrency + Wire.Sem.Concurrency.IO + Wire.Sem.Concurrency.Sequential + Wire.Sem.Error + Wire.Sem.FireAndForget + Wire.Sem.FireAndForget.IO Wire.Sem.FromUTC Wire.Sem.Logger Wire.Sem.Logger.Level @@ -25,9 +31,6 @@ library Wire.Sem.Paging.Cassandra Wire.Sem.Random Wire.Sem.Random.IO - Wire.Sem.Concurrency - Wire.Sem.Concurrency.IO - Wire.Sem.Concurrency.Sequential other-modules: Paths_polysemy_wire_zoo hs-source-dirs: src diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/Error.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/Error.hs new file mode 100644 index 0000000000..5c2d8b27df --- /dev/null +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/Error.hs @@ -0,0 +1,37 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Wire.Sem.Error where + +import Imports +import Polysemy +import Polysemy.Error +import qualified UnliftIO.Exception as UnliftIO +import Wire.API.Error + +interpretErrorToException :: + (Exception exc, Member (Embed IO) r) => + (err -> exc) -> + Sem (Error err ': r) a -> + Sem r a +interpretErrorToException f = either (embed @IO . UnliftIO.throwIO . f) pure <=< runError + +interpretWaiErrorToException :: + (APIError e, Member (Embed IO) r) => + Sem (Error e ': r) a -> + Sem r a +interpretWaiErrorToException = interpretErrorToException toWai diff --git a/libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget.hs new file mode 100644 index 0000000000..d2d8a16247 --- /dev/null +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 Wire.Sem.FireAndForget where + +import Polysemy + +data FireAndForget m a where + FireAndForgetOne :: m () -> FireAndForget m () + SpawnMany :: [m ()] -> FireAndForget m () + +makeSem ''FireAndForget + +fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () +fireAndForget = fireAndForgetOne diff --git a/services/galley/src/Galley/Effects/FireAndForget.hs b/libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget/IO.hs similarity index 74% rename from services/galley/src/Galley/Effects/FireAndForget.hs rename to libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget/IO.hs index 0a99f3c555..82729b5576 100644 --- a/services/galley/src/Galley/Effects/FireAndForget.hs +++ b/libs/polysemy-wire-zoo/src/Wire/Sem/FireAndForget/IO.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,33 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Effects.FireAndForget - ( FireAndForget, - fireAndForget, - spawnMany, - interpretFireAndForget, - ) -where +module Wire.Sem.FireAndForget.IO (interpretFireAndForget) where import Imports import Polysemy import Polysemy.Final import UnliftIO.Async (pooledMapConcurrentlyN_) - -data FireAndForget m a where - FireAndForgetOne :: m () -> FireAndForget m () - SpawnMany :: [m ()] -> FireAndForget m () - -makeSem ''FireAndForget - -fireAndForget :: Member FireAndForget r => Sem r () -> Sem r () -fireAndForget = fireAndForgetOne +import Wire.Sem.FireAndForget -- | Run actions in separate threads and ignore results. -- -- /Note/: this will also ignore any state and error effects contained in the -- 'FireAndForget' action. Use with care. -interpretFireAndForget :: Member (Final IO) r => Sem (FireAndForget ': r) a -> Sem r a +interpretFireAndForget :: + Member (Final IO) r => + Sem (FireAndForget ': r) a -> + Sem r a interpretFireAndForget = interpretFinal @IO $ \case FireAndForgetOne action -> do action' <- runS action diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index f74e685d14..9516e797a8 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -38,7 +38,6 @@ library Brig.AWS Brig.AWS.SesNotification Brig.AWS.Types - Brig.Budget Brig.Calling Brig.Calling.API Brig.Calling.Internal @@ -55,20 +54,49 @@ library Brig.Data.Types Brig.Data.User Brig.Data.UserKey + Brig.Effects.ActivationKeyStore + Brig.Effects.ActivationKeyStore.Cassandra + Brig.Effects.ActivationSupply + Brig.Effects.ActivationSupply.IO Brig.Effects.BlacklistPhonePrefixStore Brig.Effects.BlacklistPhonePrefixStore.Cassandra Brig.Effects.BlacklistStore Brig.Effects.BlacklistStore.Cassandra + Brig.Effects.BudgetStore + Brig.Effects.BudgetStore.Cassandra + Brig.Effects.ClientStore + Brig.Effects.ClientStore.Cassandra Brig.Effects.CodeStore Brig.Effects.CodeStore.Cassandra + Brig.Effects.Common + Brig.Effects.CookieStore + Brig.Effects.CookieStore.Cassandra Brig.Effects.Delay + Brig.Effects.GalleyAccess + Brig.Effects.GalleyAccess.Http + Brig.Effects.GundeckAccess + Brig.Effects.GundeckAccess.Http Brig.Effects.JwtTools Brig.Effects.PasswordResetStore Brig.Effects.PasswordResetStore.CodeStore + Brig.Effects.PasswordResetSupply + Brig.Effects.PasswordResetSupply.IO Brig.Effects.PublicKeyBundle Brig.Effects.SFT + Brig.Effects.Twilio + Brig.Effects.Twilio.IO + Brig.Effects.UniqueClaimsStore + Brig.Effects.UniqueClaimsStore.Cassandra + Brig.Effects.UserHandleStore + Brig.Effects.UserHandleStore.Cassandra + Brig.Effects.UserKeyStore + Brig.Effects.UserKeyStore.Cassandra Brig.Effects.UserPendingActivationStore Brig.Effects.UserPendingActivationStore.Cassandra + Brig.Effects.UserQuery + Brig.Effects.UserQuery.Cassandra + Brig.Effects.VerificationCodeStore + Brig.Effects.VerificationCodeStore.Cassandra Brig.Email Brig.Federation.Client Brig.Index.Eval @@ -93,6 +121,7 @@ library Brig.Queue.Stomp Brig.Queue.Types Brig.RPC + Brig.RPC.Decode Brig.Run Brig.SMTP Brig.Team.API @@ -229,6 +258,7 @@ library , imports , insert-ordered-containers , iproute >=1.5 + , iso3166-country-codes , iso639 >=0.1 , jwt-tools , lens >=3.8 @@ -247,7 +277,9 @@ library , optparse-applicative >=0.11 , pem >=0.2 , polysemy + , polysemy-conc , polysemy-plugin + , polysemy-time , polysemy-wire-zoo , proto-lens >=0.1 , random-shuffle >=0.0.3 diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 9b7ce571d2..d15b227b8a 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -23,23 +23,71 @@ 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.ActivationKeyStore +import Brig.Effects.ActivationSupply import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) +import Brig.Effects.BudgetStore +import Brig.Effects.ClientStore import Brig.Effects.CodeStore +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess (GundeckAccess) import Brig.Effects.PasswordResetStore (PasswordResetStore) +import Brig.Effects.PasswordResetSupply (PasswordResetSupply) +import Brig.Effects.Twilio +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) +import Brig.Effects.UserQuery +import Brig.Effects.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 +import Wire.Sem.Concurrency +import Wire.Sem.Paging sitemap :: forall r p. + Paging p => Members - '[ CodeStore, - PasswordResetStore, + '[ ActivationKeyStore, + ActivationSupply, + Async, BlacklistStore, BlacklistPhonePrefixStore, - UserPendingActivationStore p + BudgetStore, + ClientStore, + CodeStore, + Concurrency 'Unsafe, + CookieStore, + Error ReAuthError, + Error Twilio.ErrorResponse, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + PasswordResetStore, + PasswordResetSupply, + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p, + VerificationCodeStore ] r => Routes Doc.ApiBuilder (Handler r) () diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 0d96f8351e..e25e02ab69 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -54,10 +54,16 @@ import Brig.App import qualified Brig.Data.Client as Data import Brig.Data.Nonce as Nonce import qualified Brig.Data.User as Data +import Brig.Effects.ClientStore +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess (GundeckAccess) import Brig.Effects.JwtTools (JwtTools) import qualified Brig.Effects.JwtTools as JwtTools import Brig.Effects.PublicKeyBundle (PublicKeyBundle) import qualified Brig.Effects.PublicKeyBundle as PublicKeyBundle +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore import Brig.Federation.Client (getUserClients) import qualified Brig.Federation.Client as Federation import Brig.IO.Intra (guardLegalhold) @@ -89,8 +95,10 @@ import qualified Data.Set as Set import Data.String.Conversions (cs) import Imports import Network.HTTP.Types.Method (StdMethod) -import Network.Wai.Utilities -import Polysemy (Member) +import Network.Wai.Utilities hiding (Error) +import Polysemy +import Polysemy.Error hiding (note) +import Polysemy.Input import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log @@ -146,6 +154,16 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap ( lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk addClient :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => UserId -> Maybe ConnId -> Maybe IP -> @@ -156,6 +174,17 @@ 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 p. + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => Data.ReAuthPolicy -> UserId -> Maybe ConnId -> @@ -163,8 +192,9 @@ addClientWithReAuthPolicy :: 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) @@ -176,17 +206,16 @@ 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 lift $ do for_ old $ execDelete u con - wrapHttp $ do - Intra.newClient u (clientId clt) - Intra.onClientEvent u con (ClientAdded u clt) - when (clientType clt == LegalHoldClientType) $ wrapHttpClient $ Intra.onUserEvent u con (UserLegalHoldEnabled u) + wrapHttp $ Intra.newClient u (clientId clt) + liftSem $ Intra.onClientEvent u con (ClientAdded u clt) + when (clientType clt == LegalHoldClientType) $ + Intra.onUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ for_ (userEmail usr) $ \email -> @@ -195,18 +224,11 @@ addClientWithReAuthPolicy policy u con ip new = do where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) - verifyCode :: - ( MonadReader Env m, - MonadMask m, - MonadHttp 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 @@ -229,18 +251,33 @@ 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 + '[ ClientStore, + CookieStore, + Error ReAuthError, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + 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 :: @@ -392,10 +429,15 @@ claimLocalMultiPrekeyBundles protectee userClients = do -- Utilities -- | Enqueue an orderly deletion of an existing client. -execDelete :: UserId -> Maybe ConnId -> Client -> (AppT r) () +execDelete :: + Members '[ClientStore, CookieStore] r => + UserId -> + Maybe ConnId -> + Client -> + AppT r () execDelete u con c = do - wrapClient $ Data.rmClient u (clientId c) - for_ (clientCookie c) $ \l -> wrapClient $ Auth.revokeCookies u [] [l] + liftSem $ deleteClient u (clientId c) + for_ (clientCookie c) $ \l -> liftSem $ Auth.revokeCookies u [] [l] queue <- view internalEvents Queue.enqueue queue (Internal.DeleteClient c u con) @@ -435,9 +477,13 @@ pubClient c = pubClientClass = clientClass c } -legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppT r) () +legalHoldClientRequested :: + Members '[GalleyAccess, GundeckAccess] r => + UserId -> + LegalHoldClientRequest -> + AppT r () legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') = - wrapHttpClient $ Intra.onUserEvent targetUser Nothing lhClientEvent + Intra.onUserEvent targetUser Nothing lhClientEvent where clientId :: ClientId clientId = clientIdFromPrekey $ unpackLastPrekey lastPrekey' @@ -446,14 +492,23 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke lhClientEvent :: UserEvent lhClientEvent = LegalHoldClientRequested eventData -removeLegalHoldClient :: UserId -> (AppT r) () +removeLegalHoldClient :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess + ] + r => + UserId -> + AppT r () removeLegalHoldClient uid = do clients <- wrapClient $ Data.lookupClients uid -- Should only be one; but just in case we'll treat it as a list let legalHoldClients = filter ((== LegalHoldClientType) . clientType) clients -- maybe log if this isn't the case forM_ legalHoldClients (execDelete uid Nothing) - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserLegalHoldDisabled uid) + Intra.onUserEvent uid Nothing (UserLegalHoldDisabled uid) createAccessToken :: (Member JwtTools r, Member Now r, Member PublicKeyBundle r) => diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 4a222ec790..24b519b939 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -39,6 +39,8 @@ import Brig.App import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data +import Brig.Effects.GundeckAccess (GundeckAccess) +import Brig.Effects.UserQuery (UserQuery) import qualified Brig.IO.Intra as Intra import Brig.Types.Connection import Brig.Types.User.Event @@ -51,17 +53,22 @@ import Data.Qualified import Data.Range import qualified Data.UUID.V4 as UUID import Imports +import Polysemy +import Polysemy.Input import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Connection hiding (relationWithHistory) -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import Wire.API.Error import qualified Wire.API.Error.Brig as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -ensureIsActivated :: Local UserId -> MaybeT (AppT r) () +ensureIsActivated :: + Member (UserQuery p) r => + Local UserId -> + MaybeT (AppT r) () ensureIsActivated lusr = do - active <- lift . wrapClient $ Data.isActivated (tUnqualified lusr) + active <- lift . liftSem $ Data.isActivated (tUnqualified lusr) guard active ensureNotSameTeam :: Local UserId -> Local UserId -> (ConnectionM r) () @@ -72,6 +79,12 @@ ensureNotSameTeam self target = do throwE ConnectSameBindingTeamUsers createConnection :: + Members + '[ Input (Local ()), + GundeckAccess, + UserQuery p + ] + r => Local UserId -> ConnId -> Qualified UserId -> @@ -91,6 +104,13 @@ createConnection self con target = do target createConnectionToLocalUser :: + forall r p. + Members + '[ Input (Local ()), + GundeckAccess, + UserQuery p + ] + r => Local UserId -> ConnId -> Local UserId -> @@ -119,9 +139,9 @@ createConnectionToLocalUser self conn target = do o2s' <- wrapClient $ Data.insertConnection target (qUntagged self) PendingWithHistory qcnv e2o <- ConnectionUpdated o2s' (ucStatus <$> o2s) - <$> wrapClient (Data.lookupName (tUnqualified self)) + <$> liftSem (Data.getName (tUnqualified self)) let e2s = ConnectionUpdated s2o' (ucStatus <$> s2o) Nothing - mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] + liftSem $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] pure s2o' update :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) @@ -154,11 +174,11 @@ createConnectionToLocalUser self conn target = do then Data.updateConnection o2s BlockedWithHistory else Data.updateConnection o2s AcceptedWithHistory e2o <- - lift . wrapClient $ + lift . liftSem $ ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (tUnqualified self) + <$> Data.getName (tUnqualified self) let e2s = ConnectionUpdated s2o' (Just $ ucStatus s2o) Nothing - lift $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] + lift . liftSem $ mapM_ (Intra.onConnectionEvent (tUnqualified self) (Just conn)) [e2o, e2s] pure $ Existed s2o' resend :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (ResponseForExistedCreated UserConnection) @@ -178,15 +198,19 @@ createConnectionToLocalUser self conn target = do -- -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. -checkLegalholdPolicyConflict :: UserId -> UserId -> ExceptT ConnectionError (AppT r) () +checkLegalholdPolicyConflict :: + Members '[Input (Local ()), UserQuery p] r => + UserId -> + UserId -> + ExceptT ConnectionError (AppT r) () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = -- Does not fit into 'ExceptT', so throw in '(AppT r)'. Anyway at the time of writing -- this, users are guaranteed to exist when called from 'createConnectionToLocalUser'. maybe (throwM (errorToWai @'E.UserNotFound)) pure - status1 <- lift (wrapHttpClient $ getLegalHoldStatus uid1) >>= catchProfileNotFound - status2 <- lift (wrapHttpClient $ getLegalHoldStatus uid2) >>= catchProfileNotFound + status1 <- lift (getLegalHoldStatus uid1) >>= catchProfileNotFound + status2 <- lift (getLegalHoldStatus uid2) >>= catchProfileNotFound let oneway s1 s2 = case (s1, s2) of (LH.UserLegalHoldNoConsent, LH.UserLegalHoldNoConsent) -> pure () @@ -201,6 +225,7 @@ checkLegalholdPolicyConflict uid1 uid2 = do oneway status2 status1 updateConnection :: + Members '[GundeckAccess, UserQuery p] r => Local UserId -> Qualified UserId -> Relation -> @@ -220,6 +245,8 @@ updateConnection self other newStatus conn = -- because a connection between two team members can not exist in the first place. -- {#RefConnectionTeam} updateConnectionToLocalUser :: + forall r p. + Members '[GundeckAccess, UserQuery p] r => -- | From Local UserId -> -- | To @@ -274,7 +301,7 @@ updateConnectionToLocalUser self other newStatus conn = do -- invalid _ -> throwE $ InvalidTransition (tUnqualified self) let s2oUserConn = s2o' - lift . for_ s2oUserConn $ \c -> + lift . liftSem . for_ s2oUserConn $ \c -> let e2s = ConnectionUpdated c (Just $ ucStatus s2o) Nothing in Intra.onConnectionEvent (tUnqualified self) conn e2s pure s2oUserConn @@ -298,8 +325,8 @@ updateConnectionToLocalUser self other newStatus conn = do else Data.updateConnection o2s BlockedWithHistory e2o <- ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> wrapClient (Data.lookupName (tUnqualified self)) - Intra.onConnectionEvent (tUnqualified self) conn e2o + <$> liftSem (Data.getName (tUnqualified self)) + liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o lift . wrapClient $ Just <$> Data.updateConnection s2o AcceptedWithHistory block :: UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -326,14 +353,17 @@ updateConnectionToLocalUser self other newStatus conn = do then Data.updateConnection o2s AcceptedWithHistory else Data.updateConnection o2s BlockedWithHistory e2o :: ConnectionEvent <- - wrapClient $ + liftSem $ ConnectionUpdated o2s' (Just $ ucStatus o2s) - <$> Data.lookupName (tUnqualified self) + <$> Data.getName (tUnqualified self) -- TODO: is this correct? shouldnt o2s be sent to other? - Intra.onConnectionEvent (tUnqualified self) conn e2o + liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o lift . wrapClient $ Just <$> Data.updateConnection s2o (mkRelationWithHistory (error "impossible") new) - cancel :: UserConnection -> UserConnection -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) + cancel :: + UserConnection -> + UserConnection -> + ExceptT ConnectionError (AppT r) (Maybe UserConnection) cancel s2o o2s = do lift . Log.info $ logLocalConnection (tUnqualified self) (qUnqualified (ucTo s2o)) @@ -342,7 +372,7 @@ updateConnectionToLocalUser self other newStatus conn = do lift $ traverse_ (wrapHttp . Intra.blockConv lfrom conn) (ucConvId s2o) o2s' <- lift . wrapClient $ Data.updateConnection o2s CancelledWithHistory let e2o = ConnectionUpdated o2s' (Just $ ucStatus o2s) Nothing - lift $ Intra.onConnectionEvent (tUnqualified self) conn e2o + lift . liftSem $ Intra.onConnectionEvent (tUnqualified self) conn e2o change s2o Cancelled change :: UserConnection -> Relation -> ExceptT ConnectionError (AppT r) (Maybe UserConnection) @@ -377,7 +407,8 @@ mkRelationWithHistory oldRel = \case MissingLegalholdConsent -> error "impossible old relation" updateConnectionInternal :: - forall r. + forall r p. + Members '[GundeckAccess, UserQuery p] r => UpdateConnectionsInternal -> ExceptT ConnectionError (AppT r) () updateConnectionInternal = \case @@ -409,7 +440,7 @@ updateConnectionInternal = \case traverse_ (wrapHttp . Intra.blockConv lfrom Nothing) (ucConvId uconn) uconn' <- wrapClient $ Data.updateConnection uconn (mkRelationWithHistory (ucStatus uconn) MissingLegalholdConsent) let ev = ConnectionUpdated uconn' (Just $ ucStatus uconn) Nothing - Intra.onConnectionEvent (tUnqualified self) Nothing ev + liftSem $ Intra.onConnectionEvent (tUnqualified self) Nothing ev removeLHBlocksInvolving :: Local UserId -> ExceptT ConnectionError (AppT r) () removeLHBlocksInvolving self = @@ -444,14 +475,14 @@ updateConnectionInternal = \case void . lift . for (ucConvId uconn) $ wrapHttp . Intra.unblockConv lfrom Nothing uconnRevRel :: RelationWithHistory <- relationWithHistory lfrom (ucTo uconnRev) uconnRev' <- lift . wrapClient $ Data.updateConnection uconnRev (undoRelationHistory uconnRevRel) - connName <- lift . wrapClient $ Data.lookupName (tUnqualified lfrom) + connName <- lift . liftSem $ Data.getName (tUnqualified lfrom) let connEvent = ConnectionUpdated { ucConn = uconnRev', ucPrev = Just $ ucStatus uconnRev, ucName = connName } - lift $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent + lift . liftSem $ Intra.onConnectionEvent (ucFrom uconn) Nothing connEvent relationWithHistory :: Local UserId -> diff --git a/services/brig/src/Brig/API/Connection/Remote.hs b/services/brig/src/Brig/API/Connection/Remote.hs index 572b51eb3c..c44ae6c039 100644 --- a/services/brig/src/Brig/API/Connection/Remote.hs +++ b/services/brig/src/Brig/API/Connection/Remote.hs @@ -27,6 +27,7 @@ import Brig.API.Connection.Util (ConnectionM, checkLimit) import Brig.API.Types (ConnectionError (..)) import Brig.App import qualified Brig.Data.Connection as Data +import Brig.Effects.GundeckAccess import Brig.Federation.Client (sendConnectionAction) import qualified Brig.IO.Intra as Intra import Brig.Types.User.Event @@ -38,6 +39,7 @@ import Data.Qualified import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), UpsertOne2OneConversationRequest (..), UpsertOne2OneConversationResponse (uuorConvId)) import Imports import Network.Wai.Utilities.Error +import Polysemy import Wire.API.Connection import Wire.API.Federation.API.Brig ( NewConnectionResponse (..), @@ -141,13 +143,14 @@ updateOne2OneConv lUsr _mbConn remoteUser mbConvId rel actor = do -- -- Returns the connection, and whether it was updated or not. transitionTo :: + Members '[GundeckAccess] r => Local UserId -> Maybe ConnId -> Remote UserId -> Maybe UserConnection -> Maybe Relation -> Actor -> - (ConnectionM r) (ResponseForExistedCreated UserConnection, Bool) + ConnectionM r (ResponseForExistedCreated UserConnection, Bool) transitionTo self _ _ Nothing Nothing _ = -- This can only happen if someone tries to ignore as a first action on a -- connection. This shouldn't be possible. @@ -166,7 +169,7 @@ transitionTo self mzcon other Nothing (Just rel) actor = lift $ do qcnv -- send event - pushEvent self mzcon connection + liftSem $ pushEvent self mzcon connection pure (Created connection, True) transitionTo _self _zcon _other (Just connection) Nothing _actor = pure (Existed connection, False) transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do @@ -177,16 +180,22 @@ transitionTo self mzcon other (Just connection) (Just rel) actor = lift $ do connection' <- wrapClient $ Data.updateConnection connection (relationWithHistory rel) -- send event - pushEvent self mzcon connection' + liftSem $ pushEvent self mzcon connection' pure (Existed connection', True) -- | Send an event to the local user when the state of a connection changes. -pushEvent :: Local UserId -> Maybe ConnId -> UserConnection -> (AppT r) () +pushEvent :: + Members '[GundeckAccess] r => + Local UserId -> + Maybe ConnId -> + UserConnection -> + Sem r () pushEvent self mzcon connection = do let event = ConnectionUpdated connection Nothing Nothing Intra.onConnectionEvent (tUnqualified self) mzcon event performLocalAction :: + Members '[GundeckAccess] r => Local UserId -> Maybe ConnId -> Remote UserId -> @@ -234,6 +243,7 @@ performLocalAction self mzcon other mconnection action = do -- B connects & A reacts: Accepted Accepted -- @ performRemoteAction :: + Members '[GundeckAccess] r => Local UserId -> Remote UserId -> Maybe UserConnection -> @@ -251,6 +261,7 @@ performRemoteAction self other mconnection action = do reaction _ = Nothing createConnectionToRemoteUser :: + Members '[GundeckAccess] r => Local UserId -> ConnId -> Remote UserId -> @@ -260,6 +271,7 @@ createConnectionToRemoteUser self zcon other = do fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect updateConnectionToRemoteUser :: + Members '[GundeckAccess] r => Local UserId -> Remote UserId -> Relation -> diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index f6cbc7ea95..2690536ba0 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -19,8 +19,6 @@ module Brig.API.Federation (federationSitemap, FederationAPI) where -import Bilge.IO -import Bilge.RPC import qualified Brig.API.Client as API import Brig.API.Connection.Remote (performRemoteAction) import Brig.API.Error @@ -32,29 +30,28 @@ import Brig.API.Util (lookupSearchPolicy) import Brig.App import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data +import Brig.Effects.GundeckAccess (GundeckAccess) +import Brig.Effects.UserHandleStore +import Brig.Effects.UserQuery import Brig.IO.Intra (notify) import Brig.Types.User.Event import Brig.User.API.Handle -import Brig.User.Search.Index import qualified Brig.User.Search.SearchIndex as Q -import Cassandra (MonadClient) import Control.Error.Util -import Control.Monad.Catch (MonadMask) import Control.Monad.Trans.Except import Data.Domain import Data.Handle (Handle (..), parseHandle) import Data.Id (ClientId, UserId) import Data.List.NonEmpty (nonEmpty) -import Data.List1 import Data.Qualified import Data.Range import qualified Gundeck.Types.Push as Push import Imports import Network.Wai.Utilities.Error ((!>>)) +import Polysemy +import Polysemy.Input import Servant (ServerT) import Servant.API -import qualified System.Logger.Class as Log -import UnliftIO.Async (pooledForConcurrentlyN_) import Wire.API.Connection import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common @@ -71,24 +68,36 @@ import Wire.API.UserMap (UserMap) type FederationAPI = "federation" :> BrigApi -federationSitemap :: ServerT FederationAPI (Handler r) +federationSitemap :: + Members + '[ GundeckAccess, + Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + ServerT FederationAPI (Handler r) federationSitemap = Named @"api-version" (\_ _ -> pure versionInfo) - :<|> Named @"get-user-by-handle" (\d h -> wrapHttpClientE $ getUserByHandle d h) - :<|> Named @"get-users-by-ids" (\d us -> wrapHttpClientE $ getUsersByIds d us) + :<|> Named @"get-user-by-handle" getUserByHandle + :<|> Named @"get-users-by-ids" getUsersByIds :<|> Named @"claim-prekey" claimPrekey :<|> Named @"claim-prekey-bundle" claimPrekeyBundle :<|> Named @"claim-multi-prekey-bundle" claimMultiPrekeyBundle - :<|> Named @"search-users" (\d sr -> wrapHttpClientE $ searchUsers d sr) + :<|> Named @"search-users" searchUsers :<|> Named @"get-user-clients" getUserClients :<|> Named @"get-mls-clients" getMLSClients :<|> Named @"send-connection-action" sendConnectionAction :<|> Named @"on-user-deleted-connections" onUserDeleted :<|> Named @"claim-key-packages" fedClaimKeyPackages -sendConnectionAction :: Domain -> NewConnectionRequest -> Handler r NewConnectionResponse +sendConnectionAction :: + Members '[GundeckAccess, UserQuery p] r => + Domain -> + NewConnectionRequest -> + Handler r NewConnectionResponse sendConnectionAction originDomain NewConnectionRequest {..} = do - active <- lift $ wrapClient $ Data.isActivated ncrTo + active <- lift . liftSem $ Data.isActivated ncrTo if active then do self <- qualifyLocal ncrTo @@ -99,16 +108,15 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do else pure NewConnectionResponseUserNotActivated getUserByHandle :: - ( HasRequestId m, - Log.MonadLogger m, - MonadClient m, - MonadHttp m, - MonadMask m, - MonadReader Env m - ) => + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => Domain -> Handle -> - ExceptT Error m (Maybe UserProfile) + ExceptT Error (AppT r) (Maybe UserProfile) getUserByHandle domain handle = do searchPolicy <- lookupSearchPolicy domain @@ -120,7 +128,7 @@ getUserByHandle domain handle = do if not performHandleLookup then pure Nothing else lift $ do - maybeOwnerId <- API.lookupHandle handle + maybeOwnerId <- liftSem $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing @@ -128,18 +136,12 @@ getUserByHandle domain handle = do listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] getUsersByIds :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[Input (Local ()), UserQuery p] r => Domain -> [UserId] -> - ExceptT Error m [UserProfile] + ExceptT Error (AppT r) [UserProfile] getUsersByIds _ uids = - lift (API.lookupLocalProfiles Nothing uids) + lift $ API.lookupLocalProfiles Nothing uids claimPrekey :: Domain -> (UserId, ClientId) -> (Handler r) (Maybe ClientPrekey) claimPrekey _ (user, client) = do @@ -163,18 +165,16 @@ fedClaimKeyPackages domain ckpr = do -- only search by exact handle search, not in elasticsearch. -- (This decision may change in the future) searchUsers :: - forall m. - ( HasRequestId m, - Log.MonadLogger m, - MonadClient m, - MonadHttp m, - MonadIndexIO m, - MonadMask m, - MonadReader Env m - ) => + forall r p. + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => Domain -> SearchRequest -> - ExceptT Error m SearchResponse + ExceptT Error (AppT r) SearchResponse searchUsers domain (SearchRequest searchTerm) = do searchPolicy <- lift $ lookupSearchPolicy domain @@ -188,22 +188,26 @@ searchUsers domain (SearchRequest searchTerm) = do contacts <- go [] maxResults searches pure $ SearchResponse contacts searchPolicy where - go :: [Contact] -> Int -> [Int -> ExceptT Error m [Contact]] -> ExceptT Error m [Contact] + go :: + [Contact] -> + Int -> + [Int -> ExceptT Error (AppT r) [Contact]] -> + ExceptT Error (AppT r) [Contact] go contacts _ [] = pure contacts go contacts maxResult (search : searches) = do contactsNew <- search maxResult go (contacts <> contactsNew) (maxResult - length contactsNew) searches - fullSearch :: Int -> ExceptT Error m [Contact] + fullSearch :: Int -> ExceptT Error (AppT r) [Contact] fullSearch n | n > 0 = lift $ searchResults <$> Q.searchIndex Q.FederatedSearch searchTerm n | otherwise = pure [] - exactHandleSearch :: Int -> ExceptT Error m [Contact] + exactHandleSearch :: Int -> ExceptT Error (AppT r) [Contact] exactHandleSearch n | n > 0 = do let maybeHandle = parseHandle searchTerm - maybeOwnerId <- maybe (pure Nothing) (lift . API.lookupHandle) maybeHandle + maybeOwnerId <- maybe (pure Nothing) (lift . liftSem . API.lookupHandle) maybeHandle case maybeOwnerId of Nothing -> pure [] Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] @@ -216,7 +220,11 @@ getMLSClients :: Domain -> MLSClientsRequest -> Handler r (Set ClientInfo) getMLSClients _domain mcr = do Internal.getMLSClients (mcrUserId mcr) (mcrSignatureScheme mcr) -onUserDeleted :: Domain -> UserDeletedConnectionsNotification -> (Handler r) EmptyResponse +onUserDeleted :: + Members '[GundeckAccess] r => + Domain -> + UserDeletedConnectionsNotification -> + Handler r EmptyResponse onUserDeleted origDomain udcn = lift $ do let deletedUser = toRemoteUnsafe origDomain (udcnUser udcn) connections = udcnConnections udcn @@ -225,8 +233,7 @@ onUserDeleted origDomain udcn = lift $ do map csv2From . filter (\x -> csv2Status x == Accepted) <$> wrapClient (Data.lookupRemoteConnectionStatuses (fromRange connections) (fmap pure deletedUser)) - wrapHttp $ - pooledForConcurrentlyN_ 16 (nonEmpty acceptedLocals) $ \(List1 -> recipients) -> - notify event (tUnqualified deletedUser) Push.RouteDirect Nothing (pure recipients) + for_ (nonEmpty acceptedLocals) $ \recipients -> + liftSem $ notify event (tUnqualified deletedUser) Push.RouteDirect Nothing recipients wrapClient $ Data.deleteRemoteConnections deletedUser connections pure EmptyResponse diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index a69ebeac66..d37acfc744 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -40,11 +40,24 @@ import qualified Brig.Data.Client as Data import qualified Brig.Data.Connection as Data import qualified Brig.Data.MLS.KeyPackage as Data import qualified Brig.Data.User as Data +import Brig.Effects.ActivationKeyStore +import Brig.Effects.ActivationSupply import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) +import Brig.Effects.ClientStore (ClientStore) import Brig.Effects.CodeStore (CodeStore) +import Brig.Effects.CookieStore (CookieStore) +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess (GundeckAccess) import Brig.Effects.PasswordResetStore (PasswordResetStore) +import Brig.Effects.PasswordResetSupply (PasswordResetSupply) +import Brig.Effects.Twilio +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider @@ -78,11 +91,18 @@ import Network.Wai.Routing hiding (toList) import Network.Wai.Utilities as Utilities import Network.Wai.Utilities.ZAuth (zauthConnId, zauthUserId) import Polysemy +import Polysemy.Async +import Polysemy.Conc.Effect.Race +import qualified Polysemy.Error as P +import Polysemy.Input +import Polysemy.Resource +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio import Servant hiding (Handler, JSON, addHeader, respond) import Servant.Swagger.Internal.Orphans () import Servant.Swagger.UI import qualified System.Logger.Class as Log -import UnliftIO.Async +import UnliftIO.Async hiding (Async) import Wire.API.Connection import Wire.API.Error import qualified Wire.API.Error.Brig as E @@ -99,20 +119,40 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo +import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) --------------------------------------------------------------------------- -- Sitemap (servant) servantSitemap :: Members - '[ BlacklistStore, - UserPendingActivationStore p + '[ ActivationKeyStore, + ActivationSupply, + Async, + BlacklistStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetStore, + PasswordResetSupply, + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p, + VerificationCodeStore ] r => ServerT BrigIRoutes.API (Handler r) servantSitemap = ejpdAPI :<|> accountAPI :<|> mlsAPI :<|> getVerificationCode :<|> teamsAPI :<|> userAPI -ejpdAPI :: ServerT BrigIRoutes.EJPD_API (Handler r) +ejpdAPI :: + Members '[UserHandleStore, UserQuery p] r => + ServerT BrigIRoutes.EJPD_API (Handler r) ejpdAPI = Brig.User.EJPD.ejpdRequest :<|> Named @"get-account-conference-calling-config" getAccountConferenceCallingConfig @@ -137,8 +177,24 @@ mlsAPI = accountAPI :: Members - '[ BlacklistStore, - UserPendingActivationStore p + '[ ActivationKeyStore, + ActivationSupply, + Async, + BlacklistStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => ServerT BrigIRoutes.AccountAPI (Handler r) @@ -244,15 +300,22 @@ mapKeyPackageRefsInternal bundle = do for_ (kpbEntries bundle) $ \e -> Data.mapKeyPackageRef (kpbeRef e) (kpbeUser e) (kpbeClient e) -getVerificationCode :: UserId -> VerificationAction -> Handler r (Maybe Code.Value) +getVerificationCode :: + forall r p. + Members '[VerificationCodeStore, UserQuery p] r => + UserId -> + VerificationAction -> + Handler r (Maybe Code.Value) getVerificationCode uid action = do - user <- wrapClientE $ Api.lookupUser NoPendingInvitations uid + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + user <- lift . liftSem $ Api.lookupUser loc locale NoPendingInvitations uid maybe (pure Nothing) (lookupCode action) (userEmail =<< user) where - lookupCode :: VerificationAction -> Email -> (Handler r) (Maybe Code.Value) + lookupCode :: VerificationAction -> Email -> Handler r (Maybe Code.Value) lookupCode a e = do key <- Code.mkKey (Code.ForEmail e) - code <- wrapClientE $ Code.lookup key (Code.scopeFromAction a) + code <- lift . liftSem $ Code.getPendingCode key (Code.scopeFromAction a) pure $ Code.codeValue <$> code swaggerDocsAPI :: Servant.Server BrigIRoutes.SwaggerDocsAPI @@ -263,11 +326,32 @@ swaggerDocsAPI = swaggerSchemaUIServer BrigIRoutes.swaggerDoc sitemap :: Members - '[ CodeStore, - PasswordResetStore, - BlacklistStore, + '[ ActivationKeyStore, + ActivationSupply, + Async, BlacklistPhonePrefixStore, - UserPendingActivationStore p + BlacklistStore, + ClientStore, + CodeStore, + Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + PasswordResetStore, + PasswordResetSupply, + P.Error ReAuthError, + P.Error Twilio.ErrorResponse, + P.TinyLog, + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p, + VerificationCodeStore ] r => Routes a (Handler r) () @@ -433,25 +517,64 @@ sitemap = do -- Handlers -- | Add a client without authentication checks -addClientInternalH :: UserId ::: Maybe Bool ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> (Handler r) Response +addClientInternalH :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + UserId ::: Maybe Bool ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> + Handler r Response addClientInternalH (usr ::: mSkipReAuth ::: req ::: connId ::: _) = do new <- parseJsonBody req setStatus status201 . json <$> addClientInternal usr mSkipReAuth new connId -addClientInternal :: UserId -> Maybe Bool -> NewClient -> Maybe ConnId -> (Handler r) Client +addClientInternal :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + UserId -> + Maybe Bool -> + NewClient -> + Maybe ConnId -> + Handler r Client addClientInternal usr mSkipReAuth new connId = do let policy | mSkipReAuth == Just True = \_ _ -> False | otherwise = Data.reAuthForNewClients API.addClientWithReAuthPolicy policy usr connId Nothing new !>> clientError -legalHoldClientRequestedH :: UserId ::: JsonRequest LegalHoldClientRequest ::: JSON -> (Handler r) Response +legalHoldClientRequestedH :: + Members '[GalleyAccess, GundeckAccess] r => + UserId ::: JsonRequest LegalHoldClientRequest ::: JSON -> + Handler r Response legalHoldClientRequestedH (targetUser ::: req ::: _) = do clientRequest <- parseJsonBody req lift $ API.legalHoldClientRequested targetUser clientRequest pure $ setStatus status200 empty -removeLegalHoldClientH :: UserId ::: JSON -> (Handler r) Response +removeLegalHoldClientH :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess + ] + r => + UserId ::: JSON -> + Handler r Response removeLegalHoldClientH (uid ::: _) = do lift $ API.removeLegalHoldClient uid pure $ setStatus status200 empty @@ -475,12 +598,23 @@ internalListFullClients (UserSet usrs) = createUserNoVerify :: Members - '[ BlacklistStore, - UserPendingActivationStore p + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => NewUser -> - (Handler r) (Either RegisterError SelfProfile) + Handler r (Either RegisterError SelfProfile) createUserNoVerify uData = lift . runExceptT $ do result <- API.createUser uData let acc = createdAccount result @@ -494,7 +628,28 @@ createUserNoVerify uData = lift . runExceptT $ do in API.activate key code (Just uid) !>> activationErrorToRegisterError pure . SelfProfile $ usr -createUserNoVerifySpar :: NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) +createUserNoVerifySpar :: + Members + '[ ActivationKeyStore, + ActivationSupply, + Async, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetStore, + PasswordResetSupply, + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p + ] + r => + NewUserSpar -> + Handler r (Either CreateUserSparError SelfProfile) createUserNoVerifySpar uData = lift . runExceptT $ do result <- API.createUserSpar uData @@ -509,15 +664,39 @@ createUserNoVerifySpar uData = in API.activate key code (Just uid) !>> CreateUserSparRegistrationError . activationErrorToRegisterError pure . SelfProfile $ usr -deleteUserNoAuthH :: UserId -> (Handler r) Response +deleteUserNoAuthH :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + Handler r Response deleteUserNoAuthH uid = do - r <- lift $ wrapHttp $ API.ensureAccountDeleted uid + r <- lift $ API.ensureAccountDeleted uid case r of NoUser -> throwStd (errorToWai @'E.UserNotFound) AccountAlreadyDeleted -> pure $ setStatus ok200 empty AccountDeleted -> pure $ setStatus accepted202 empty -changeSelfEmailMaybeSendH :: Member BlacklistStore r => UserId ::: Bool ::: JsonRequest EmailUpdate -> (Handler r) Response +changeSelfEmailMaybeSendH :: + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserId ::: Bool ::: JsonRequest EmailUpdate -> + Handler r Response changeSelfEmailMaybeSendH (u ::: validate ::: req) = do email <- euEmail <$> parseJsonBody req changeSelfEmailMaybeSend u (if validate then ActuallySendEmail else DoNotSendEmail) email API.AllowSCIMUpdates >>= \case @@ -526,7 +705,20 @@ changeSelfEmailMaybeSendH (u ::: validate ::: req) = do data MaybeSendEmail = ActuallySendEmail | DoNotSendEmail -changeSelfEmailMaybeSend :: Member BlacklistStore r => UserId -> MaybeSendEmail -> Email -> API.AllowSCIMUpdates -> (Handler r) ChangeEmailResponse +changeSelfEmailMaybeSend :: + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + MaybeSendEmail -> + Email -> + API.AllowSCIMUpdates -> + Handler r ChangeEmailResponse changeSelfEmailMaybeSend u ActuallySendEmail email allowScim = do API.changeSelfEmail u email allowScim changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do @@ -534,21 +726,41 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do ChangeEmailIdempotent -> pure ChangeEmailResponseIdempotent ChangeEmailNeedsActivation _ -> pure ChangeEmailResponseNeedsActivation -listActivatedAccountsH :: JSON ::: Either (List UserId) (List Handle) ::: Bool -> (Handler r) Response +listActivatedAccountsH :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + JSON ::: Either (List UserId) (List Handle) ::: Bool -> + Handler r Response listActivatedAccountsH (_ ::: qry ::: includePendingInvitations) = do json <$> lift (listActivatedAccounts qry includePendingInvitations) -listActivatedAccounts :: Either (List UserId) (List Handle) -> Bool -> (AppT r) [UserAccount] +listActivatedAccounts :: + forall r p. + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + Either (List UserId) (List Handle) -> + Bool -> + AppT r [UserAccount] listActivatedAccounts elh includePendingInvitations = do Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) case elh of Left us -> byIds (fromList us) Right hs -> do - us <- mapM (wrapClient . API.lookupHandle) (fromList hs) + us <- mapM (liftSem . API.lookupHandle) (fromList hs) byIds (catMaybes us) where byIds :: [UserId] -> (AppT r) [UserAccount] - byIds uids = wrapClient (API.lookupAccounts uids) >>= filterM accountValid + byIds uids = do + locale <- setDefaultUserLocale <$> view settings + liftSem (API.lookupAccounts locale uids) >>= filterM accountValid accountValid :: UserAccount -> (AppT r) Bool accountValid account = case userIdentity . accountUser $ account of @@ -569,7 +781,10 @@ listActivatedAccounts elh includePendingInvitations = do (Deleted, _, _) -> pure True (Ephemeral, _, _) -> pure True -listAccountsByIdentityH :: JSON ::: Either Email Phone ::: Bool -> (Handler r) Response +listAccountsByIdentityH :: + Members '[Input (Local ()), UserKeyStore, UserQuery p] r => + JSON ::: Either Email Phone ::: Bool -> + Handler r Response listAccountsByIdentityH (_ ::: emailOrPhone ::: includePendingInvitations) = lift $ json @@ -590,14 +805,24 @@ instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] getPasswordResetCodeH :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => JSON ::: Either Email Phone -> (Handler r) Response getPasswordResetCodeH (_ ::: emailOrPhone) = do maybe (throwStd (errorToWai @'E.InvalidPasswordResetKey)) (pure . json) =<< lift (getPasswordResetCode emailOrPhone) getPasswordResetCode :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => Either Email Phone -> (AppT r) (Maybe GetPasswordResetCodeResp) getPasswordResetCode emailOrPhone = @@ -608,10 +833,20 @@ newtype GetPasswordResetCodeResp = GetPasswordResetCodeResp (PasswordResetKey, P instance ToJSON GetPasswordResetCodeResp where toJSON (GetPasswordResetCodeResp (k, c)) = object ["key" .= k, "code" .= c] -changeAccountStatusH :: UserId ::: JsonRequest AccountStatusUpdate -> (Handler r) Response +changeAccountStatusH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + UserId ::: JsonRequest AccountStatusUpdate -> + Handler r Response changeAccountStatusH (usr ::: req) = do status <- suStatus <$> parseJsonBody req - wrapHttpClientE (API.changeSingleAccountStatus usr status) !>> accountStatusError + API.changeSingleAccountStatus usr status !>> accountStatusError pure empty getAccountStatusH :: JSON ::: UserId -> (Handler r) Response @@ -645,12 +880,25 @@ getConnectionsStatus (ConnectionsStatusRequestV2 froms mtos mrel) = do where filterByRelation l rel = filter ((== rel) . csv2Status) l -revokeIdentityH :: Either Email Phone -> (Handler r) Response +revokeIdentityH :: + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + Either Email Phone -> + Handler r Response revokeIdentityH emailOrPhone = do lift $ API.revokeIdentity emailOrPhone pure $ setStatus status200 empty -updateConnectionInternalH :: JSON ::: JsonRequest UpdateConnectionsInternal -> (Handler r) Response +updateConnectionInternalH :: + Members '[GundeckAccess, UserQuery p] r => + JSON ::: JsonRequest UpdateConnectionsInternal -> + (Handler r) Response updateConnectionInternalH (_ ::: req) = do updateConn <- parseJsonBody req API.updateConnectionInternal updateConn !>> connError @@ -692,22 +940,28 @@ addPhonePrefixH (_ ::: req) = do void . lift $ API.phonePrefixInsert prefix pure empty -updateSSOIdH :: UserId ::: JSON ::: JsonRequest UserSSOId -> (Handler r) Response +updateSSOIdH :: + Members '[GalleyAccess, GundeckAccess] r => + UserId ::: JSON ::: JsonRequest UserSSOId -> + Handler r Response updateSSOIdH (uid ::: _ ::: req) = do ssoid :: UserSSOId <- parseJsonBody req success <- lift $ wrapClient $ Data.updateSSOId uid (Just ssoid) if success then do - lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) + lift $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOId = Just ssoid})) pure empty else pure . setStatus status404 $ plain "User does not exist or has no team." -deleteSSOIdH :: UserId ::: JSON -> (Handler r) Response +deleteSSOIdH :: + Members '[GalleyAccess, GundeckAccess] r => + UserId ::: JSON -> + Handler r Response deleteSSOIdH (uid ::: _) = do success <- lift $ wrapClient $ Data.updateSSOId uid Nothing if success then do - lift $ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) + lift $ Intra.onUserEvent uid Nothing (UserUpdated ((emptyUserUpdatedData uid) {eupSSOIdRemoved = True})) pure empty else pure . setStatus status404 $ plain "User does not exist or has no team." @@ -758,19 +1012,55 @@ getRichInfoMulti :: [UserId] -> (Handler r) [(UserId, RichInfo)] getRichInfoMulti uids = lift (wrapClient $ API.lookupRichInfoMultiUsers uids) -updateHandleH :: UserId ::: JSON ::: JsonRequest HandleUpdate -> (Handler r) Response +updateHandleH :: + Members + '[ Async, + GalleyAccess, + GundeckAccess, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + UserId ::: JSON ::: JsonRequest HandleUpdate -> + (Handler r) Response updateHandleH (uid ::: _ ::: body) = empty <$ (updateHandle uid =<< parseJsonBody body) -updateHandle :: UserId -> HandleUpdate -> (Handler r) () +updateHandle :: + Members + '[ Async, + GalleyAccess, + GundeckAccess, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + UserId -> + HandleUpdate -> + Handler r () updateHandle uid (HandleUpdate handleUpd) = do handle <- validateHandle handleUpd API.changeHandle uid Nothing handle API.AllowSCIMUpdates !>> changeHandleError -updateUserNameH :: UserId ::: JSON ::: JsonRequest NameUpdate -> (Handler r) Response +updateUserNameH :: + Members '[GalleyAccess, GundeckAccess, UserQuery p] r => + UserId ::: JSON ::: JsonRequest NameUpdate -> + (Handler r) Response updateUserNameH (uid ::: _ ::: body) = empty <$ (updateUserName uid =<< parseJsonBody body) -updateUserName :: UserId -> NameUpdate -> (Handler r) () +updateUserName :: + Members '[GalleyAccess, GundeckAccess, UserQuery p] r => + UserId -> + NameUpdate -> + (Handler r) () updateUserName uid (NameUpdate nameUpd) = do + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings name <- either (const $ throwStd (errorToWai @'E.InvalidUser)) pure $ mkName nameUpd let uu = UserUpdate @@ -779,11 +1069,14 @@ updateUserName uid (NameUpdate nameUpd) = do uupAssets = Nothing, uupAccentId = Nothing } - lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) >>= \case + lift (liftSem $ Data.lookupUser loc locale WithPendingInvitations uid) >>= \case Just _ -> API.updateUser uid Nothing uu API.AllowSCIMUpdates !>> updateProfileError Nothing -> throwStd (errorToWai @'E.InvalidUser) -checkHandleInternalH :: Text -> (Handler r) Response +checkHandleInternalH :: + Members '[UserHandleStore] r => + Text -> + Handler r Response checkHandleInternalH = API.checkHandle >=> \case API.CheckHandleInvalid -> throwE (StdError (errorToWai @'E.InvalidHandle)) diff --git a/services/brig/src/Brig/API/Properties.hs b/services/brig/src/Brig/API/Properties.hs index 00004eeb0d..8327ecd8b4 100644 --- a/services/brig/src/Brig/API/Properties.hs +++ b/services/brig/src/Brig/API/Properties.hs @@ -29,24 +29,41 @@ where import Brig.App import Brig.Data.Properties (PropertiesDataError) import qualified Brig.Data.Properties as Data +import Brig.Effects.GundeckAccess (GundeckAccess) import qualified Brig.IO.Intra as Intra import Brig.Types.User.Event import Control.Error import Data.Id import Imports +import Polysemy import Wire.API.Properties -setProperty :: UserId -> ConnId -> PropertyKey -> PropertyValue -> ExceptT PropertiesDataError (AppT r) () +setProperty :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + PropertyKey -> + PropertyValue -> + ExceptT PropertiesDataError (AppT r) () setProperty u c k v = do wrapClientE $ Data.insertProperty u k (propertyRaw v) - lift $ Intra.onPropertyEvent u c (PropertySet u k v) + lift . liftSem $ Intra.onPropertyEvent u c (PropertySet u k v) -deleteProperty :: UserId -> ConnId -> PropertyKey -> AppT r () +deleteProperty :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + PropertyKey -> + AppT r () deleteProperty u c k = do wrapClient $ Data.deleteProperty u k - Intra.onPropertyEvent u c (PropertyDeleted u k) + liftSem $ Intra.onPropertyEvent u c (PropertyDeleted u k) -clearProperties :: UserId -> ConnId -> AppT r () +clearProperties :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + AppT r () clearProperties u c = do wrapClient $ Data.clearProperties u - Intra.onPropertyEvent u c (PropertiesCleared u) + liftSem $ Intra.onPropertyEvent u c (PropertiesCleared u) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d94c6747b7..6bf675830f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -29,7 +29,7 @@ where import qualified Brig.API.Client as API import qualified Brig.API.Connection as API -import Brig.API.Error +import Brig.API.Error hiding (Error) import Brig.API.Handler import Brig.API.MLS.KeyPackages import qualified Brig.API.Properties as API @@ -45,13 +45,27 @@ import qualified Brig.Data.Connection as Data import Brig.Data.Nonce as Nonce import qualified Brig.Data.User as Data import qualified Brig.Data.UserKey as UserKey +import Brig.Effects.ActivationKeyStore +import Brig.Effects.ActivationSupply import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) +import Brig.Effects.BudgetStore +import Brig.Effects.ClientStore (ClientStore) import Brig.Effects.CodeStore (CodeStore) +import Brig.Effects.CookieStore (CookieStore) +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess (GundeckAccess) import Brig.Effects.JwtTools (JwtTools) import Brig.Effects.PasswordResetStore (PasswordResetStore) +import Brig.Effects.PasswordResetSupply (PasswordResetSupply) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) +import Brig.Effects.Twilio +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider @@ -96,11 +110,18 @@ import qualified Data.ZAuth.Token as ZAuth import FileEmbedLzma import Galley.Types.Teams (HiddenPerm (..), hasPermission) import Imports hiding (head) -import Network.Wai.Predicate hiding (result, setStatus) +import Network.Wai.Predicate hiding (Error, result, setStatus) import Network.Wai.Routing import Network.Wai.Utilities as Utilities import Network.Wai.Utilities.Swagger (mkSwaggerApi) import Polysemy +import Polysemy.Async +import Polysemy.Conc.Effect.Race +import qualified Polysemy.Error as P +import Polysemy.Input +import Polysemy.Resource +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio import Servant hiding (Handler, JSON, addHeader, respond) import qualified Servant import Servant.Swagger.Internal.Orphans () @@ -136,7 +157,9 @@ import qualified Wire.API.User.Password as Public import qualified Wire.API.User.RichInfo as Public import qualified Wire.API.UserMap as Public import qualified Wire.API.Wrapped as Public +import Wire.Sem.Concurrency import Wire.Sem.Now (Now) +import Wire.Sem.Paging -- User API ----------------------------------------------------------- @@ -161,18 +184,49 @@ swaggerDocsAPI Nothing = swaggerDocsAPI (Just maxBound) servantSitemap :: forall r p. Members - '[ BlacklistStore, + '[ ActivationKeyStore, + ActivationSupply, + Async, BlacklistPhonePrefixStore, - UserPendingActivationStore p, - PasswordResetStore, + BlacklistStore, + ClientStore, CodeStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), JwtTools, + Now, + PasswordResetStore, + PasswordResetSupply, + P.Error ReAuthError, + P.Error Twilio.ErrorResponse, + P.TinyLog, PublicKeyBundle, - Now + Race, + Resource, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p, + VerificationCodeStore ] r => ServerT BrigAPI (Handler r) -servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI :<|> propertiesAPI :<|> mlsAPI :<|> userHandleAPI :<|> searchAPI +servantSitemap = + userAPI + :<|> selfAPI + :<|> accountAPI + :<|> clientAPI + :<|> prekeyAPI + :<|> userClientAPI + :<|> connectionAPI + :<|> propertiesAPI + :<|> mlsAPI + :<|> userHandleAPI + :<|> searchAPI where userAPI :: ServerT UserAPI (Handler r) userAPI = @@ -288,11 +342,31 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey -- - MemberLeave event to members for all conversations the user was in (via galley) sitemap :: + forall r p. + Paging p => Members - '[ CodeStore, - PasswordResetStore, + '[ ActivationKeyStore, + ActivationSupply, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + BudgetStore, + ClientStore, + CodeStore, + Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + P.TinyLog, + PasswordResetStore, + PasswordResetSupply, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore ] r => Routes Doc.ApiBuilder (Handler r) () @@ -303,12 +377,31 @@ sitemap = do Calling.routesPublic apiDocs :: - forall r. + forall r p. + Paging p => Members - '[ CodeStore, - PasswordResetStore, + '[ ActivationKeyStore, + ActivationSupply, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + BudgetStore, + ClientStore, + CodeStore, + Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + P.TinyLog, + PasswordResetStore, + PasswordResetSupply, + Twilio, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore ] r => Routes Doc.ApiBuilder (Handler r) () @@ -325,7 +418,13 @@ apiDocs = --------------------------------------------------------------------------- -- Handlers -setProperty :: UserId -> ConnId -> Public.PropertyKey -> Public.RawPropertyValue -> Handler r () +setProperty :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + Public.PropertyKey -> + Public.RawPropertyValue -> + Handler r () setProperty u c key raw = do checkPropertyKey key val <- safeParsePropertyValue raw @@ -334,8 +433,8 @@ setProperty u c key raw = do checkPropertyKey :: Public.PropertyKey -> Handler r () checkPropertyKey k = do maxKeyLen <- fromMaybe defMaxKeyLen <$> view (settings . propertyMaxKeyLen) - let keyText = Ascii.toText (Public.propertyKeyName k) - when (Text.compareLength keyText (fromIntegral maxKeyLen) == GT) $ + let keyTxt = Ascii.toText (Public.propertyKeyName k) + when (Text.compareLength keyTxt (fromIntegral maxKeyLen) == GT) $ throwStd propertyKeyTooLarge -- | Parse a 'PropertyValue' from a bytestring. This is different from 'FromJSON' in that @@ -364,10 +463,19 @@ parseStoredPropertyValue raw = case propertyValueFromRaw raw of . Log.field "parse_error" e throwStd internalServerError -deleteProperty :: UserId -> ConnId -> Public.PropertyKey -> Handler r () +deleteProperty :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + Public.PropertyKey -> + Handler r () deleteProperty u c k = lift (API.deleteProperty u c k) -clearProperties :: UserId -> ConnId -> Handler r () +clearProperties :: + Members '[GundeckAccess] r => + UserId -> + ConnId -> + Handler r () clearProperties u c = lift (API.clearProperties u c) getProperty :: UserId -> Public.PropertyKey -> Handler r (Maybe Public.RawPropertyValue) @@ -418,7 +526,22 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do throwStd (errorToWai @'E.TooManyClients) API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError -addClient :: UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> (Handler r) NewClientResponse +addClient :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + UserId -> + ConnId -> + Maybe IpAddr -> + Public.NewClient -> + Handler r NewClientResponse addClient usr con ip new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ @@ -429,7 +552,21 @@ addClient usr con ip new = do clientResponse :: Public.Client -> NewClientResponse clientResponse client = Servant.addHeader (Public.clientId client) client -deleteClient :: UserId -> ConnId -> ClientId -> Public.RmClient -> (Handler r) () +deleteClient :: + Members + '[ ClientStore, + CookieStore, + GundeckAccess, + Input (Local ()), + P.Error ReAuthError, + UserQuery p + ] + r => + UserId -> + ConnId -> + ClientId -> + Public.RmClient -> + (Handler r) () deleteClient usr con clt body = API.rmClient usr con clt (Public.rmPassword body) !>> clientError @@ -474,16 +611,22 @@ getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) maybe (throwStd (errorToWai @'E.ClientNotFound)) (pure . Public.clientCapabilities) mclient -getRichInfo :: UserId -> UserId -> Handler r Public.RichInfoAssocList +getRichInfo :: + Member (UserQuery p) r => + UserId -> + UserId -> + Handler r Public.RichInfoAssocList getRichInfo self user = do + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings -- Check that both users exist and the requesting user is allowed to see rich info of the -- other user selfUser <- ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations self) + =<< lift (liftSem $ Data.lookupUser loc locale NoPendingInvitations self) otherUser <- ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations user) + =<< lift (liftSem $ Data.lookupUser loc locale NoPendingInvitations user) case (Public.userTeam selfUser, Public.userTeam otherUser) of (Just t1, Just t2) | t1 == t2 -> pure () _ -> throwStd insufficientTeamPermissions @@ -521,12 +664,23 @@ createAccessToken method uid cid proof = do -- | docs/reference/user/registration.md {#RefRegistration} createUser :: Members - '[ BlacklistStore, - UserPendingActivationStore p + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetStore, + PasswordResetSupply, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => Public.NewUserPublic -> - (Handler r) (Either Public.RegisterError Public.RegisterSuccess) + Handler r (Either Public.RegisterError Public.RegisterSuccess) createUser (Public.NewUserPublic new) = lift . runExceptT $ do API.checkRestrictedUserCreation new for_ (Public.newUserEmail new) $ mapExceptT wrapHttp . checkWhitelistWithError RegisterErrorWhitelistError . Left @@ -595,23 +749,44 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do Public.NewTeamMemberSSO _ -> Team.sendMemberWelcomeMail e t n l -getSelf :: UserId -> (Handler r) Public.SelfProfile +getSelf :: + Members '[Input (Local ()), UserQuery p] r => + UserId -> + Handler r Public.SelfProfile getSelf self = lift (API.lookupSelfProfile self) >>= ifNothing (errorToWai @'E.UserNotFound) -getUserUnqualifiedH :: UserId -> UserId -> (Handler r) (Maybe Public.UserProfile) +getUserUnqualifiedH :: + Members '[Input (Local ()), UserQuery p] r => + UserId -> + UserId -> + Handler r (Maybe Public.UserProfile) getUserUnqualifiedH self uid = do domain <- viewFederationDomain getUser self (Qualified uid domain) -getUser :: UserId -> Qualified UserId -> (Handler r) (Maybe Public.UserProfile) +getUser :: + Members '[Input (Local ()), UserQuery p] r => + UserId -> + Qualified UserId -> + Handler r (Maybe Public.UserProfile) getUser self qualifiedUserId = do lself <- qualifyLocal self - wrapHttpClientE $ API.lookupProfile lself qualifiedUserId !>> fedError + API.lookupProfile lself qualifiedUserId !>> fedError -- FUTUREWORK: Make servant understand that at least one of these is required -listUsersByUnqualifiedIdsOrHandles :: UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> (Handler r) [Public.UserProfile] +listUsersByUnqualifiedIdsOrHandles :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Maybe (CommaSeparatedList UserId) -> + Maybe (Range 1 4 (CommaSeparatedList Handle)) -> + Handler r [Public.UserProfile] listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do domain <- viewFederationDomain case (mUids, mHandles) of @@ -627,7 +802,17 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do in listUsersByIdsOrHandles self (Public.ListUsersByHandles qualifiedRangedList) (Nothing, Nothing) -> throwStd $ badRequest "at least one ids or handles must be provided" -listUsersByIdsOrHandles :: UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] +listUsersByIdsOrHandles :: + forall r p. + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Public.ListUsersQuery -> + Handler r [Public.UserProfile] listUsersByIdsOrHandles self q = do lself <- qualifyLocal self foundUsers <- case q of @@ -643,11 +828,11 @@ listUsersByIdsOrHandles self q = do where getIds :: [Handle] -> (Handler r) [Qualified UserId] getIds localHandles = do - localUsers <- catMaybes <$> traverse (lift . wrapClient . API.lookupHandle) localHandles + localUsers <- catMaybes <$> traverse (lift . liftSem . API.lookupHandle) localHandles domain <- viewFederationDomain pure $ map (`Qualified` domain) localUsers byIds :: Local UserId -> [Qualified UserId] -> (Handler r) [Public.UserProfile] - byIds lself uids = wrapHttpClientE (API.lookupProfiles lself uids) !>> fedError + byIds lself uids = API.lookupProfiles lself uids !>> fedError newtype GetActivationCodeResp = GetActivationCodeResp (Public.ActivationKey, Public.ActivationCode) @@ -655,15 +840,31 @@ newtype GetActivationCodeResp instance ToJSON GetActivationCodeResp where toJSON (GetActivationCodeResp (k, c)) = object ["key" .= k, "code" .= c] -updateUser :: UserId -> ConnId -> Public.UserUpdate -> (Handler r) (Maybe Public.UpdateProfileError) +updateUser :: + Members + '[ GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + UserId -> + ConnId -> + Public.UserUpdate -> + (Handler r) (Maybe Public.UpdateProfileError) updateUser uid conn uu = do eithErr <- lift $ runExceptT $ API.updateUser uid (Just conn) uu API.ForbidSCIMUpdates pure $ either Just (const Nothing) eithErr changePhone :: Members - '[ BlacklistStore, - BlacklistPhonePrefixStore + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + BlacklistPhonePrefixStore, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p ] r => UserId -> @@ -672,30 +873,66 @@ changePhone :: (Handler r) (Maybe Public.ChangePhoneError) changePhone u _ (Public.puPhone -> phone) = lift . exceptTToMaybe $ do (adata, pn) <- API.changePhone u phone - loc <- lift $ wrapClient $ API.lookupLocale u + defLocale <- setDefaultUserLocale <$> view settings + loc <- lift . liftSem $ API.lookupLocale defLocale u let apair = (activationKey adata, activationCode adata) lift . wrapClient $ sendActivationSms pn apair loc -removePhone :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) +removePhone :: + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + UserId -> + ConnId -> + Handler r (Maybe Public.RemoveIdentityError) removePhone self conn = lift . exceptTToMaybe $ API.removePhone self conn -removeEmail :: UserId -> ConnId -> (Handler r) (Maybe Public.RemoveIdentityError) +removeEmail :: + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + UserId -> + ConnId -> + Handler r (Maybe Public.RemoveIdentityError) removeEmail self conn = lift . exceptTToMaybe $ API.removeEmail self conn checkPasswordExists :: UserId -> (Handler r) Bool checkPasswordExists = fmap isJust . lift . wrapClient . API.lookupPassword -changePassword :: UserId -> Public.PasswordChange -> (Handler r) (Maybe Public.ChangePasswordError) +changePassword :: + Members '[CookieStore, UserQuery p] r => + UserId -> + Public.PasswordChange -> + Handler r (Maybe Public.ChangePasswordError) changePassword u cp = lift . exceptTToMaybe $ API.changePassword u cp -changeLocale :: UserId -> ConnId -> Public.LocaleUpdate -> (Handler r) () +changeLocale :: + Members '[GalleyAccess, GundeckAccess] r => + UserId -> + ConnId -> + Public.LocaleUpdate -> + Handler r () changeLocale u conn l = lift $ API.changeLocale u conn l -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandle :: UserId -> Text -> Handler r () +checkHandle :: + Members '[UserHandleStore] r => + UserId -> + Text -> + Handler r () checkHandle _uid hndl = API.checkHandle hndl >>= \case API.CheckHandleInvalid -> throwStd (errorToWai @'E.InvalidHandle) @@ -704,40 +941,82 @@ checkHandle _uid hndl = -- | (zusr is ignored by this handler, ie. checking handles is allowed as long as you have -- *any* account.) -checkHandles :: UserId -> Public.CheckHandles -> Handler r [Handle] +checkHandles :: + Members '[UserHandleStore] r => + UserId -> + Public.CheckHandles -> + Handler r [Handle] checkHandles _ (Public.CheckHandles hs num) = do let handles = mapMaybe parseHandle (fromRange hs) - lift $ wrapHttpClient $ API.checkHandles handles (fromRange num) + lift . liftSem $ API.checkHandles handles (fromRange num) -- | This endpoint returns UserHandleInfo instead of UserProfile for backwards -- compatibility, whereas the corresponding qualified endpoint (implemented by -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. -getHandleInfoUnqualifiedH :: UserId -> Handle -> (Handler r) (Maybe Public.UserHandleInfo) +getHandleInfoUnqualifiedH :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Handle -> + Handler r (Maybe Public.UserHandleInfo) getHandleInfoUnqualifiedH self handle = do domain <- viewFederationDomain Public.UserHandleInfo . Public.profileQualifiedId <$$> Handle.getHandleInfo self (Qualified handle domain) -changeHandle :: UserId -> ConnId -> Public.HandleUpdate -> (Handler r) (Maybe Public.ChangeHandleError) +changeHandle :: + Members + '[ Async, + GalleyAccess, + GundeckAccess, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + UserId -> + ConnId -> + Public.HandleUpdate -> + (Handler r) (Maybe Public.ChangeHandleError) changeHandle u conn (Public.HandleUpdate h) = lift . exceptTToMaybe $ do handle <- maybe (throwError Public.ChangeHandleInvalid) pure $ parseHandle h API.changeHandle u (Just conn) handle API.ForbidSCIMUpdates beginPasswordReset :: - Members '[PasswordResetStore] r => + Members + '[ P.TinyLog, + PasswordResetStore, + UserKeyStore, + UserQuery p + ] + r => Public.NewPasswordReset -> (Handler r) () beginPasswordReset (Public.NewPasswordReset target) = do checkWhitelist target (u, pair) <- API.beginPasswordReset target !>> pwResetError - loc <- lift $ wrapClient $ API.lookupLocale u + defLocale <- setDefaultUserLocale <$> view settings + loc <- lift . liftSem $ API.lookupLocale defLocale u lift $ case target of Left email -> sendPasswordResetMail email pair loc Right phone -> wrapClient $ sendPasswordResetSms phone pair loc completePasswordReset :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ CodeStore, + CookieStore, + PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => Public.CompletePasswordReset -> (Handler r) () completePasswordReset req = do @@ -747,8 +1026,14 @@ completePasswordReset req = do -- docs/reference/user/registration.md {#RefRegistration} sendActivationCode :: Members - '[ BlacklistStore, - BlacklistPhonePrefixStore + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + BlacklistPhonePrefixStore, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p ] r => Public.SendActivationCode -> @@ -773,23 +1058,55 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) +createConnectionUnqualified :: + Members + '[ GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId -> + ConnId -> + Public.ConnectionRequest -> + (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) createConnectionUnqualified self conn cr = do lself <- qualifyLocal self target <- qualifyLocal (Public.crUser cr) API.createConnection lself conn (qUntagged target) !>> connError -createConnection :: UserId -> ConnId -> Qualified UserId -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) +createConnection :: + Members + '[ GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId -> + ConnId -> + Qualified UserId -> + (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) createConnection self conn target = do lself <- qualifyLocal self API.createConnection lself conn target !>> connError -updateLocalConnection :: UserId -> ConnId -> UserId -> Public.ConnectionUpdate -> (Handler r) (Public.UpdateResult Public.UserConnection) +updateLocalConnection :: + Members '[GundeckAccess, UserQuery p] r => + UserId -> + ConnId -> + UserId -> + Public.ConnectionUpdate -> + (Handler r) (Public.UpdateResult Public.UserConnection) updateLocalConnection self conn other update = do lother <- qualifyLocal other updateConnection self conn (qUntagged lother) update -updateConnection :: UserId -> ConnId -> Qualified UserId -> Public.ConnectionUpdate -> (Handler r) (Public.UpdateResult Public.UserConnection) +updateConnection :: + Members '[GundeckAccess, UserQuery p] r => + UserId -> + ConnId -> + Qualified UserId -> + Public.ConnectionUpdate -> + (Handler r) (Public.UpdateResult Public.UserConnection) updateConnection self conn other update = do let newStatus = Public.cuStatus update lself <- qualifyLocal self @@ -855,16 +1172,56 @@ getConnection self other = do lift . wrapClient $ Data.lookupConnection lself other deleteSelfUser :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => UserId -> Public.DeleteUser -> - (Handler r) (Maybe Code.Timeout) + Handler r (Maybe Code.Timeout) deleteSelfUser u body = API.deleteSelfUser u (Public.deleteUserPassword body) !>> deleteUserError -verifyDeleteUser :: Public.VerifyDeleteUser -> Handler r () +verifyDeleteUser :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + Public.VerifyDeleteUser -> + Handler r () verifyDeleteUser body = API.verifyDeleteUser body !>> deleteUserError -updateUserEmail :: Member BlacklistStore r => UserId -> UserId -> Public.EmailUpdate -> (Handler r) () +updateUserEmail :: + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + UserId -> + Public.EmailUpdate -> + Handler r () updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do maybeZuserTeamId <- lift $ wrapClient $ Data.lookupUserTeam zuserId whenM (not <$> assertHasPerm maybeZuserTeamId) $ throwStd insufficientTeamPermissions @@ -887,16 +1244,49 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do -- activation -activate :: Public.ActivationKey -> Public.ActivationCode -> (Handler r) ActivationRespWithStatus +activate :: + Members + '[ ActivationKeyStore, + ActivationSupply, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserQuery p + ] + r => + Public.ActivationKey -> + Public.ActivationCode -> + Handler r ActivationRespWithStatus activate k c = do let activationRequest = Public.Activate (Public.ActivateKey k) c False activateKey activationRequest -- docs/reference/user/activation.md {#RefActivationSubmit} -activateKey :: Public.Activate -> (Handler r) ActivationRespWithStatus +activateKey :: + Members + '[ ActivationKeyStore, + ActivationSupply, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserQuery p + ] + r => + Public.Activate -> + Handler r ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) | dryrun = do - wrapClientE (API.preverify tgt code) !>> actError + liftSemE (API.preverify tgt code) !>> actError pure ActivationRespDryRun | otherwise = do result <- API.activate tgt code Nothing !>> actError @@ -907,7 +1297,17 @@ activateKey (Public.Activate tgt code dryrun) respond (Just ident) x = ActivationResp $ Public.ActivationResponse ident x respond Nothing _ = ActivationRespSuccessNoIdent -sendVerificationCode :: Public.SendVerificationCode -> (Handler r) () +sendVerificationCode :: + forall r p. + Members + '[ Input (Local ()), + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + Public.SendVerificationCode -> + Handler r () sendVerificationCode req = do let email = Public.svcEmail req let action = Public.svcAction req @@ -916,22 +1316,24 @@ sendVerificationCode req = do case (mbAccount, featureEnabled) of (Just account, True) -> do gen <- Code.mk6DigitGen $ Code.ForEmail email - timeout <- setVerificationTimeout <$> view settings + tout <- setVerificationTimeout <$> view settings code <- Code.generate gen (Code.scopeFromAction action) (Code.Retries 3) - timeout + tout (Just $ toUUID $ Public.userId $ accountUser account) + -- lift . liftSem $ Code.insertCode code tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled sendMail email (Code.codeValue code) (Just $ Public.userLocale $ accountUser account) action _ -> pure () where - getAccount :: Public.Email -> (Handler r) (Maybe UserAccount) + getAccount :: Public.Email -> Handler r (Maybe UserAccount) getAccount email = lift $ do - mbUserId <- wrapClient . UserKey.lookupKey $ UserKey.userEmailKey email - join <$> wrapClient (Data.lookupAccount `traverse` mbUserId) + locale <- setDefaultUserLocale <$> view settings + mbUserId <- liftSem . UserKey.getKey $ UserKey.userEmailKey email + join <$> liftSem (Data.lookupAccount locale `traverse` mbUserId) sendMail :: Public.Email -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = @@ -951,7 +1353,15 @@ deprecatedOnboarding :: UserId -> JsonValue -> (Handler r) DeprecatedMatchingRes deprecatedOnboarding _ _ = pure DeprecatedMatchingResult deprecatedCompletePasswordReset :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ CodeStore, + CookieStore, + PasswordResetStore, + PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => Public.PasswordResetKey -> Public.PasswordReset -> (Handler r) () diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 57acbd8697..f0e2a19f18 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -35,7 +35,7 @@ import Brig.Data.Activation (Activation (..), ActivationError (..)) import Brig.Data.Client (ClientDataError (..)) import Brig.Data.Properties (PropertiesDataError (..)) import Brig.Data.User (AuthError (..), ReAuthError (..)) -import Brig.Data.UserKey (UserKey, foldKey) +import Brig.Types.Common import Brig.Types.Intra import Data.Code import Data.Id diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ea3932461f..9d7897ebba 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -30,7 +30,7 @@ module Brig.API.User changeHandle, CheckHandleResp (..), checkHandle, - lookupHandle, + Brig.Effects.UserHandleStore.lookupHandle, changeManagedBy, changeAccountStatus, changeSingleAccountStatus, @@ -42,7 +42,7 @@ module Brig.API.User lookupProfiles, lookupLocalProfiles, getLegalHoldStatus, - Data.lookupName, + Data.getName, Data.lookupLocale, Data.lookupUser, Data.lookupRichInfo, @@ -90,8 +90,6 @@ module Brig.API.User ) where -import Bilge.IO (MonadHttp) -import Bilge.RPC (HasRequestId) import qualified Brig.API.Error as Error import qualified Brig.API.Handler as API (Handler, UserNotAllowedToJoinTeam (..)) import Brig.API.Types @@ -108,20 +106,33 @@ import Brig.Data.User import qualified Brig.Data.User as Data import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data +import Brig.Effects.ActivationKeyStore (ActivationKeyStore) +import Brig.Effects.ActivationSupply (ActivationSupply) import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import qualified Brig.Effects.BlacklistPhonePrefixStore as BlacklistPhonePrefixStore import Brig.Effects.BlacklistStore (BlacklistStore) import qualified Brig.Effects.BlacklistStore as BlacklistStore -import Brig.Effects.CodeStore (CodeStore) -import qualified Brig.Effects.CodeStore as E +import Brig.Effects.ClientStore +import Brig.Effects.CookieStore (CookieStore) +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess import Brig.Effects.PasswordResetStore (PasswordResetStore) import qualified Brig.Effects.PasswordResetStore as E +import Brig.Effects.PasswordResetSupply (PasswordResetSupply) +import qualified Brig.Effects.PasswordResetSupply as E +import Brig.Effects.Twilio (Twilio) +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore (UserKeyStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import qualified Brig.Effects.UserPendingActivationStore as UserPendingActivationStore +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore import qualified Brig.Federation.Client as Federation import qualified Brig.IO.Intra as Intra import qualified Brig.InternalEvent.Types as Internal import Brig.Options hiding (Timeout, internalEvents) +import qualified Brig.Options as Opt import Brig.Password import qualified Brig.Queue as Queue import qualified Brig.Team.DB as Team @@ -133,10 +144,10 @@ import Brig.Types.User (HavePendingInvitations (..), ManagedByUpdate (..), Passw import Brig.Types.User.Event import Brig.User.Auth.Cookie (listCookies, revokeAllCookies) import Brig.User.Email -import Brig.User.Handle +import Brig.User.Handle hiding (lookupHandle) import Brig.User.Handle.Blacklist import Brig.User.Phone -import Brig.User.Search.Index (MonadIndexIO, reindex) +import Brig.User.Search.Index (reindex) import qualified Brig.User.Search.TeamSize as TeamSize import Cassandra import Control.Arrow ((&&&)) @@ -151,7 +162,7 @@ import Data.Id as Id import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) import Data.List.Extra -import Data.List1 as List1 (List1, singleton) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as Map import qualified Data.Metrics as Metrics import Data.Misc (PlainTextPassword (..)) @@ -163,10 +174,16 @@ import qualified Galley.Types.Teams.Intra as Team import Imports import Network.Wai.Utilities import Polysemy +import Polysemy.Async +import Polysemy.Conc.Effect.Race (Race) +import qualified Polysemy.Error as P +import Polysemy.Input +import Polysemy.Resource hiding (onException) +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio import System.Logger.Class (MonadLogger) import qualified System.Logger.Class as Log import System.Logger.Message -import UnliftIO.Async import Wire.API.Connection import Wire.API.Error import qualified Wire.API.Error.Brig as E @@ -184,6 +201,7 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo +import Wire.Sem.Concurrency data AllowSCIMUpdates = AllowSCIMUpdates @@ -210,9 +228,17 @@ identityErrorToBrigError = \case IdentityErrorBlacklistedPhone -> Error.StdError $ errorToWai @'E.BlacklistedPhone IdentityErrorUserKeyExists -> Error.StdError $ errorToWai @'E.UserKeyExists -verifyUniquenessAndCheckBlacklist :: Member BlacklistStore r => UserKey -> ExceptT IdentityError (AppT r) () +verifyUniquenessAndCheckBlacklist :: + Members + '[ BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserKey -> + ExceptT IdentityError (AppT r) () verifyUniquenessAndCheckBlacklist uk = do - wrapClientE $ checkKey Nothing uk + liftSemE $ checkKey Nothing uk blacklisted <- lift $ liftSem $ BlacklistStore.exists uk when blacklisted $ throwE (foldKey (const IdentityErrorBlacklistedEmail) (const IdentityErrorBlacklistedPhone) uk) @@ -222,7 +248,21 @@ verifyUniquenessAndCheckBlacklist uk = do unless av $ throwE IdentityErrorUserKeyExists -createUserSpar :: NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult +createUserSpar :: + forall r p. + Members + '[ Async, + GalleyAccess, + GundeckAccess, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + NewUserSpar -> + ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do let handle' = newUserSparHandle new new' = newUserFromSpar new @@ -236,12 +276,12 @@ createUserSpar new = do let uid = userId (accountUser account) -- FUTUREWORK: make this transactional if possible - wrapClient $ Data.insertAccount account Nothing pw False + liftSem $ Data.insertAccount account Nothing pw False case unRichInfo <$> newUserSparRichInfo new of Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do wrapHttp $ Intra.createSelfConv uid - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -271,7 +311,7 @@ createUserSpar new = do unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do - wrapClient $ activateUser uid ident + liftSem $ activateUser uid ident void $ onActivated (AccountActivated account) Log.info $ field "user" (toByteString uid) @@ -284,8 +324,19 @@ createUserSpar new = do createUser :: forall r p. Members - '[ BlacklistStore, - UserPendingActivationStore p + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => NewUser -> @@ -310,7 +361,8 @@ createUser new = do Nothing -> pure (Nothing, Nothing, Nothing) let mbInv = Team.inInvitation . fst <$> teamInvitation - mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> wrapClient $ Data.lookupAccount (Id uuid)) + locale <- setDefaultUserLocale <$> view settings + mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> liftSem $ Data.lookupAccount locale (Id uuid)) let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -341,9 +393,9 @@ createUser new = do Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.createUser") Log.info $ field "user" (toByteString uid) . msg (val "Creating user") - wrapClient $ Data.insertAccount account Nothing pw False + liftSem $ Data.insertAccount account Nothing pw False wrapHttp $ Intra.createSelfConv uid - wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -388,7 +440,9 @@ createUser new = do where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT RegisterError (AppT r) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: + NewUser -> + ExceptT RegisterError (AppT r) (Maybe Email, Maybe Phone) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> @@ -402,7 +456,7 @@ createUser new = do maybe (throwE RegisterErrorInvalidPhone) pure - =<< lift (wrapClient $ validatePhone p) + =<< lift (liftSem $ validatePhone p) for_ (catMaybes [userEmailKey <$> email, userPhoneKey <$> phone]) $ \k -> verifyUniquenessAndCheckBlacklist k !>> identityErrorToRegisterError @@ -445,7 +499,8 @@ createUser new = do ExceptT RegisterError (AppT r) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) - ok <- lift . wrapClient $ Data.claimKey uk uid + d <- view digestSHA256 + ok <- lift . liftSem $ Data.claimKey d uk uid unless ok $ throwE RegisterErrorUserKeyExists let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) @@ -454,7 +509,7 @@ createUser new = do unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do - wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) + liftSem $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) Log.info $ field "user" (toByteString uid) @@ -471,7 +526,7 @@ createUser new = do unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do - wrapClient $ activateUser uid ident + liftSem $ activateUser uid ident void $ onActivated (AccountActivated account) Log.info $ field "user" (toByteString uid) @@ -486,7 +541,7 @@ createUser new = do fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do timeout <- setActivationTimeout <$> view settings - edata <- lift . wrapClient $ Data.newActivation ek timeout (Just uid) + edata <- lift . liftSem $ Data.newActivation ek timeout (Just uid) lift . Log.info $ field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey edata) @@ -505,7 +560,7 @@ createUser new = do fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of Nothing -> do timeout <- setActivationTimeout <$> view settings - pdata <- lift . wrapClient $ Data.newActivation pk timeout (Just uid) + pdata <- lift . liftSem $ Data.newActivation pk timeout (Just uid) lift . Log.info $ field "user" (toByteString uid) . field "activation.key" (toByteString $ activationKey pdata) @@ -527,7 +582,9 @@ initAccountFeatureConfig uid = do createUserInviteViaScim :: Members '[ BlacklistStore, - UserPendingActivationStore p + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => UserId -> @@ -553,7 +610,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = do -- would not produce an identity, and so we won't have the email address to construct -- the SCIM user. True - lift . wrapClient $ Data.insertAccount account Nothing Nothing activated + lift . liftSem $ Data.insertAccount account Nothing Nothing activated pure account @@ -571,10 +628,23 @@ checkRestrictedUserCreation new = do ------------------------------------------------------------------------------- -- Update Profile -updateUser :: UserId -> Maybe ConnId -> UserUpdate -> AllowSCIMUpdates -> ExceptT UpdateProfileError (AppT r) () +updateUser :: + Members + '[ GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + UserId -> + Maybe ConnId -> + UserUpdate -> + AllowSCIMUpdates -> + ExceptT UpdateProfileError (AppT r) () updateUser uid mconn uu allowScim = do + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings for_ (uupName uu) $ \newName -> do - mbUser <- lift . wrapClient $ Data.lookupUser WithPendingInvitations uid + mbUser <- lift . liftSem $ Data.lookupUser loc locale WithPendingInvitations uid user <- maybe (throwE ProfileNotFound) pure mbUser unless ( userManagedBy user /= ManagedByScim @@ -584,32 +654,68 @@ updateUser uid mconn uu allowScim = do $ throwE DisplayNameManagedByScim lift $ do wrapClient $ Data.updateUser uid uu - wrapHttpClient $ Intra.onUserEvent uid mconn (profileUpdated uid uu) + Intra.onUserEvent uid mconn (profileUpdated uid uu) ------------------------------------------------------------------------------- -- Update Locale -changeLocale :: UserId -> ConnId -> LocaleUpdate -> (AppT r) () +changeLocale :: + Members + '[ GalleyAccess, + GundeckAccess + ] + r => + UserId -> + ConnId -> + LocaleUpdate -> + AppT r () changeLocale uid conn (LocaleUpdate loc) = do wrapClient $ Data.updateLocale uid loc - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) + Intra.onUserEvent uid (Just conn) (localeUpdate uid loc) ------------------------------------------------------------------------------- -- Update ManagedBy -changeManagedBy :: UserId -> ConnId -> ManagedByUpdate -> (AppT r) () +changeManagedBy :: + Members + '[ GalleyAccess, + GundeckAccess + ] + r => + UserId -> + ConnId -> + ManagedByUpdate -> + AppT r () changeManagedBy uid conn (ManagedByUpdate mb) = do wrapClient $ Data.updateManagedBy uid mb - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) + Intra.onUserEvent uid (Just conn) (managedByUpdate uid mb) -------------------------------------------------------------------------------- -- Change Handle -changeHandle :: UserId -> Maybe ConnId -> Handle -> AllowSCIMUpdates -> ExceptT ChangeHandleError (AppT r) () +changeHandle :: + Members + '[ Async, + GalleyAccess, + GundeckAccess, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Maybe ConnId -> + Handle -> + AllowSCIMUpdates -> + ExceptT ChangeHandleError (AppT r) () changeHandle uid mconn hdl allowScim = do when (isBlacklistedHandle hdl) $ throwE ChangeHandleInvalid - usr <- lift $ wrapClient $ Data.lookupUser WithPendingInvitations uid + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + usr <- lift . liftSem $ Data.lookupUser loc locale WithPendingInvitations uid case usr of Nothing -> throwE ChangeHandleNoIdentity Just u -> do @@ -624,10 +730,10 @@ changeHandle uid mconn hdl allowScim = do claim u = do unless (isJust (userIdentity u)) $ throwE ChangeHandleNoIdentity - claimed <- lift . wrapClient $ claimHandle (userId u) (userHandle u) hdl + claimed <- lift . liftSem $ claimHandle (userId u) (userHandle u) hdl unless claimed $ throwE ChangeHandleExists - lift $ wrapHttpClient $ Intra.onUserEvent uid mconn (handleUpdated uid hdl) + lift $ Intra.onUserEvent uid mconn (handleUpdated uid hdl) -------------------------------------------------------------------------------- -- Check Handle @@ -637,10 +743,13 @@ data CheckHandleResp | CheckHandleFound | CheckHandleNotFound -checkHandle :: Text -> API.Handler r CheckHandleResp +checkHandle :: + Members '[UserHandleStore] r => + Text -> + API.Handler r CheckHandleResp checkHandle uhandle = do xhandle <- validateHandle uhandle - owner <- lift . wrapClient $ lookupHandle xhandle + owner <- lift . liftSem $ lookupHandle xhandle if | isJust owner -> -- Handle is taken (=> getHandleInfo will return 200) @@ -659,7 +768,11 @@ checkHandle uhandle = do -------------------------------------------------------------------------------- -- Check Handles -checkHandles :: MonadClient m => [Handle] -> Word -> m [Handle] +checkHandles :: + Member UserHandleStore r => + [Handle] -> + Word -> + Sem r [Handle] checkHandles check num = reverse <$> collectFree [] check num where collectFree free _ 0 = pure free @@ -678,7 +791,19 @@ checkHandles check num = reverse <$> collectFree [] check num -- | Call 'changeEmail' and process result: if email changes to itself, succeed, if not, send -- validation email. -changeSelfEmail :: Member BlacklistStore r => UserId -> Email -> AllowSCIMUpdates -> ExceptT Error.Error (AppT r) ChangeEmailResponse +changeSelfEmail :: + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + Email -> + AllowSCIMUpdates -> + ExceptT Error.Error (AppT r) ChangeEmailResponse changeSelfEmail u email allowScim = do changeEmail u email allowScim !>> Error.changeEmailError >>= \case ChangeEmailIdempotent -> @@ -698,7 +823,19 @@ changeSelfEmail u email allowScim = do (userIdentity usr) -- | Prepare changing the email (checking a number of invariants). -changeEmail :: Member BlacklistStore r => UserId -> Email -> AllowSCIMUpdates -> ExceptT ChangeEmailError (AppT r) ChangeEmailResult +changeEmail :: + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + Email -> + AllowSCIMUpdates -> + ExceptT ChangeEmailError (AppT r) ChangeEmailResult changeEmail u email allowScim = do em <- either @@ -709,11 +846,15 @@ changeEmail u email allowScim = do blacklisted <- lift . liftSem $ BlacklistStore.exists ek when blacklisted $ throwE (ChangeBlacklistedEmail email) - available <- lift . wrapClient $ Data.keyAvailable ek (Just u) + available <- lift . liftSem $ Data.keyAvailable ek (Just u) unless available $ throwE $ EmailExists email - usr <- maybe (throwM $ UserProfileNotFound u) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations u) + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + usr <- + maybe (throwM $ UserProfileNotFound u) pure + =<< lift (liftSem $ Data.lookupUser loc locale WithPendingInvitations u) case emailIdentity =<< userIdentity usr of -- The user already has an email address and the new one is exactly the same Just current | current == em -> pure ChangeEmailIdempotent @@ -724,7 +865,7 @@ changeEmail u email allowScim = do ) $ throwE EmailManagedByScim timeout <- setActivationTimeout <$> view settings - act <- lift . wrapClient $ Data.newActivation ek timeout (Just u) + act <- lift . liftSem $ Data.newActivation ek timeout (Just u) pure $ ChangeEmailNeedsActivation (usr, act, em) ------------------------------------------------------------------------------- @@ -732,8 +873,14 @@ changeEmail u email allowScim = do changePhone :: Members - '[ BlacklistStore, - BlacklistPhonePrefixStore + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + BlacklistPhonePrefixStore, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p ] r => UserId -> @@ -744,9 +891,9 @@ changePhone u phone = do maybe (throwE InvalidNewPhone) pure - =<< lift (wrapClient $ validatePhone phone) + =<< lift (liftSem $ validatePhone phone) let pk = userPhoneKey canonical - available <- lift . wrapClient $ Data.keyAvailable pk (Just u) + available <- lift . liftSem $ Data.keyAvailable pk (Just u) unless available $ throwE PhoneExists timeout <- setActivationTimeout <$> view settings @@ -757,48 +904,83 @@ changePhone u phone = do prefixExcluded <- lift . liftSem $ BlacklistPhonePrefixStore.existsAny canonical when prefixExcluded $ throwE BlacklistedNewPhone - act <- lift . wrapClient $ Data.newActivation pk timeout (Just u) + act <- lift . liftSem $ Data.newActivation pk timeout (Just u) pure (act, canonical) ------------------------------------------------------------------------------- -- Remove Email -removeEmail :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppT r) () +removeEmail :: + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + UserId -> + ConnId -> + ExceptT RemoveIdentityError (AppT r) () removeEmail uid conn = do ident <- lift $ fetchUserIdentity uid + d <- view digestSHA256 case ident of Just (FullIdentity e _) -> lift $ do - wrapClient . deleteKey $ userEmailKey e + liftSem . deleteKey d $ userEmailKey e wrapClient $ Data.deleteEmail uid - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (emailRemoved uid e) + Intra.onUserEvent uid (Just conn) (emailRemoved uid e) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity ------------------------------------------------------------------------------- -- Remove Phone -removePhone :: UserId -> ConnId -> ExceptT RemoveIdentityError (AppT r) () +removePhone :: + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + UserId -> + ConnId -> + ExceptT RemoveIdentityError (AppT r) () removePhone uid conn = do ident <- lift $ fetchUserIdentity uid + d <- view digestSHA256 case ident of Just (FullIdentity _ p) -> do pw <- lift . wrapClient $ Data.lookupPassword uid unless (isJust pw) $ throwE NoPassword lift $ do - wrapClient . deleteKey $ userPhoneKey p + liftSem . deleteKey d $ userPhoneKey p wrapClient $ Data.deletePhone uid - wrapHttpClient $ Intra.onUserEvent uid (Just conn) (phoneRemoved uid p) + Intra.onUserEvent uid (Just conn) (phoneRemoved uid p) Just _ -> throwE LastIdentity Nothing -> throwE NoIdentity ------------------------------------------------------------------------------- -- Forcefully revoke a verified identity -revokeIdentity :: Either Email Phone -> AppT r () +revokeIdentity :: + forall r p. + Members + '[ GalleyAccess, + GundeckAccess, + Input (Local ()), + UserKeyStore, + UserQuery p + ] + r => + Either Email Phone -> + AppT r () revokeIdentity key = do let uk = either userEmailKey userPhoneKey key - mu <- wrapClient $ Data.lookupKey uk + mu <- liftSem $ Data.getKey uk case mu of Nothing -> pure () Just u -> @@ -814,74 +996,82 @@ revokeIdentity key = do where revokeKey :: UserId -> UserKey -> AppT r () revokeKey u uk = do - wrapClient $ deleteKey uk + d <- view digestSHA256 + liftSem $ deleteKey d uk wrapClient $ foldKey (\(_ :: Email) -> Data.deleteEmail u) (\(_ :: Phone) -> Data.deletePhone u) uk - wrapHttpClient $ - Intra.onUserEvent u Nothing $ - foldKey - (emailRemoved u) - (phoneRemoved u) - uk + Intra.onUserEvent u Nothing $ + foldKey + (emailRemoved u) + (phoneRemoved u) + uk ------------------------------------------------------------------------------- -- Change Account Status changeAccountStatus :: - forall m. - ( MonadClient m, - MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => - List1 UserId -> + forall r p. + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + NonEmpty UserId -> AccountStatus -> - ExceptT AccountStatusError m () + ExceptT AccountStatusError (AppT r) () changeAccountStatus usrs status = do - ev <- mkUserEvent usrs status - lift $ mapConcurrently_ (update ev) usrs + ev <- liftSemE $ mkUserEvent usrs status + lift $ do + -- mapConcurrently_ (update ev) usrs + -- TODO(md): do this updating concurrently, perhaps in an effect + traverse_ (update ev) usrs where update :: (UserId -> UserEvent) -> UserId -> - m () + AppT r () update ev u = do - Data.updateStatus u status + liftSem $ Data.updateStatus u status Intra.onUserEvent u Nothing (ev u) changeSingleAccountStatus :: - forall m. - ( MonadClient m, - MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => UserId -> AccountStatus -> - ExceptT AccountStatusError m () + ExceptT AccountStatusError (AppT r) () changeSingleAccountStatus uid status = do - unlessM (Data.userExists uid) $ throwE AccountNotFound - ev <- mkUserEvent (List1.singleton uid) status - lift $ do - Data.updateStatus uid status - Intra.onUserEvent uid Nothing (ev uid) - -mkUserEvent :: (MonadUnliftIO m, Traversable t, MonadClient m) => t UserId -> AccountStatus -> ExceptT AccountStatusError m (UserId -> UserEvent) + unlessM (lift . liftSem $ Data.userExists uid) $ throwE AccountNotFound + ev <- liftSemE $ mkUserEvent [uid] status + lift . liftSem $ Data.updateStatus uid status + lift $ Intra.onUserEvent uid Nothing (ev uid) + +mkUserEvent :: + ( Traversable t, + Members '[Concurrency 'Unsafe, CookieStore] r + ) => + t UserId -> + AccountStatus -> + ExceptT AccountStatusError (Sem r) (UserId -> UserEvent) mkUserEvent usrs status = case status of Active -> pure UserResumed - Suspended -> lift $ mapConcurrently revokeAllCookies usrs >> pure UserSuspended + Suspended -> + lift $ + unsafePooledMapConcurrentlyN_ 16 revokeAllCookies usrs + >> pure UserSuspended Deleted -> throwE InvalidAccountStatus Ephemeral -> throwE InvalidAccountStatus PendingInvitation -> throwE InvalidAccountStatus @@ -890,6 +1080,20 @@ mkUserEvent usrs status = -- Activation activate :: + Members + '[ ActivationKeyStore, + ActivationSupply, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserQuery p + ] + r => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -898,6 +1102,20 @@ activate :: activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: + Members + '[ ActivationKeyStore, + ActivationSupply, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.Error Twilio.ErrorResponse, + PasswordResetSupply, + PasswordResetStore, + Twilio, + UserKeyStore, + UserQuery p + ] + r => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -907,12 +1125,14 @@ activateWithCurrency :: Maybe Currency.Alpha -> ExceptT ActivationError (AppT r) ActivationResult activateWithCurrency tgt code usr cur = do - key <- wrapClientE $ mkActivationKey tgt + key <- liftSemE $ mkActivationKey tgt lift . Log.info $ field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") - event <- wrapClientE $ Data.activateKey key code usr + d <- view digestSHA256 + locale <- setDefaultUserLocale <$> view settings + event <- liftSemE $ Data.activateKey locale d key code usr case event of Nothing -> pure ActivationPass Just e -> do @@ -927,106 +1147,129 @@ activateWithCurrency tgt code usr cur = do for_ tid $ \t -> wrapHttp $ Intra.changeTeamStatus t Team.Active cur preverify :: - ( MonadClient m, - MonadReader Env m - ) => + Members + '[ ActivationKeyStore, + ActivationSupply, + P.Error Twilio.ErrorResponse, + Twilio + ] + r => ActivationTarget -> ActivationCode -> - ExceptT ActivationError m () + ExceptT ActivationError (Sem r) () preverify tgt code = do key <- mkActivationKey tgt void $ Data.verifyCode key code -onActivated :: ActivationEvent -> (AppT r) (UserId, Maybe UserIdentity, Bool) +onActivated :: + Members + '[ GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + ActivationEvent -> + AppT r (UserId, Maybe UserIdentity, Bool) onActivated (AccountActivated account) = do let uid = userId (accountUser account) Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.onActivated") Log.info $ field "user" (toByteString uid) . msg (val "User activated") - wrapHttpClient $ Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) + Intra.onUserEvent uid Nothing $ UserActivated (accountUser account) pure (uid, userIdentity (accountUser account), True) onActivated (EmailActivated uid email) = do - wrapHttpClient $ Intra.onUserEvent uid Nothing (emailUpdated uid email) - wrapHttpClient $ Data.deleteEmailUnvalidated uid + Intra.onUserEvent uid Nothing (emailUpdated uid email) + liftSem $ Data.deleteEmailUnvalidated uid pure (uid, Just (EmailIdentity email), False) onActivated (PhoneActivated uid phone) = do - wrapHttpClient $ Intra.onUserEvent uid Nothing (phoneUpdated uid phone) + Intra.onUserEvent uid Nothing (phoneUpdated uid phone) pure (uid, Just (PhoneIdentity phone), False) -- docs/reference/user/activation.md {#RefActivationRequest} sendActivationCode :: Members - '[ BlacklistStore, - BlacklistPhonePrefixStore + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + BlacklistPhonePrefixStore, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p ] r => Either Email Phone -> Maybe Locale -> Bool -> ExceptT SendActivationCodeError (AppT r) () -sendActivationCode emailOrPhone loc call = case emailOrPhone of - Left email -> do - ek <- - either - (const . throwE . InvalidRecipient $ userEmailKey email) - (pure . userEmailKey) - (validateEmail email) - exists <- lift $ isJust <$> wrapClient (Data.lookupKey ek) - when exists $ - throwE $ - UserKeyInUse ek - blacklisted <- lift . liftSem $ BlacklistStore.exists ek - when blacklisted $ - throwE (ActivationBlacklistedUserKey ek) - uc <- lift . wrapClient $ Data.lookupActivationCode ek - case uc of - Nothing -> sendVerificationEmail ek Nothing -- Fresh code request, no user - Just (Nothing, c) -> sendVerificationEmail ek (Just c) -- Re-requesting existing code - Just (Just uid, c) -> sendActivationEmail ek c uid -- User re-requesting activation - Right phone -> do - -- validatePhone returns the canonical E.164 phone number format - canonical <- - maybe - (throwE $ InvalidRecipient (userPhoneKey phone)) - pure - =<< lift (wrapClient $ validatePhone phone) - let pk = userPhoneKey canonical - exists <- lift $ isJust <$> wrapClient (Data.lookupKey pk) - when exists $ - throwE $ - UserKeyInUse pk - blacklisted <- lift . liftSem $ BlacklistStore.exists pk - when blacklisted $ - throwE (ActivationBlacklistedUserKey pk) - -- check if any prefixes of this phone number are blocked - prefixExcluded <- lift . liftSem $ BlacklistPhonePrefixStore.existsAny canonical - when prefixExcluded $ - throwE (ActivationBlacklistedUserKey pk) - c <- lift . wrapClient $ fmap snd <$> Data.lookupActivationCode pk - p <- wrapClientE $ mkPair pk c Nothing - void . forPhoneKey pk $ \ph -> - lift $ - if call - then wrapClient $ sendActivationCall ph p loc - else wrapClient $ sendActivationSms ph p loc +sendActivationCode emailOrPhone loc call = do + timeout <- setActivationTimeout <$> view settings + case emailOrPhone of + Left email -> do + ek <- + either + (const . throwE . InvalidRecipient $ userEmailKey email) + (pure . userEmailKey) + (validateEmail email) + exists <- lift $ isJust <$> liftSem (Data.getKey ek) + when exists $ + throwE $ + UserKeyInUse ek + blacklisted <- lift . liftSem $ BlacklistStore.exists ek + when blacklisted $ + throwE (ActivationBlacklistedUserKey ek) + uc <- lift . wrapClient $ Data.lookupActivationCode ek + case uc of + Nothing -> sendVerificationEmail timeout ek Nothing -- Fresh code request, no user + Just (Nothing, c) -> sendVerificationEmail timeout ek (Just c) -- Re-requesting existing code + Just (Just uid, c) -> sendActivationEmail timeout ek c uid -- User re-requesting activation + Right phone -> do + -- validatePhone returns the canonical E.164 phone number format + canonical <- + maybe + (throwE $ InvalidRecipient (userPhoneKey phone)) + pure + =<< lift (liftSem $ validatePhone phone) + let pk = userPhoneKey canonical + exists <- lift $ isJust <$> liftSem (Data.getKey pk) + when exists $ + throwE $ + UserKeyInUse pk + blacklisted <- lift . liftSem $ BlacklistStore.exists pk + when blacklisted $ + throwE (ActivationBlacklistedUserKey pk) + -- check if any prefixes of this phone number are blocked + prefixExcluded <- lift . liftSem $ BlacklistPhonePrefixStore.existsAny canonical + when prefixExcluded $ + throwE (ActivationBlacklistedUserKey pk) + c <- lift . wrapClient $ fmap snd <$> Data.lookupActivationCode pk + p <- lift . liftSem $ mkPair timeout pk c Nothing + void . forPhoneKey pk $ \ph -> + lift $ + if call + then wrapClient $ sendActivationCall ph p loc + else wrapClient $ sendActivationSms ph p loc where notFound = throwM . UserDisplayNameNotFound - mkPair k c u = do - timeout <- setActivationTimeout <$> view settings + mkPair timeout k c u = do case c of - Just c' -> liftIO $ (,c') <$> Data.mkActivationKey k - Nothing -> lift $ do + Just c' -> (,c') <$> Data.makeActivationKey k + Nothing -> do dat <- Data.newActivation k timeout u pure (activationKey dat, activationCode dat) - sendVerificationEmail ek uc = do - p <- wrapClientE $ mkPair ek uc Nothing + sendVerificationEmail timeout ek uc = do + p <- lift . liftSem $ mkPair timeout ek uc Nothing void . forEmailKey ek $ \em -> lift $ sendVerificationMail em p loc - sendActivationEmail ek uc uid = do + sendActivationEmail timeout ek uc uid = do -- FUTUREWORK(fisx): we allow for 'PendingInvitations' here, but I'm not sure this -- top-level function isn't another piece of a deprecated onboarding flow? - u <- maybe (notFound uid) pure =<< lift (wrapClient $ Data.lookupUser WithPendingInvitations uid) - p <- wrapClientE $ mkPair ek (Just uc) (Just uid) + locu <- qualifyLocal () + locale <- setDefaultUserLocale <$> view settings + u <- + maybe (notFound uid) pure + =<< lift (liftSem $ Data.lookupUser locu locale WithPendingInvitations uid) + p <- lift . liftSem $ mkPair timeout ek (Just uc) (Just uid) let ident = userIdentity u name = userDisplayName u loc' = loc <|> Just (userLocale u) @@ -1044,7 +1287,15 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of _otherwise -> sendActivationMail em name p loc' ident -mkActivationKey :: (MonadClient m, MonadReader Env m) => ActivationTarget -> ExceptT ActivationError m ActivationKey +mkActivationKey :: + Members + '[ ActivationSupply, + P.Error Twilio.ErrorResponse, + Twilio + ] + r => + ActivationTarget -> + ExceptT ActivationError (Sem r) ActivationKey mkActivationKey (ActivateKey k) = pure k mkActivationKey (ActivateEmail e) = do ek <- @@ -1052,21 +1303,25 @@ mkActivationKey (ActivateEmail e) = do (throwE . InvalidActivationEmail e) (pure . userEmailKey) (validateEmail e) - liftIO $ Data.mkActivationKey ek + lift $ Data.makeActivationKey ek mkActivationKey (ActivatePhone p) = do pk <- maybe (throwE $ InvalidActivationPhone p) (pure . userPhoneKey) =<< lift (validatePhone p) - liftIO $ Data.mkActivationKey pk + lift $ Data.makeActivationKey pk ------------------------------------------------------------------------------- -- Password Management -changePassword :: UserId -> PasswordChange -> ExceptT ChangePasswordError (AppT r) () +changePassword :: + Members '[CookieStore, UserQuery p] r => + UserId -> + PasswordChange -> + ExceptT ChangePasswordError (AppT r) () changePassword uid cp = do - activated <- lift . wrapClient $ Data.isActivated uid + activated <- lift . liftSem $ Data.isActivated uid unless activated $ throwE ChangePasswordNoIdentity currpw <- lift . wrapClient $ Data.lookupPassword uid @@ -1079,16 +1334,17 @@ changePassword uid cp = do throwE InvalidCurrentPassword when (verifyPassword newpw pw) $ throwE ChangePasswordMustDiffer - lift $ wrapClient (Data.updatePassword uid newpw) >> wrapClient (revokeAllCookies uid) + lift $ wrapClient (Data.updatePassword uid newpw) >> liftSem (revokeAllCookies uid) beginPasswordReset :: - Members '[PasswordResetStore] r => + Members '[P.TinyLog, PasswordResetStore, UserKeyStore] r => Either Email Phone -> ExceptT PasswordResetError (AppT r) (UserId, PasswordResetPair) beginPasswordReset target = do let key = either userEmailKey userPhoneKey target - user <- lift (wrapClient $ Data.lookupKey key) >>= maybe (throwE InvalidPasswordResetKey) pure - lift . Log.debug $ field "user" (toByteString user) . field "action" (Log.val "User.beginPasswordReset") + user <- lift (liftSem $ Data.getKey key) >>= maybe (throwE InvalidPasswordResetKey) pure + lift . liftSem . P.debug $ + field "user" (toByteString user) . field "action" (Log.val "User.beginPasswordReset") status <- lift . wrapClient $ Data.lookupStatus user unless (status == Just Active) $ throwE InvalidPasswordResetKey @@ -1098,7 +1354,13 @@ beginPasswordReset target = do (user,) <$> lift (liftSem $ E.createPasswordResetCode user target) completePasswordReset :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ CookieStore, + PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => PasswordResetIdentity -> PasswordResetCode -> PlainTextPassword -> @@ -1113,8 +1375,8 @@ completePasswordReset ident code pw = do checkNewIsDifferent uid pw lift $ do wrapClient $ Data.updatePassword uid pw - liftSem $ E.codeDelete key - wrapClient $ revokeAllCookies uid + liftSem $ E.deletePasswordResetCode key + liftSem $ revokeAllCookies uid -- | Pull the current password of a user and compare it against the one about to be installed. -- If the two are the same, throw an error. If no current password can be found, do nothing. @@ -1126,19 +1388,19 @@ checkNewIsDifferent uid pw = do _ -> pure () mkPasswordResetKey :: - Members '[CodeStore] r => + Members '[PasswordResetSupply, UserKeyStore] r => PasswordResetIdentity -> ExceptT PasswordResetError (AppT r) PasswordResetKey mkPasswordResetKey ident = case ident of PasswordResetIdentityKey k -> pure k PasswordResetEmailIdentity e -> - wrapClientE (user (userEmailKey e)) + user (userEmailKey e) >>= lift . liftSem . E.mkPasswordResetKey PasswordResetPhoneIdentity p -> - wrapClientE (user (userPhoneKey p)) + user (userPhoneKey p) >>= lift . liftSem . E.mkPasswordResetKey where - user uk = lift (Data.lookupKey uk) >>= maybe (throwE InvalidPasswordResetKey) pure + user uk = lift (liftSem $ Data.getKey uk) >>= maybe (throwE InvalidPasswordResetKey) pure ------------------------------------------------------------------------------- -- User Deletion @@ -1151,9 +1413,26 @@ mkPasswordResetKey ident = case ident of -- delete them in the team settings. This protects teams against orphanhood. -- -- TODO: communicate deletions of SSO users to SSO service. -deleteSelfUser :: UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) +deleteSelfUser :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + UserId -> + Maybe PlainTextPassword -> + ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser uid pwd = do - account <- lift . wrapClient $ Data.lookupAccount uid + locale <- setDefaultUserLocale <$> view settings + account <- lift . liftSem $ Data.lookupAccount locale uid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -1182,7 +1461,7 @@ deleteSelfUser uid pwd = do Just emailOrPhone -> sendCode a emailOrPhone Nothing -> case pwd of Just _ -> throwE DeleteUserMissingPassword - Nothing -> lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + Nothing -> lift $ deleteAccount a >> pure Nothing byPassword a pw = do lift . Log.info $ field "user" (toByteString uid) @@ -1193,10 +1472,10 @@ deleteSelfUser uid pwd = do Just p -> do unless (verifyPassword pw p) $ throwE DeleteUserInvalidPassword - lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + lift $ deleteAccount a >> pure Nothing sendCode a target = do gen <- Code.mkGen (either Code.ForEmail Code.ForPhone target) - pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.AccountDeletion + pending <- lift . liftSem $ Code.getPendingCode (Code.genKey gen) Code.AccountDeletion case pending of Just c -> throwE $! DeleteUserPendingCode (Code.codeTTL c) Nothing -> do @@ -1210,6 +1489,7 @@ deleteSelfUser uid pwd = do (Code.Retries 3) (Code.Timeout 600) (Just (toUUID uid)) + -- lift . liftSem $ Code.insertCode c tryInsertVerificationCode c DeleteUserVerificationCodeThrottled let k = Code.codeKey c let v = Code.codeValue c @@ -1224,47 +1504,65 @@ deleteSelfUser uid pwd = do -- | Conclude validation and scheduling of user's deletion request that was initiated in -- 'deleteUser'. Called via @post /delete@. -verifyDeleteUser :: VerifyDeleteUser -> ExceptT DeleteUserError (AppT r) () +verifyDeleteUser :: + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + VerifyDeleteUser -> + ExceptT DeleteUserError (AppT r) () verifyDeleteUser d = do let key = verifyDeleteUserKey d let code = verifyDeleteUserCode d - c <- lift . wrapClient $ Code.verify key Code.AccountDeletion code + c <- lift . liftSem $ Code.verifyCode key Code.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (Code.codeAccount =<< c) - account <- lift . wrapClient $ Data.lookupAccount (Id a) - for_ account $ lift . wrapHttpClient . deleteAccount + locale <- setDefaultUserLocale <$> view settings + account <- lift . liftSem $ Data.lookupAccount locale (Id a) + for_ account $ lift . deleteAccount lift . wrapClient $ Code.delete key Code.AccountDeletion -- | Check if `deleteAccount` succeeded and run it again if needed. -- Called via @delete /i/user/:uid@. ensureAccountDeleted :: - ( MonadLogger m, - MonadCatch m, - MonadThrow m, - MonadIndexIO m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m, - MonadReader Env m - ) => + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p + ] + r => UserId -> - m DeleteUserResult + AppT r DeleteUserResult ensureAccountDeleted uid = do - mbAcc <- lookupAccount uid + locale <- Opt.setDefaultUserLocale <$> view settings + mbAcc <- liftSem $ lookupAccount locale uid case mbAcc of Nothing -> pure NoUser Just acc -> do - probs <- Data.lookupPropertyKeysAndValues uid + probs <- wrapClient $ Data.lookupPropertyKeysAndValues uid let accIsDeleted = accountStatus acc == Deleted - clients <- Data.lookupClients uid + clients <- wrapClient $ Data.lookupClients uid localUid <- qualifyLocal uid - conCount <- countConnections localUid [(minBound @Relation) .. maxBound] - cookies <- listCookies uid [] + conCount <- + wrapClient $ + countConnections localUid [(minBound @Relation) .. maxBound] + cookies <- liftSem $ listCookies uid [] if notNull probs || not accIsDeleted @@ -1286,36 +1584,40 @@ ensureAccountDeleted uid = do -- statements matters! Other functions reason upon some states to imply other -- states. Please change this order only with care! deleteAccount :: - ( MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m - ) => + forall r p. + Members + '[ ClientStore, + CookieStore, + GalleyAccess, + GundeckAccess, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p + ] + r => UserAccount -> - m () + AppT r () deleteAccount account@(accountUser -> user) = do let uid = userId user Log.info $ field "user" (toByteString uid) . msg (val "Deleting account") -- Free unique keys - for_ (userEmail user) $ deleteKeyForUser uid . userEmailKey - for_ (userPhone user) $ deleteKeyForUser uid . userPhoneKey - for_ (userHandle user) $ freeHandle (userId user) + d <- view digestSHA256 + for_ (userEmail user) $ liftSem . deleteKeyForUser d uid . userEmailKey + for_ (userPhone user) $ liftSem . deleteKeyForUser d uid . userPhoneKey + liftSem $ for_ (userHandle user) $ freeHandle (userId user) -- Wipe data - Data.clearProperties uid + wrapClient $ Data.clearProperties uid tombstone <- mkTombstone - Data.insertAccount tombstone Nothing Nothing False - Intra.rmUser uid (userAssets user) - Data.lookupClients uid >>= mapM_ (Data.rmClient uid . clientId) + liftSem $ Data.insertAccount tombstone Nothing Nothing False + wrapHttp $ Intra.rmUser uid (userAssets user) + liftSem (lookupClients uid >>= mapM_ (deleteClient uid . clientId)) luid <- qualifyLocal uid Intra.onUserEvent uid Nothing (UserDeleted (qUntagged luid)) -- Note: Connections can only be deleted afterwards, since -- they need to be notified. - Data.deleteConnections uid - revokeAllCookies uid + wrapClient $ Data.deleteConnections uid + liftSem $ revokeAllCookies uid where mkTombstone = do defLoc <- setDefaultUserLocale <$> view settings @@ -1348,12 +1650,17 @@ lookupActivationCode emailOrPhone = do pure $ (k,) <$> c lookupPasswordResetCode :: - Members '[CodeStore, PasswordResetStore] r => + Members + '[ PasswordResetStore, + PasswordResetSupply, + UserKeyStore + ] + r => Either Email Phone -> - (AppT r) (Maybe PasswordResetPair) + AppT r (Maybe PasswordResetPair) lookupPasswordResetCode emailOrPhone = do let uk = either userEmailKey userPhoneKey emailOrPhone - usr <- wrapClient $ Data.lookupKey uk + usr <- liftSem $ Data.getKey uk liftSem $ case usr of Nothing -> pure Nothing Just u -> do @@ -1400,16 +1707,10 @@ userGC u = case userExpire u of pure u lookupProfile :: - ( MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[Input (Local ()), UserQuery p] r => Local UserId -> Qualified UserId -> - ExceptT FederationError m (Maybe UserProfile) + ExceptT FederationError (AppT r) (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfilesFromDomain @@ -1422,36 +1723,37 @@ lookupProfile self other = -- Otherwise only the 'PublicProfile' is accessible for user 'self'. -- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: - ( MonadUnliftIO m, - MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[Input (Local ()), UserQuery p] r => + -- ( MonadUnliftIO m, + -- MonadClient m, + -- MonadReader Env m, + -- MonadLogger m, + -- MonadMask m, + -- MonadHttp m, + -- HasRequestId m + -- ) => + -- | User 'self' on whose behalf the profiles are requested. Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> - ExceptT FederationError m [UserProfile] + ExceptT FederationError (AppT r) [UserProfile] lookupProfiles self others = concat - <$> traverseConcurrentlyWithErrors + <$> + -- <$> traverseConcurrentlyWithErrors + -- (lookupProfilesFromDomain self) + -- (bucketQualified others) + -- TODO(md): Use an effect with error handling for this + traverse (lookupProfilesFromDomain self) (bucketQualified others) lookupProfilesFromDomain :: - ( MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[Input (Local ()), UserQuery p] r => Local UserId -> Qualified [UserId] -> - ExceptT FederationError m [UserProfile] + ExceptT FederationError (AppT r) [UserProfile] lookupProfilesFromDomain self = foldQualified self @@ -1459,12 +1761,8 @@ lookupProfilesFromDomain self = lookupRemoteProfiles lookupRemoteProfiles :: - ( MonadIO m, - MonadReader Env m, - MonadLogger m - ) => Remote [UserId] -> - ExceptT FederationError m [UserProfile] + ExceptT FederationError (AppT r) [UserProfile] lookupRemoteProfiles (qUntagged -> Qualified uids domain) = Federation.getUsersByIds domain uids @@ -1472,29 +1770,29 @@ lookupRemoteProfiles (qUntagged -> Qualified uids domain) = -- ids, but it is also very complex. Maybe this can be made easy by extracting a -- pure function and writing tests for that. lookupLocalProfiles :: - forall m. - ( MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + forall r p. + Members '[Input (Local ()), UserQuery p] r => -- | This is present only when an authenticated user is requesting access. Maybe UserId -> -- | The users ('others') for which to obtain the profiles. [UserId] -> - m [UserProfile] + AppT r [UserProfile] lookupLocalProfiles requestingUser others = do - users <- Data.lookupUsers NoPendingInvitations others >>= mapM userGC + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + users <- + liftSem (Data.lookupUsers loc locale NoPendingInvitations others) + >>= mapM userGC css <- case requestingUser of - Just localReqUser -> toMap <$> Data.lookupConnectionStatus (map userId users) [localReqUser] + Just localReqUser -> + toMap + <$> wrapClient (Data.lookupConnectionStatus (map userId users) [localReqUser]) Nothing -> pure mempty emailVisibility' <- view (settings . emailVisibility) emailVisibility'' <- case emailVisibility' of EmailVisibleIfOnTeam -> pure EmailVisibleIfOnTeam' EmailVisibleIfOnSameTeam -> case requestingUser of - Just localReqUser -> EmailVisibleIfOnSameTeam' <$> getSelfInfo localReqUser + Just localReqUser -> EmailVisibleIfOnSameTeam' <$> getSelfInfo loc locale localReqUser Nothing -> pure EmailVisibleToSelf' EmailVisibleToSelf -> pure EmailVisibleToSelf' usersAndStatus <- for users $ \u -> (u,) <$> getLegalHoldStatus' u @@ -1503,15 +1801,16 @@ lookupLocalProfiles requestingUser others = do toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - getSelfInfo :: UserId -> m (Maybe (TeamId, TeamMember)) - getSelfInfo selfId = do + getSelfInfo :: Local x -> Locale -> UserId -> AppT r (Maybe (TeamId, TeamMember)) + getSelfInfo loc locale selfId = do -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') -- to return 'Nothing'. we could throw errors here if that happens, rather than just -- returning an empty profile list from 'lookupProfiles'. - mUser <- Data.lookupUser NoPendingInvitations selfId + mUser <- + liftSem (Data.lookupUser loc locale NoPendingInvitations selfId) case userTeam =<< mUser of Nothing -> pure Nothing - Just tid -> (tid,) <$$> Intra.getTeamMember selfId tid + Just tid -> (tid,) <$$> wrapHttp (Intra.getTeamMember selfId tid) toProfile :: EmailVisibility' -> Map UserId Relation -> (User, UserLegalHoldStatus) -> UserProfile toProfile emailVisibility'' css (u, userLegalHold) = @@ -1524,32 +1823,24 @@ lookupLocalProfiles requestingUser others = do in baseProfile {profileEmail = profileEmail'} getLegalHoldStatus :: - ( MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadClient m - ) => + Members '[Input (Local ()), UserQuery p] r => UserId -> - m (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (getLegalHoldStatus' . accountUser) =<< lookupAccount uid + AppT r (Maybe UserLegalHoldStatus) +getLegalHoldStatus uid = do + locale <- setDefaultUserLocale <$> view settings + traverse (getLegalHoldStatus' . accountUser) + =<< liftSem (lookupAccount locale uid) getLegalHoldStatus' :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + forall r p. + Members '[Input (Local ()), UserQuery p] r => User -> - m UserLegalHoldStatus + AppT r UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus Just tid -> do - teamMember <- Intra.getTeamMember (userId user) tid + teamMember <- wrapHttp $ Intra.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember data EmailVisibility' @@ -1576,12 +1867,17 @@ getEmailForProfile _ EmailVisibleToSelf' = Nothing -- | Find user accounts for a given identity, both activated and those -- currently pending activation. -lookupAccountsByIdentity :: Either Email Phone -> Bool -> (AppT r) [UserAccount] +lookupAccountsByIdentity :: + Members '[Input (Local ()), UserKeyStore, UserQuery p] r => + Either Email Phone -> + Bool -> + AppT r [UserAccount] lookupAccountsByIdentity emailOrPhone includePendingInvitations = do let uk = either userEmailKey userPhoneKey emailOrPhone - activeUid <- wrapClient $ Data.lookupKey uk + activeUid <- liftSem $ Data.getKey uk uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) - result <- wrapClient $ Data.lookupAccounts (nub $ catMaybes [activeUid, uidFromKey]) + locale <- setDefaultUserLocale <$> view settings + result <- liftSem $ Data.lookupAccounts locale (nub $ catMaybes [activeUid, uidFromKey]) if includePendingInvitations then pure result else pure $ filter ((/= PendingInvitation) . accountStatus) result diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 01607c93bd..120c3d5517 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -36,6 +36,8 @@ import Brig.API.Types import Brig.App import qualified Brig.Code as Code import qualified Brig.Data.User as Data +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore (VerificationCodeStore) import Brig.Options (FederationDomainConfig, federationDomainConfigs, set2FACodeGenerationDelaySecs) import qualified Brig.Options as Opts import Brig.Types.Intra (accountUser) @@ -50,6 +52,8 @@ import Data.Qualified import Data.String.Conversions (cs) import Data.Text.Ascii (AsciiText (toText)) import Imports +import Polysemy +import Polysemy.Input import System.Logger (Msg) import qualified System.Logger as Log import UnliftIO.Async @@ -68,7 +72,14 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> (AppT r) (Maybe UserIdentity) +fetchUserIdentity :: + Members + '[ Input (Local ()), + UserQuery p + ] + r => + UserId -> + AppT r (Maybe UserIdentity) fetchUserIdentity uid = lookupSelfProfile uid >>= maybe @@ -76,8 +87,17 @@ fetchUserIdentity uid = (pure . userIdentity . selfUser) -- | Obtain a profile for a user as he can see himself. -lookupSelfProfile :: UserId -> (AppT r) (Maybe SelfProfile) -lookupSelfProfile = fmap (fmap mk) . wrapClient . Data.lookupAccount +lookupSelfProfile :: + Members + '[ Input (Local ()), + UserQuery p + ] + r => + UserId -> + AppT r (Maybe SelfProfile) +lookupSelfProfile u = do + locale <- Opts.setDefaultUserLocale <$> view settings + fmap (fmap mk) $ liftSem $ Data.lookupAccount locale u where mk a = SelfProfile (accountUser a) @@ -121,8 +141,12 @@ ensureLocal x = do loc <- qualifyLocal () foldQualified loc pure (\_ -> throwM federationNotImplemented) x -tryInsertVerificationCode :: Code.Code -> (RetryAfter -> e) -> ExceptT e (AppT r) () +tryInsertVerificationCode :: + Member VerificationCodeStore r => + Code.Code -> + (RetryAfter -> e) -> + ExceptT e (AppT r) () tryInsertVerificationCode code e = do ttl <- set2FACodeGenerationDelaySecs <$> view settings - mRetryAfter <- wrapClientE $ Code.insert code ttl + mRetryAfter <- lift . liftSem $ Code.insertCode code ttl mapM_ (throwE . e) mRetryAfter diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 4a18a47ec8..757f018e5a 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -78,6 +78,7 @@ module Brig.App wrapHttp, HttpClientIO (..), liftSem, + liftSemE, ) where @@ -476,6 +477,9 @@ instance MonadReader Env (AppT r) where liftSem :: Sem r a -> AppT r a liftSem sem = AppT $ lift sem +liftSemE :: ExceptT e (Sem r) a -> ExceptT e (AppT r) a +liftSemE = mapExceptT liftSem + instance MonadIO m => MonadLogger (ReaderT Env m) where log l m = do g <- view applog diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index c05ec6710f..821cb26c0e 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -1,36 +1,130 @@ -module Brig.CanonicalInterpreter where +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.CanonicalInterpreter + ( BrigCanonicalEffects, + runBrigToIO, + ) +where + +import Bilge.IO +import Brig.API.Types (ReAuthError) import Brig.App +import Brig.Effects.ActivationKeyStore (ActivationKeyStore) +import Brig.Effects.ActivationKeyStore.Cassandra +import Brig.Effects.ActivationSupply (ActivationSupply) +import Brig.Effects.ActivationSupply.IO import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistPhonePrefixStore.Cassandra (interpretBlacklistPhonePrefixStoreToCassandra) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) +import Brig.Effects.BudgetStore (BudgetStore) +import Brig.Effects.BudgetStore.Cassandra +import Brig.Effects.ClientStore (ClientStore) +import Brig.Effects.ClientStore.Cassandra import Brig.Effects.CodeStore (CodeStore) -import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) +import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra) +import Brig.Effects.Common +import Brig.Effects.CookieStore (CookieStore) +import Brig.Effects.CookieStore.Cassandra +import Brig.Effects.GalleyAccess (GalleyAccess) +import Brig.Effects.GalleyAccess.Http +import Brig.Effects.GundeckAccess (GundeckAccess) +import Brig.Effects.GundeckAccess.Http (gundeckAccessToHttp) import Brig.Effects.JwtTools import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) +import Brig.Effects.PasswordResetSupply (PasswordResetSupply) +import Brig.Effects.PasswordResetSupply.IO import Brig.Effects.PublicKeyBundle +import Brig.Effects.Twilio (Twilio) +import Brig.Effects.Twilio.IO +import Brig.Effects.UniqueClaimsStore (UniqueClaimsStore) +import Brig.Effects.UniqueClaimsStore.Cassandra +import Brig.Effects.UserHandleStore (UserHandleStore) +import Brig.Effects.UserHandleStore.Cassandra +import Brig.Effects.UserKeyStore (UserKeyStore) +import Brig.Effects.UserKeyStore.Cassandra import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.UserQuery.Cassandra +import Brig.Effects.VerificationCodeStore (VerificationCodeStore) +import Brig.Effects.VerificationCodeStore.Cassandra +import qualified Brig.Options as Opt +import Cassandra import qualified Cassandra as Cas -import Control.Lens ((^.)) +import Control.Lens (view, (^.)) +import Data.Qualified +import Data.String.Conversions import Imports -import Polysemy (Embed, Final, embedToFinal, runFinal) +import Network.HTTP.Types.Status +import qualified Network.Wai.Utilities.Error as Wai +import Polysemy +import Polysemy.Async (Async, asyncToIO) +import Polysemy.Conc.Effect.Race (Race) +import Polysemy.Conc.Interpreter.Race +import qualified Polysemy.Error as P +import Polysemy.Input +import Polysemy.Resource (Resource, resourceToIO) +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.IO +import Wire.Sem.Error +import Wire.Sem.Logger.TinyLog import Wire.Sem.Now (Now) -import Wire.Sem.Now.IO (nowToIOAction) +import Wire.Sem.Now.IO import Wire.Sem.Paging.Cassandra (InternalPaging) +import qualified Wire.Sem.Paging.Cassandra as PC type BrigCanonicalEffects = - '[ PublicKeyBundle, + '[ CookieStore, + ClientStore, + PublicKeyBundle, JwtTools, BlacklistPhonePrefixStore, BlacklistStore, + VerificationCodeStore, + UserKeyStore, + UserHandleStore, + Twilio, + ActivationKeyStore, + ActivationSupply, + UniqueClaimsStore, + GalleyAccess, + GundeckAccess, + Embed HttpClientIO, + UserQuery PC.InternalPaging, PasswordResetStore, UserPendingActivationStore InternalPaging, Now, + PasswordResetSupply, CodeStore, + BudgetStore, + P.TinyLog, + Input (Local ()), + Async, + Race, + Resource, Embed Cas.Client, + P.Error Twilio.ErrorResponse, + P.Error ReAuthError, + Concurrency 'Unsafe, Embed IO, Final IO ] @@ -39,13 +133,60 @@ runBrigToIO :: Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = runFinal . embedToFinal + . unsafelyPerformConcurrency + . interpretWaiErrorToException + . interpretErrorToException twilioToWai . interpretClientToIO (e ^. casClient) + . resourceToIO + . interpretRace + . asyncToIO + . runInputConst (toLocalUnsafe (e ^. settings & Opt.setFederationDomain) ()) + . loggerToTinyLogReqId (view requestId e) (view applog e) + . budgetStoreToCassandra @Cas.Client . codeStoreToCassandra @Cas.Client + . passwordResetSupplyToIO . nowToIOAction (e ^. currentTime) . userPendingActivationStoreToCassandra . passwordResetStoreToCodeStore + . userQueryToCassandra + . interpretHttpToIO e + . gundeckAccessToHttp @HttpClientIO (e ^. gundeck) + . galleyAccessToHttp @HttpClientIO (e ^. galley) + . uniqueClaimsStoreToCassandra @Cas.Client + . activationSupplyToIO + . activationKeyStoreToCassandra @Cas.Client + . twilioToIO + . userHandleStoreToCassandra @Cas.Client + . userKeyStoreToCassandra @Cas.Client + . verificationCodeStoreToCassandra @Cas.Client . interpretBlacklistStoreToCassandra @Cas.Client . interpretBlacklistPhonePrefixStoreToCassandra @Cas.Client . interpretJwtTools . interpretPublicKeyBundle + . clientStoreToCassandra @HttpClientIO + . cookieStoreToCassandra @Cas.Client $ runReaderT ma e + +interpretHttpToIO :: + Member (Final IO) r => + Env -> + Sem (Embed HttpClientIO ': r) a -> + Sem r a +interpretHttpToIO e = interpret $ \case + Embed action -> embedFinal @IO $ do + let ctx = e ^. casClient + manager = e ^. httpManager + runClient ctx + . runHttpT manager + . flip runReaderT e + . runHttpClientIO + $ action + +twilioToWai :: Twilio.ErrorResponse -> Wai.Error +twilioToWai e = + Wai.Error + { Wai.code = Status (Twilio.errStatus e) "", + Wai.label = "twilio-error", + Wai.message = cs . Twilio.errMessage $ e, + Wai.errorData = Nothing + } diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 5d4c11a0b4..e599629270 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -52,21 +50,32 @@ module Brig.Code mkKey, -- * Storage - insert, - lookup, - verify, + insertCode, + getPendingCode, + verifyCode, delete, ) where import Brig.Data.Instances () -import Brig.Email (emailKeyUniq, mkEmailKey) -import Brig.Phone (mkPhoneKey, phoneKeyUniq) +import Brig.Effects.VerificationCodeStore + ( Code (..), + CodeFor (..), + Retries (..), + Scope (..), + codeForEmail, + codeForPhone, + getPendingCode, + insertCode, + verifyCode, + ) +import Brig.Effects.VerificationCodeStore.Cassandra () +import Brig.Email +import Brig.Types.Common import Cassandra hiding (Value) import qualified Data.ByteString as BS import Data.Code import Data.Range -import Data.RetryAfter (RetryAfter (RetryAfter)) import qualified Data.Text as Text import qualified Data.Text.Ascii as Ascii import qualified Data.Text.Encoding as Text @@ -77,84 +86,16 @@ import OpenSSL.EVP.Digest (Digest, digestBS, getDigestByName) import OpenSSL.Random (randBytes) import Text.Printf (printf) import qualified Wire.API.User as User -import Wire.API.User.Identity -------------------------------------------------------------------------------- -- Code -data Code = Code - { codeKey :: !Key, - codeScope :: !Scope, - codeValue :: !Value, - codeRetries :: !Retries, - codeTTL :: !Timeout, - codeFor :: !CodeFor, - codeAccount :: !(Maybe UUID) - } - deriving (Eq, Show) - -data CodeFor - = ForEmail !Email - | ForPhone !Phone - deriving (Eq, Show) - -codeForEmail :: Code -> Maybe Email -codeForEmail c - | ForEmail e <- codeFor c = Just e - | otherwise = Nothing - -codeForPhone :: Code -> Maybe Phone -codeForPhone c - | ForPhone p <- codeFor c = Just p - | otherwise = Nothing - scopeFromAction :: User.VerificationAction -> Scope scopeFromAction = \case User.CreateScimToken -> CreateScimToken User.Login -> AccountLogin User.DeleteTeam -> DeleteTeam --- | The same 'Key' can exist with different 'Value's in different --- 'Scope's at the same time. -data Scope - = AccountDeletion - | IdentityVerification - | PasswordReset - | AccountLogin - | AccountApproval - | CreateScimToken - | DeleteTeam - deriving (Eq, Show) - -instance Cql Scope where - ctype = Tagged IntColumn - - toCql AccountDeletion = CqlInt 1 - toCql IdentityVerification = CqlInt 2 - toCql PasswordReset = CqlInt 3 - toCql AccountLogin = CqlInt 4 - toCql AccountApproval = CqlInt 5 - toCql CreateScimToken = CqlInt 6 - toCql DeleteTeam = CqlInt 7 - - fromCql (CqlInt 1) = pure AccountDeletion - fromCql (CqlInt 2) = pure IdentityVerification - fromCql (CqlInt 3) = pure PasswordReset - fromCql (CqlInt 4) = pure AccountLogin - fromCql (CqlInt 5) = pure AccountApproval - fromCql (CqlInt 6) = pure CreateScimToken - fromCql (CqlInt 7) = pure DeleteTeam - fromCql _ = Left "fromCql: Scope: int expected" - -newtype Retries = Retries {numRetries :: Word8} - deriving (Eq, Show, Ord, Num, Integral, Enum, Real) - -instance Cql Retries where - ctype = Tagged IntColumn - toCql = CqlInt . fromIntegral . numRetries - fromCql (CqlInt n) = pure (Retries (fromIntegral n)) - fromCql _ = Left "fromCql: Retries: int expected" - -------------------------------------------------------------------------------- -- Generation @@ -269,74 +210,45 @@ generate gen scope retries ttl account = do -------------------------------------------------------------------------------- -- Storage -insert :: MonadClient m => Code -> Int -> m (Maybe RetryAfter) -insert code ttl = do - mRetryAfter <- lookupThrottle (codeKey code) (codeScope code) - case mRetryAfter of - Just ra -> pure (Just ra) - Nothing -> do - insertThrottle code ttl - insertInternal code - pure Nothing - where - insertThrottle :: MonadClient m => Code -> Int -> m () - insertThrottle c t = do - let k = codeKey c - let s = codeScope c - retry x5 (write cql (params LocalQuorum (k, s, fromIntegral t, fromIntegral t))) - where - cql :: PrepQuery W (Key, Scope, Int32, Int32) () - cql = - "INSERT INTO vcodes_throttle (key, scope, initial_delay) \ - \VALUES (?, ?, ?) USING TTL ?" - -insertInternal :: MonadClient m => Code -> m () -insertInternal c = do - let k = codeKey c - let s = codeScope c - let v = codeValue c - let r = fromIntegral (codeRetries c) - let a = codeAccount c - let e = codeForEmail c - let p = codeForPhone c - let t = round (codeTTL c) - retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) - where - cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () - cql = - "INSERT INTO vcodes (key, scope, value, retries, email, phone, account) \ - \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?" - --- | Check if code generation should be throttled. -lookupThrottle :: MonadClient m => Key -> Scope -> m (Maybe RetryAfter) -lookupThrottle k s = do - fmap (RetryAfter . fromIntegral . runIdentity) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) - where - cql :: PrepQuery R (Key, Scope) (Identity Int32) - cql = - "SELECT ttl(initial_delay) \ - \FROM vcodes_throttle WHERE key = ? AND scope = ?" - --- | Lookup a pending code. -lookup :: MonadClient m => Key -> Scope -> m (Maybe Code) -lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) - where - cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) - cql = - "SELECT value, ttl(value), retries, email, phone, account \ - \FROM vcodes WHERE key = ? AND scope = ?" +-- 'insert' is available in Brig.Effects.VerificationCodeStore.Cassandra only + +-- insertInternal :: MonadClient m => Code -> m () +-- insertInternal c = do +-- let k = codeKey c +-- let s = codeScope c +-- let v = codeValue c +-- let r = fromIntegral (codeRetries c) +-- let a = codeAccount c +-- let e = codeForEmail c +-- let p = codeForPhone c +-- let t = round (codeTTL c) +-- retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) +-- where +-- cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () +-- cql = +-- "INSERT INTO vcodes (key, scope, value, retries, email, phone, account) \ +-- \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?" + +-- -- | Lookup a pending code. +-- lookup :: MonadClient m => Key -> Scope -> m (Maybe Code) +-- lookup k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) +-- where +-- cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) +-- cql = +-- "SELECT value, ttl(value), retries, email, phone, account \ +-- \FROM vcodes WHERE key = ? AND scope = ?" -- | Lookup and verify the code for the given key and scope -- against the given value. -verify :: MonadClient m => Key -> Scope -> Value -> m (Maybe Code) -verify k s v = lookup k s >>= maybe (pure Nothing) continue - where - continue c - | codeValue c == v = pure (Just c) - | codeRetries c > 0 = do - insertInternal (c {codeRetries = codeRetries c - 1}) - pure Nothing - | otherwise = pure Nothing +-- verify :: MonadClient m => Key -> Scope -> Value -> m (Maybe Code) +-- verify k s v = lookup k s >>= maybe (pure Nothing) continue +-- where +-- continue c +-- | codeValue c == v = pure (Just c) +-- | codeRetries c > 0 = do +-- insertInternal (c {codeRetries = codeRetries c - 1}) +-- pure Nothing +-- | otherwise = pure Nothing -- | Delete a code associated with the given key and scope. delete :: MonadClient m => Key -> Scope -> m () @@ -344,24 +256,3 @@ delete k s = retry x5 $ write cql (params LocalQuorum (k, s)) where cql :: PrepQuery W (Key, Scope) () cql = "DELETE FROM vcodes WHERE key = ? AND scope = ?" - --------------------------------------------------------------------------------- --- Internal - -toCode :: Key -> Scope -> (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) -> Code -toCode k s (val, ttl, retries, email, phone, account) = - let ek = ForEmail <$> email - pk = ForPhone <$> phone - to = Timeout (fromIntegral ttl) - in case ek <|> pk of - Nothing -> error "toCode: email or phone must be present" - Just cf -> - Code - { codeKey = k, - codeScope = s, - codeValue = val, - codeTTL = to, - codeRetries = retries, - codeFor = cf, - codeAccount = account - } diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 3de71d3982..790c4d0c26 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -28,28 +28,35 @@ module Brig.Data.Activation lookupActivationCode, activateKey, verifyCode, + + -- * polysemized version of 'mkActivationKey' + makeActivationKey, ) where -import Brig.App (Env) import Brig.Data.User import Brig.Data.UserKey -import qualified Brig.Effects.CodeStore as E -import Brig.Effects.CodeStore.Cassandra +import Brig.Effects.ActivationKeyStore +import Brig.Effects.ActivationSupply +import Brig.Effects.PasswordResetStore +import qualified Brig.Effects.PasswordResetStore as E +import qualified Brig.Effects.PasswordResetSupply as E +import Brig.Effects.UserKeyStore (UserKeyStore) +import Brig.Effects.UserQuery (UserQuery) import Brig.Options +import Brig.Types.Common import Brig.Types.Intra import Cassandra import Control.Error import Data.Id -import Data.Text (pack) +import Data.Qualified import qualified Data.Text.Ascii as Ascii import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import Imports -import OpenSSL.BN (randIntegerZeroToNMinusOne) -import OpenSSL.EVP.Digest (digestBS, getDigestByName) +import OpenSSL.EVP.Digest (Digest, digestBS, getDigestByName) import Polysemy -import Text.Printf (printf) +import Polysemy.Input import Wire.API.User import Wire.API.User.Activation @@ -82,23 +89,30 @@ data ActivationEvent | EmailActivated !UserId !Email | PhoneActivated !UserId !Phone --- | Max. number of activation attempts per 'ActivationKey'. -maxAttempts :: Int32 -maxAttempts = 3 - -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: - forall m. - (MonadClient m, MonadReader Env m) => + forall r p. + Members + '[ ActivationKeyStore, + Input (Local ()), + E.PasswordResetSupply, + PasswordResetStore, + UserKeyStore, + UserQuery p + ] + r => + Locale -> + Digest -> ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError m (Maybe ActivationEvent) -activateKey k c u = verifyCode k c >>= pickUser >>= activate + ExceptT ActivationError (Sem r) (Maybe ActivationEvent) +activateKey locale d k c u = verifyCode k c >>= pickUser >>= activate where pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u') activate (key, uid) = do - a <- lift (lookupAccount uid) >>= maybe (throwE invalidUser) pure + a <- + lift (lookupAccount locale uid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of @@ -126,46 +140,47 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key -- if the key is the same, we only want to update our profile | otherwise = do - lift (runM (codeStoreToCassandra @m @'[Embed m] (E.mkPasswordResetKey uid >>= E.codeDelete))) + lift (deleteCode uid) claim key uid lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key - for_ oldKey $ lift . deleteKey + for_ oldKey $ lift . deleteKey d pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key where - updateEmailAndDeleteEmailUnvalidated :: UserId -> Email -> m () + updateEmailAndDeleteEmailUnvalidated :: UserId -> Email -> Sem r () updateEmailAndDeleteEmailUnvalidated u' email = updateEmail u' email <* deleteEmailUnvalidated u' + deleteCode :: UserId -> Sem r () + deleteCode uId = + -- FUTUREWORK: use the DeletePasswordResetCode action instead of CodeDelete + E.mkPasswordResetKey uId + >>= E.deletePasswordResetCode claim key uid = do - ok <- lift $ claimKey key uid + ok <- lift $ claimKey d key uid unless ok $ throwE . UserKeyExists . LT.fromStrict $ foldKey fromEmail fromPhone key -- | Create a new pending activation for a given 'UserKey'. newActivation :: - (MonadIO m, MonadClient m) => + Members '[ActivationKeyStore, ActivationSupply] r => UserKey -> -- | The timeout for the activation code. Timeout -> -- | The user with whom to associate the activation code. Maybe UserId -> - m Activation + Sem r Activation newActivation uk timeout u = do (typ, key, code) <- - liftIO $ - foldKey - (\e -> ("email",fromEmail e,) <$> genCode) - (\p -> ("phone",fromPhone p,) <$> genCode) - uk + foldKey + (\e -> ("email",fromEmail e,) <$> makeActivationCode) + (\p -> ("phone",fromPhone p,) <$> makeActivationCode) + uk insert typ key code where insert t k c = do - key <- liftIO $ mkActivationKey uk - retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, maxAttempts, round timeout) + key <- makeActivationKey uk + insertActivationKey (key, t, k, c, u, maxAttempts, round timeout) pure $ Activation key c - genCode = - ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" - <$> randIntegerZeroToNMinusOne 1000000 -- | Lookup an activation code and it's associated owner (if any) for a 'UserKey'. lookupActivationCode :: MonadClient m => UserKey -> m (Maybe (Maybe UserId, ActivationCode)) @@ -175,12 +190,12 @@ lookupActivationCode k = -- | Verify an activation code. verifyCode :: - MonadClient m => + Members '[ActivationKeyStore] r => ActivationKey -> ActivationCode -> - ExceptT ActivationError m (UserKey, Maybe UserId) + ExceptT ActivationError (Sem r) (UserKey, Maybe UserId) verifyCode key code = do - s <- lift . retry x1 . query1 keySelect $ params LocalQuorum (Identity key) + s <- lift . getActivationKey $ key case s of Just (ttl, Ascii t, k, c, u, r) -> if @@ -196,9 +211,12 @@ verifyCode key code = do Just p -> pure (userPhoneKey p, u) Nothing -> throwE invalidCode mkScope _ _ _ = throwE invalidCode - countdown = lift . retry x5 . write keyInsert . params LocalQuorum + countdown = lift . insertActivationKey + -- countdown = lift . retry x5 . write keyInsert . params LocalQuorum revoke = lift $ deleteActivationPair key +-- FUTUREWORK: This should be deleted and an effect action 'makeActivationKey' +-- should be used instead. mkActivationKey :: UserKey -> IO ActivationKey mkActivationKey k = do d <- liftIO $ getDigestByName "SHA256" @@ -206,26 +224,11 @@ mkActivationKey k = do let bs = digestBS d' (T.encodeUtf8 $ keyText k) pure . ActivationKey $ Ascii.encodeBase64Url bs -deleteActivationPair :: MonadClient m => ActivationKey -> m () -deleteActivationPair = write keyDelete . params LocalQuorum . Identity - invalidUser :: ActivationError invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." invalidCode :: ActivationError invalidCode = InvalidActivationCodeWrongCode -- "Invalid activation code" -keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () -keyInsert = - "INSERT INTO activation_keys \ - \(key, key_type, key_text, code, user, retries) VALUES \ - \(? , ? , ? , ? , ? , ? ) USING TTL ?" - -keySelect :: PrepQuery R (Identity ActivationKey) (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) -keySelect = "SELECT ttl(code) as ttl, key_type, key_text, code, user, retries FROM activation_keys WHERE key = ?" - codeSelect :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) codeSelect = "SELECT user, code FROM activation_keys WHERE key = ?" - -keyDelete :: PrepQuery W (Identity ActivationKey) () -keyDelete = "DELETE FROM activation_keys WHERE key = ?" diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 480f8bebf7..55fa90e70f 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -26,7 +26,6 @@ module Brig.Data.Client reAuthForNewClients, addClientWithReAuthPolicy, addClient, - rmClient, hasClient, lookupClient, lookupClients, @@ -55,31 +54,41 @@ import Bilge.Retry (httpHandlers) import Brig.AWS import Brig.App import Brig.Data.Instances () -import Brig.Data.User (AuthError (..), ReAuthError (..)) -import qualified Brig.Data.User as User +import Brig.Effects.ClientStore.Cassandra (key, lookupClients, toClient) +-- import Brig.Data.User (AuthError (..), ReAuthError (..)) +-- import qualified Brig.Data.User as User +-- import Brig.Options (setDefaultUserLocale) +import Brig.Effects.UserQuery import Brig.Types.Instances () import Brig.User.Auth.DB.Instances () import Cassandra as C hiding (Client) import Cassandra.Settings as C hiding (Client) +-- import Control.Arrow import Control.Error import qualified Control.Exception.Lens as EL import Control.Lens import Control.Monad.Catch import Control.Monad.Random (randomRIO) +-- import Control.Monad.Trans.Except import Control.Retry import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Conversion (toByteString, toByteString') import qualified Data.ByteString.Lazy as LBS +import Data.Either.Combinators import qualified Data.HashMap.Strict as HashMap import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import qualified Data.Map as Map import qualified Data.Metrics as Metrics import Data.Misc +import Data.Qualified import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.UUID as UUID import Imports +import Polysemy hiding (run) +import Polysemy.Error +import qualified Polysemy.Error as P +import Polysemy.Input import System.CryptoBox (Result (Success)) import qualified System.CryptoBox as CryptoBox import System.Logger.Class (field, msg, val) @@ -115,18 +124,19 @@ reAuthForNewClients :: ReAuthPolicy reAuthForNewClients count upsert = count > 0 && not upsert addClient :: - (MonadClient m, MonadReader Brig.App.Env m) => + Members '[Input (Local ()), UserQuery p] r => UserId -> ClientId -> NewClient -> Int -> Maybe Location -> Maybe (Imports.Set ClientCapability) -> - ExceptT ClientDataError m (Client, [Client], Word) + ExceptT ClientDataError (AppT r) (Client, [Client], Word) addClient = addClientWithReAuthPolicy reAuthForNewClients addClientWithReAuthPolicy :: - (MonadClient m, MonadReader Brig.App.Env m) => + forall r p. + Members '[Input (Local ()), UserQuery p] r => ReAuthPolicy -> UserId -> ClientId -> @@ -134,15 +144,19 @@ addClientWithReAuthPolicy :: Int -> Maybe Location -> Maybe (Imports.Set ClientCapability) -> - ExceptT ClientDataError m (Client, [Client], Word) -addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do - clients <- lookupClients u + ExceptT ClientDataError (AppT r) (Client, [Client], Word) +addClientWithReAuthPolicy _reAuthPolicy u newId c maxPermClients loc cps = do + clients <- lift . wrapClient $ lookupClients u + -- locale <- setDefaultUserLocale <$> view settings let typed = filter ((== newClientType c) . clientType) clients let count = length typed let upsert = any exists typed - when (reAuthPolicy count upsert) $ - fmapLT ClientReAuthError $ - User.reauthenticate u (newClientPassword c) + -- when (reAuthPolicy count upsert) $ do + -- liftSemE + -- . fmapLT ClientReAuthError + -- . semToExceptT + -- . raise @(P.Error ReAuthError) + -- $ User.reauthenticate locale u (newClientPassword c) let capacity = fmap (+ (-count)) limit unless (maybe True (> 0) capacity || upsert) $ throwE TooManyClients @@ -160,8 +174,8 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: (MonadClient m, MonadReader Brig.App.Env m) => ExceptT ClientDataError m Client - insert = do + insert :: ExceptT ClientDataError (AppT r) Client + insert = wrapClientE $ do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) let keys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c @@ -186,6 +200,9 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do clientMLSPublicKeys = mempty } +_semToExceptT :: Sem (P.Error e ': r) () -> ExceptT e (Sem r) () +_semToExceptT = lift . runError >=> flip whenLeft throwE + lookupClient :: MonadClient m => UserId -> ClientId -> m (Maybe Client) lookupClient u c = do keys <- retry x1 (query selectMLSPublicKeys (params LocalQuorum (u, c))) @@ -211,20 +228,6 @@ lookupPubClientsBulk uids = liftClient $ do executeQuery :: MonadClient m => UserId -> m [(ClientId, Maybe ClientClass)] executeQuery u = retry x1 (query selectPubClients (params LocalQuorum (Identity u))) -lookupClients :: MonadClient m => UserId -> m [Client] -lookupClients u = do - keys <- - (\(cid, ss, Blob b) -> (cid, [(ss, LBS.toStrict b)])) - <$$> retry x1 (query selectMLSPublicKeysByUser (params LocalQuorum (Identity u))) - let keyMap = Map.fromListWith (<>) keys - updateKeys c = - c - { clientMLSPublicKeys = - Map.fromList $ Map.findWithDefault [] (clientId c) keyMap - } - updateKeys . toClient [] - <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) - lookupClientIds :: MonadClient m => UserId -> m [ClientId] lookupClientIds u = map runIdentity @@ -244,19 +247,6 @@ lookupPrekeyIds u c = hasClient :: MonadClient m => UserId -> ClientId -> m Bool hasClient u d = isJust <$> retry x1 (query1 checkClient (params LocalQuorum (u, d))) -rmClient :: - ( MonadClient m, - MonadReader Brig.App.Env m, - MonadCatch m - ) => - UserId -> - ClientId -> - m () -rmClient u c = do - retry x5 $ write removeClient (params LocalQuorum (u, c)) - retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) - unlessM (isJust <$> view randomPrekeyLocalLock) $ deleteOptLock u c - updateClientLabel :: MonadClient m => UserId -> ClientId -> Maybe Text -> m () updateClientLabel u c l = retry x5 $ write updateClientLabelQuery (params LocalQuorum (l, u, c)) @@ -377,9 +367,6 @@ updateClientCapabilitiesQuery = "UPDATE clients SET capabilities = ? WHERE user selectClientIds :: PrepQuery R (Identity UserId) (Identity ClientId) selectClientIds = "SELECT client from clients where user = ?" -selectClients :: PrepQuery R (Identity UserId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Latitude, Maybe Longitude, Maybe Text, Maybe (C.Set ClientCapability)) -selectClients = "SELECT client, type, tstamp, label, class, cookie, lat, lon, model, capabilities from clients where user = ?" - selectPubClients :: PrepQuery R (Identity UserId) (ClientId, Maybe ClientClass) selectPubClients = "SELECT client, class from clients where user = ?" @@ -389,12 +376,6 @@ selectClient = "SELECT client, type, tstamp, label, class, cookie, lat, lon, mod insertClientKey :: PrepQuery W (UserId, ClientId, PrekeyId, Text) () insertClientKey = "INSERT INTO prekeys (user, client, key, data) VALUES (?, ?, ?, ?)" -removeClient :: PrepQuery W (UserId, ClientId) () -removeClient = "DELETE FROM clients where user = ? and client = ?" - -removeClientKeys :: PrepQuery W (UserId, ClientId) () -removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?" - userPrekey :: PrepQuery R (UserId, ClientId) (PrekeyId, Text) userPrekey = "SELECT key, data FROM prekeys where user = ? and client = ? LIMIT 1" @@ -416,9 +397,6 @@ selectMLSPublicKey = "SELECT key from mls_public_keys where user = ? and client selectMLSPublicKeys :: PrepQuery R (UserId, ClientId) (SignatureSchemeTag, Blob) selectMLSPublicKeys = "SELECT sig_scheme, key from mls_public_keys where user = ? and client = ?" -selectMLSPublicKeysByUser :: PrepQuery R (Identity UserId) (ClientId, SignatureSchemeTag, Blob) -selectMLSPublicKeysByUser = "SELECT client, sig_scheme, key from mls_public_keys where user = ?" - insertMLSPublicKeys :: PrepQuery W (UserId, ClientId, SignatureSchemeTag, Blob) Row insertMLSPublicKeys = "INSERT INTO mls_public_keys (user, client, sig_scheme, key) \ @@ -427,65 +405,15 @@ insertMLSPublicKeys = ------------------------------------------------------------------------------- -- Conversions -toClient :: - [(SignatureSchemeTag, Blob)] -> - ( ClientId, - ClientType, - UTCTimeMillis, - Maybe Text, - Maybe ClientClass, - Maybe CookieLabel, - Maybe Latitude, - Maybe Longitude, - Maybe Text, - Maybe (C.Set ClientCapability) - ) -> - Client -toClient keys (cid, cty, tme, lbl, cls, cok, lat, lon, mdl, cps) = - Client - { clientId = cid, - clientType = cty, - clientTime = tme, - clientClass = cls, - clientLabel = lbl, - clientCookie = cok, - clientLocation = location <$> lat <*> lon, - clientModel = mdl, - clientCapabilities = ClientCapabilityList $ maybe Set.empty (Set.fromList . C.fromSet) cps, - clientMLSPublicKeys = fmap (LBS.toStrict . fromBlob) (Map.fromList keys) - } - toPubClient :: (ClientId, Maybe ClientClass) -> PubClient toPubClient = uncurry PubClient ------------------------------------------------------------------------------- -- Best-effort optimistic locking for prekeys via DynamoDB -ddbClient :: Text -ddbClient = "client" - ddbVersion :: Text ddbVersion = "version" -ddbKey :: UserId -> ClientId -> AWS.AttributeValue -ddbKey u c = AWS.S (UUID.toText (toUUID u) <> "." <> client c) - -key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue -key u c = HashMap.singleton ddbClient (ddbKey u c) - -deleteOptLock :: - ( MonadReader Brig.App.Env m, - MonadCatch m, - MonadIO m - ) => - UserId -> - ClientId -> - m () -deleteOptLock u c = do - t <- view (awsEnv . prekeyTable) - e <- view (awsEnv . amazonkaEnv) - void $ exec e (AWS.newDeleteItem t & AWS.deleteItem_key .~ key u c) - withOptLock :: forall a m. ( MonadIO m, diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 7aa3adbb82..be2ec43304 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -38,15 +38,15 @@ module Brig.Data.User lookupAccounts, lookupUser, lookupUsers, - lookupName, + getName, lookupLocale, lookupPassword, lookupStatus, lookupRichInfo, lookupRichInfoMultiUsers, lookupUserTeam, - lookupServiceUsers, - lookupServiceUsersForTeam, + getServiceUsers, + getServiceUsersForTeam, lookupFeatureConferenceCalling, userExists, @@ -76,6 +76,29 @@ where import Brig.App (Env, currentTime, settings, viewFederationDomain, zauthEnv) import Brig.Data.Instances () +import Brig.Effects.UserQuery + ( AuthError (..), + ReAuthError (..), + UserQuery, + activateUser, + deleteEmailUnvalidated, + deleteServiceUser, + getAuthentication, + getId, + getLocale, + getName, + getServiceUsers, + getServiceUsersForTeam, + getUsers, + insertAccount, + isActivated, + lookupAccount, + lookupAccounts, + updateEmail, + updateHandle, + updatePhone, + updateStatus, + ) import Brig.Options import Brig.Password import Brig.Types.Intra @@ -84,7 +107,6 @@ import qualified Brig.ZAuth as ZAuth import Cassandra import Control.Error import Control.Lens hiding (from) -import Data.Conduit (ConduitM) import Data.Domain import Data.Handle (Handle) import Data.Id @@ -95,27 +117,14 @@ import Data.Range (fromRange) import Data.Time (addUTCTime) import Data.UUID.V4 import Imports +import Polysemy +import Polysemy.Error +import Polysemy.Input import Wire.API.Provider.Service import qualified Wire.API.Team.Feature as ApiFt import Wire.API.User import Wire.API.User.RichInfo --- | Authentication errors. -data AuthError - = AuthInvalidUser - | AuthInvalidCredentials - | AuthSuspended - | AuthEphemeral - | AuthPendingInvitation - --- | Re-authentication errors. -data ReAuthError - = ReAuthError !AuthError - | ReAuthMissingPassword - | ReAuthCodeVerificationRequired - | ReAuthCodeVerificationNoPendingCode - | ReAuthCodeVerificationNoEmail - -- | Preconditions: -- -- 1. @newUserUUID u == Just inv || isNothing (newUserUUID u)@. @@ -185,98 +194,68 @@ newAccountInviteViaScim uid tid locale name email = do ManagedByScim -- | Mandatory password authentication. -authenticate :: MonadClient m => UserId -> PlainTextPassword -> ExceptT AuthError m () +authenticate :: + Members + '[ Error AuthError, + UserQuery p + ] + r => + UserId -> + PlainTextPassword -> + Sem r () authenticate u pw = - lift (lookupAuth u) >>= \case - Nothing -> throwE AuthInvalidUser - Just (_, Deleted) -> throwE AuthInvalidUser - Just (_, Suspended) -> throwE AuthSuspended - Just (_, Ephemeral) -> throwE AuthEphemeral - Just (_, PendingInvitation) -> throwE AuthPendingInvitation - Just (Nothing, _) -> throwE AuthInvalidCredentials + lookupAuth u >>= \case + Nothing -> throw AuthInvalidUser + Just (_, Deleted) -> throw AuthInvalidUser + Just (_, Suspended) -> throw AuthSuspended + Just (_, Ephemeral) -> throw AuthEphemeral + Just (_, PendingInvitation) -> throw AuthPendingInvitation + Just (Nothing, _) -> throw AuthInvalidCredentials Just (Just pw', Active) -> unless (verifyPassword pw pw') $ - throwE AuthInvalidCredentials + throw AuthInvalidCredentials -- | Password reauthentication. If the account has a password, reauthentication -- is mandatory. If the account has no password, or is an SSO user, and no password is given, -- reauthentication is a no-op. -reauthenticate :: (MonadClient m, MonadReader Env m) => UserId -> Maybe PlainTextPassword -> ExceptT ReAuthError m () -reauthenticate u pw = - lift (lookupAuth u) >>= \case - Nothing -> throwE (ReAuthError AuthInvalidUser) - Just (_, Deleted) -> throwE (ReAuthError AuthInvalidUser) - Just (_, Suspended) -> throwE (ReAuthError AuthSuspended) - Just (_, PendingInvitation) -> throwE (ReAuthError AuthPendingInvitation) - Just (Nothing, _) -> for_ pw $ const (throwE $ ReAuthError AuthInvalidCredentials) +reauthenticate :: + Members + '[ Error ReAuthError, + Input (Local ()), + UserQuery p + ] + r => + Locale -> + UserId -> + Maybe PlainTextPassword -> + Sem r () +reauthenticate locale u pw = + lookupAuth u >>= \case + Nothing -> throw (ReAuthError AuthInvalidUser) + Just (_, Deleted) -> throw (ReAuthError AuthInvalidUser) + Just (_, Suspended) -> throw (ReAuthError AuthSuspended) + Just (_, PendingInvitation) -> throw (ReAuthError AuthPendingInvitation) + Just (Nothing, _) -> for_ pw $ const (throw $ ReAuthError AuthInvalidCredentials) Just (Just pw', Active) -> maybeReAuth pw' Just (Just pw', Ephemeral) -> maybeReAuth pw' where maybeReAuth pw' = case pw of - Nothing -> unlessM (isSamlUser u) $ throwE ReAuthMissingPassword + Nothing -> unlessM (isSamlUser locale u) $ throw ReAuthMissingPassword Just p -> unless (verifyPassword p pw') $ - throwE (ReAuthError AuthInvalidCredentials) - -isSamlUser :: (MonadClient m, MonadReader Env m) => UserId -> m Bool -isSamlUser uid = do - account <- lookupAccount uid + throw (ReAuthError AuthInvalidCredentials) + +isSamlUser :: + Members '[Input (Local ()), UserQuery p] r => + Locale -> + UserId -> + Sem r Bool +isSamlUser locale uid = do + account <- lookupAccount locale uid case userIdentity . accountUser =<< account of Just (SSOIdentity (UserSSOId _) _ _) -> pure True _ -> pure False -insertAccount :: - MonadClient m => - UserAccount -> - -- | If a bot: conversation and team - -- (if a team conversation) - Maybe (ConvId, Maybe TeamId) -> - Maybe Password -> - -- | Whether the user is activated - Bool -> - m () -insertAccount (UserAccount u status) mbConv password activated = retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - let Locale l c = userLocale u - addPrepQuery - userInsert - ( userId u, - userDisplayName u, - userPict u, - userAssets u, - userEmail u, - userPhone u, - userSSOId u, - userAccentId u, - password, - activated, - status, - userExpire u, - l, - c, - view serviceRefProvider <$> userService u, - view serviceRefId <$> userService u, - userHandle u, - userTeam u, - userManagedBy u - ) - for_ ((,) <$> userService u <*> mbConv) $ \(sref, (cid, mbTid)) -> do - let pid = sref ^. serviceRefProvider - sid = sref ^. serviceRefId - addPrepQuery cqlServiceUser (pid, sid, BotId (userId u), cid, mbTid) - for_ mbTid $ \tid -> - addPrepQuery cqlServiceTeam (pid, sid, BotId (userId u), cid, tid) - where - cqlServiceUser :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId) () - cqlServiceUser = - "INSERT INTO service_user (provider, service, user, conv, team) \ - \VALUES (?, ?, ?, ?, ?)" - cqlServiceTeam :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, TeamId) () - cqlServiceTeam = - "INSERT INTO service_team (provider, service, user, conv, team) \ - \VALUES (?, ?, ?, ?, ?)" - updateLocale :: MonadClient m => UserId -> Locale -> m () updateLocale u (Locale l c) = write userLocaleUpdate (params LocalQuorum (l, c, u)) @@ -289,15 +268,9 @@ updateUser u UserUpdate {..} = retry x5 . batch $ do for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) -updateEmail :: MonadClient m => UserId -> Email -> m () -updateEmail u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) - updateEmailUnvalidated :: MonadClient m => UserId -> Email -> m () updateEmailUnvalidated u e = retry x5 $ write userEmailUnvalidatedUpdate (params LocalQuorum (e, u)) -updatePhone :: MonadClient m => UserId -> Phone -> m () -updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) - updateSSOId :: MonadClient m => UserId -> Maybe UserSSOId -> m Bool updateSSOId u ssoid = do mteamid <- lookupUserTeam u @@ -310,8 +283,8 @@ updateSSOId u ssoid = do updateManagedBy :: MonadClient m => UserId -> ManagedBy -> m () updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum (h, u)) -updateHandle :: MonadClient m => UserId -> Handle -> m () -updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) +-- updateHandle :: MonadClient m => UserId -> Handle -> m () +-- updateHandle u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) updatePassword :: MonadClient m => UserId -> PlainTextPassword -> m () updatePassword u t = do @@ -333,45 +306,11 @@ updateFeatureConferenceCalling uid mbStatus = do deleteEmail :: MonadClient m => UserId -> m () deleteEmail u = retry x5 $ write userEmailDelete (params LocalQuorum (Identity u)) -deleteEmailUnvalidated :: MonadClient m => UserId -> m () -deleteEmailUnvalidated u = retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) - deletePhone :: MonadClient m => UserId -> m () deletePhone u = retry x5 $ write userPhoneDelete (params LocalQuorum (Identity u)) -deleteServiceUser :: MonadClient m => ProviderId -> ServiceId -> BotId -> m () -deleteServiceUser pid sid bid = do - lookupServiceUser pid sid bid >>= \case - Nothing -> pure () - Just (_, mbTid) -> retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery cql (pid, sid, bid) - for_ mbTid $ \tid -> - addPrepQuery cqlTeam (pid, sid, tid, bid) - where - cql :: PrepQuery W (ProviderId, ServiceId, BotId) () - cql = - "DELETE FROM service_user \ - \WHERE provider = ? AND service = ? AND user = ?" - cqlTeam :: PrepQuery W (ProviderId, ServiceId, TeamId, BotId) () - cqlTeam = - "DELETE FROM service_team \ - \WHERE provider = ? AND service = ? AND team = ? AND user = ?" - -updateStatus :: MonadClient m => UserId -> AccountStatus -> m () -updateStatus u s = - retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) - -userExists :: MonadClient m => UserId -> m Bool -userExists uid = isJust <$> retry x1 (query1 idSelect (params LocalQuorum (Identity uid))) - --- | Whether the account has been activated by verifying --- an email address or phone number. -isActivated :: MonadClient m => UserId -> m Bool -isActivated u = - (== Just (Identity True)) - <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) +userExists :: Member (UserQuery p) r => UserId -> Sem r Bool +userExists uid = isJust <$> getId uid filterActive :: MonadClient m => [UserId] -> m [UserId] filterActive us = @@ -382,28 +321,25 @@ filterActive us = isActiveUser (_, True, Just Active) = True isActiveUser _ = False -lookupUser :: (MonadClient m, MonadReader Env m) => HavePendingInvitations -> UserId -> m (Maybe User) -lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] - -activateUser :: MonadClient m => UserId -> UserIdentity -> m () -activateUser u ident = do - let email = emailIdentity ident - let phone = phoneIdentity ident - retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) +lookupUser :: + Member (UserQuery p) r => + Local x -> + Locale -> + HavePendingInvitations -> + UserId -> + Sem r (Maybe User) +lookupUser loc locale hpi u = listToMaybe <$> lookupUsers loc locale hpi [u] deactivateUser :: MonadClient m => UserId -> m () deactivateUser u = retry x5 $ write userDeactivatedUpdate (params LocalQuorum (Identity u)) -lookupLocale :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe Locale) -lookupLocale u = do - defLoc <- setDefaultUserLocale <$> view settings - fmap (toLocale defLoc) <$> retry x1 (query1 localeSelect (params LocalQuorum (Identity u))) - -lookupName :: MonadClient m => UserId -> m (Maybe Name) -lookupName u = - fmap runIdentity - <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) +lookupLocale :: + Member (UserQuery p) r => + Locale -> + UserId -> + Sem r (Maybe Locale) +lookupLocale defLoc u = fmap (toLocale defLoc) <$> getLocale u lookupPassword :: MonadClient m => UserId -> m (Maybe Password) lookupPassword u = @@ -434,64 +370,26 @@ lookupUserTeam u = (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u))) -lookupAuth :: MonadClient m => UserId -> m (Maybe (Maybe Password, AccountStatus)) -lookupAuth u = fmap f <$> retry x1 (query1 authSelect (params LocalQuorum (Identity u))) +lookupAuth :: + Member (UserQuery p) r => + UserId -> + Sem r (Maybe (Maybe Password, AccountStatus)) +lookupAuth u = fmap f <$> getAuthentication u where f (pw, st) = (pw, fromMaybe Active st) -- | Return users with given IDs. -- -- Skips nonexistent users. /Does not/ skip users who have been deleted. -lookupUsers :: (MonadClient m, MonadReader Env m) => HavePendingInvitations -> [UserId] -> m [User] -lookupUsers hpi usrs = do - loc <- setDefaultUserLocale <$> view settings - domain <- viewFederationDomain - toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) - -lookupAccount :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe UserAccount) -lookupAccount u = listToMaybe <$> lookupAccounts [u] - -lookupAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [UserAccount] -lookupAccounts usrs = do - loc <- setDefaultUserLocale <$> view settings - domain <- viewFederationDomain - fmap (toUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) - -lookupServiceUser :: MonadClient m => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) -lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) - where - cql :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) - cql = - "SELECT conv, team FROM service_user \ - \WHERE provider = ? AND service = ? AND user = ?" - --- | NB: might return a lot of users, and therefore we do streaming here (page-by-page). -lookupServiceUsers :: - MonadClient m => - ProviderId -> - ServiceId -> - ConduitM () [(BotId, ConvId, Maybe TeamId)] m () -lookupServiceUsers pid sid = - paginateC cql (paramsP LocalQuorum (pid, sid) 100) x1 - where - cql :: PrepQuery R (ProviderId, ServiceId) (BotId, ConvId, Maybe TeamId) - cql = - "SELECT user, conv, team FROM service_user \ - \WHERE provider = ? AND service = ?" - -lookupServiceUsersForTeam :: - MonadClient m => - ProviderId -> - ServiceId -> - TeamId -> - ConduitM () [(BotId, ConvId)] m () -lookupServiceUsersForTeam pid sid tid = - paginateC cql (paramsP LocalQuorum (pid, sid, tid) 100) x1 - where - cql :: PrepQuery R (ProviderId, ServiceId, TeamId) (BotId, ConvId) - cql = - "SELECT user, conv FROM service_team \ - \WHERE provider = ? AND service = ? AND team = ?" +lookupUsers :: + Member (UserQuery p) r => + Local x -> + Locale -> + HavePendingInvitations -> + [UserId] -> + Sem r [User] +lookupUsers loc locale hpi usrs = + toUsers (tDomain loc) locale hpi <$> getUsers usrs lookupFeatureConferenceCalling :: MonadClient m => UserId -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) lookupFeatureConferenceCalling uid = do @@ -530,77 +428,9 @@ type UserRow = Maybe ManagedBy ) -type UserRowInsert = - ( UserId, - Name, - Pict, - [Asset], - Maybe Email, - Maybe Phone, - Maybe UserSSOId, - ColourId, - Maybe Password, - Activated, - AccountStatus, - Maybe UTCTimeMillis, - Language, - Maybe Country, - Maybe ProviderId, - Maybe ServiceId, - Maybe Handle, - Maybe TeamId, - ManagedBy - ) - -deriving instance Show UserRowInsert - --- Represents a 'UserAccount' -type AccountRow = - ( UserId, - Name, - Maybe Pict, - Maybe Email, - Maybe Phone, - Maybe UserSSOId, - ColourId, - Maybe [Asset], - Activated, - Maybe AccountStatus, - Maybe UTCTimeMillis, - Maybe Language, - Maybe Country, - Maybe ProviderId, - Maybe ServiceId, - Maybe Handle, - Maybe TeamId, - Maybe ManagedBy - ) - -usersSelect :: PrepQuery R (Identity [UserId]) UserRow -usersSelect = - "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, service, \ - \handle, team, managed_by \ - \FROM user where id IN ?" - -idSelect :: PrepQuery R (Identity UserId) (Identity UserId) -idSelect = "SELECT id FROM user WHERE id = ?" - -nameSelect :: PrepQuery R (Identity UserId) (Identity Name) -nameSelect = "SELECT name FROM user WHERE id = ?" - -localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) -localeSelect = "SELECT language, country FROM user WHERE id = ?" - -authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus) -authSelect = "SELECT password, status FROM user WHERE id = ?" - passwordSelect :: PrepQuery R (Identity UserId) (Identity (Maybe Password)) passwordSelect = "SELECT password FROM user WHERE id = ?" -activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) -activatedSelect = "SELECT activated FROM user WHERE id = ?" - accountStateSelectAll :: PrepQuery R (Identity [UserId]) (UserId, Bool, Maybe AccountStatus) accountStateSelectAll = "SELECT id, activated, status FROM user WHERE id IN ?" @@ -616,19 +446,12 @@ richInfoSelectMulti = "SELECT user, json FROM rich_info WHERE user in ?" teamSelect :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId)) teamSelect = "SELECT team FROM user WHERE id = ?" -accountsSelect :: PrepQuery R (Identity [UserId]) AccountRow -accountsSelect = - "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, \ - \service, handle, team, managed_by \ - \FROM user WHERE id IN ?" - -userInsert :: PrepQuery W UserRowInsert () -userInsert = - "INSERT INTO user (id, name, picture, assets, email, phone, sso_id, \ - \accent_id, password, activated, status, expires, language, \ - \country, provider, service, handle, team, managed_by) \ - \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" +-- userInsert :: PrepQuery W UserRowInsert () +-- userInsert = +-- "INSERT INTO user (id, name, picture, assets, email, phone, sso_id, \ +-- \accent_id, password, activated, status, expires, language, \ +-- \country, provider, service, handle, team, managed_by) \ +-- \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" userDisplayNameUpdate :: PrepQuery W (Name, UserId) () userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" @@ -642,39 +465,21 @@ userAssetsUpdate = "UPDATE user SET assets = ? WHERE id = ?" userAccentIdUpdate :: PrepQuery W (ColourId, UserId) () userAccentIdUpdate = "UPDATE user SET accent_id = ? WHERE id = ?" -userEmailUpdate :: PrepQuery W (Email, UserId) () -userEmailUpdate = "UPDATE user SET email = ? WHERE id = ?" - userEmailUnvalidatedUpdate :: PrepQuery W (Email, UserId) () userEmailUnvalidatedUpdate = "UPDATE user SET email_unvalidated = ? WHERE id = ?" -userEmailUnvalidatedDelete :: PrepQuery W (Identity UserId) () -userEmailUnvalidatedDelete = "UPDATE user SET email_unvalidated = null WHERE id = ?" - -userPhoneUpdate :: PrepQuery W (Phone, UserId) () -userPhoneUpdate = "UPDATE user SET phone = ? WHERE id = ?" - userSSOIdUpdate :: PrepQuery W (Maybe UserSSOId, UserId) () userSSOIdUpdate = "UPDATE user SET sso_id = ? WHERE id = ?" userManagedByUpdate :: PrepQuery W (ManagedBy, UserId) () userManagedByUpdate = "UPDATE user SET managed_by = ? WHERE id = ?" -userHandleUpdate :: PrepQuery W (Handle, UserId) () -userHandleUpdate = "UPDATE user SET handle = ? WHERE id = ?" - userPasswordUpdate :: PrepQuery W (Password, UserId) () userPasswordUpdate = "UPDATE user SET password = ? WHERE id = ?" -userStatusUpdate :: PrepQuery W (AccountStatus, UserId) () -userStatusUpdate = "UPDATE user SET status = ? WHERE id = ?" - userDeactivatedUpdate :: PrepQuery W (Identity UserId) () userDeactivatedUpdate = "UPDATE user SET activated = false WHERE id = ?" -userActivatedUpdate :: PrepQuery W (Maybe Email, Maybe Phone, UserId) () -userActivatedUpdate = "UPDATE user SET activated = true, email = ?, phone = ? WHERE id = ?" - userLocaleUpdate :: PrepQuery W (Language, Maybe Country, UserId) () userLocaleUpdate = "UPDATE user SET language = ?, country = ? WHERE id = ?" @@ -690,54 +495,6 @@ userRichInfoUpdate = "UPDATE rich_info SET json = ? WHERE user = ?" ------------------------------------------------------------------------------- -- Conversions --- | Construct a 'UserAccount' from a raw user record in the database. -toUserAccount :: Domain -> Locale -> AccountRow -> UserAccount -toUserAccount - domain - defaultLocale - ( uid, - name, - pict, - email, - phone, - ssoid, - accent, - assets, - activated, - status, - expires, - lan, - con, - pid, - sid, - handle, - tid, - managed_by - ) = - let ident = toIdentity activated email phone ssoid - deleted = Just Deleted == status - expiration = if status == Just Ephemeral then expires else Nothing - loc = toLocale defaultLocale (lan, con) - svc = newServiceRef <$> sid <*> pid - in UserAccount - ( User - uid - (Qualified uid domain) - ident - name - (fromMaybe noPict pict) - (fromMaybe [] assets) - accent - deleted - loc - svc - handle - expiration - tid - (fromMaybe ManagedByWire managed_by) - ) - (fromMaybe Active status) - toUsers :: Domain -> Locale -> HavePendingInvitations -> [UserRow] -> [User] toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp where diff --git a/services/brig/src/Brig/Data/UserKey.hs b/services/brig/src/Brig/Data/UserKey.hs index 28c4212435..903a2a7793 100644 --- a/services/brig/src/Brig/Data/UserKey.hs +++ b/services/brig/src/Brig/Data/UserKey.hs @@ -17,8 +17,7 @@ -- | Natural, addressable external identifiers of users. module Brig.Data.UserKey - ( UserKey, - userEmailKey, + ( userEmailKey, userPhoneKey, forEmailKey, forPhoneKey, @@ -27,90 +26,41 @@ module Brig.Data.UserKey keyTextOriginal, claimKey, keyAvailable, - lookupKey, + getKey, deleteKey, deleteKeyForUser, lookupPhoneHashes, ) where -import Brig.App (Env, digestSHA256) import Brig.Data.Instances () import qualified Brig.Data.User as User +import Brig.Effects.UserKeyStore +import Brig.Effects.UserQuery (UserQuery) import Brig.Email import Brig.Phone +import Brig.Types.Common import Cassandra -import Control.Lens (view) import qualified Data.ByteString as B -import Data.ByteString.Lazy (toStrict) import Data.Id import qualified Data.Multihash.Digest as MH -import qualified Data.Text.Encoding as T import Imports -import OpenSSL.EVP.Digest (digestBS) +import OpenSSL.EVP.Digest (Digest) +import Polysemy import Wire.API.User (fromEmail) --- | 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 - -data UKHashType - = UKHashPhone - | UKHashEmail - deriving (Eq) - -instance Cql UKHashType where - ctype = Tagged IntColumn - - fromCql (CqlInt i) = case i of - 0 -> pure UKHashPhone - 1 -> pure UKHashEmail - n -> Left $ "unexpected hashtype: " ++ show n - fromCql _ = Left "userkeyhashtype: int expected" - - toCql UKHashPhone = CqlInt 0 - toCql UKHashEmail = CqlInt 1 - -newtype UserKeyHash = UserKeyHash MH.MultihashDigest - -instance Cql UserKeyHash where - ctype = Tagged BlobColumn - - fromCql (CqlBlob lbs) = case MH.decode (toStrict lbs) of - Left e -> Left ("userkeyhash: " ++ e) - Right h -> pure $ UserKeyHash h - fromCql _ = Left "userkeyhash: expected blob" - - toCql (UserKeyHash d) = CqlBlob $ MH.encode (MH.algorithm d) (MH.digest d) - userEmailKey :: Email -> UserKey userEmailKey = UserEmailKey . mkEmailKey userPhoneKey :: Phone -> UserKey userPhoneKey = UserPhoneKey . mkPhoneKey -foldKey :: (Email -> a) -> (Phone -> a) -> UserKey -> a -foldKey f g k = case k of - UserEmailKey ek -> f (emailKeyOrig ek) - UserPhoneKey pk -> g (phoneKeyOrig pk) - forEmailKey :: Applicative f => UserKey -> (Email -> f a) -> f (Maybe a) forEmailKey k f = foldKey (fmap Just . f) (const (pure Nothing)) k forPhoneKey :: Applicative f => UserKey -> (Phone -> f a) -> f (Maybe a) forPhoneKey k f = foldKey (const (pure Nothing)) (fmap Just . f) k --- | Get the normalised text of a 'UserKey'. -keyText :: UserKey -> Text -keyText (UserEmailKey k) = emailKeyUniq k -keyText (UserPhoneKey k) = phoneKeyUniq k - -- | Get the original text of a 'UserKey', i.e. the original phone number -- or email address. keyTextOriginal :: UserKey -> Text @@ -119,52 +69,36 @@ keyTextOriginal (UserPhoneKey k) = fromPhone (phoneKeyOrig k) -- | Claim a 'UserKey' for a user. claimKey :: - (MonadClient m, MonadReader Env m) => + Members '[UserKeyStore, UserQuery p] r => + -- | The SHA256 digest + Digest -> -- | The key to claim. UserKey -> -- | The user claiming the key. UserId -> - m Bool -claimKey k u = do + Sem r Bool +claimKey d k u = do free <- keyAvailable k (Just u) - when free (insertKey u k) + when free (insertKey d u k) pure free -- | Check whether a 'UserKey' is available. -- A key is available if it is not already actived for another user or -- if the other user and the user looking to claim the key are the same. keyAvailable :: - MonadClient m => + Members '[UserKeyStore, UserQuery p] r => -- | The key to check. UserKey -> -- | The user looking to claim the key, if any. Maybe UserId -> - m Bool + Sem r Bool keyAvailable k u = do - o <- lookupKey k + o <- getKey k case (o, u) of (Nothing, _) -> pure True (Just x, Just y) | x == y -> pure True (Just x, _) -> not <$> User.isActivated x -lookupKey :: MonadClient m => UserKey -> m (Maybe UserId) -lookupKey k = - fmap runIdentity - <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) - -insertKey :: (MonadClient m, MonadReader Env m) => UserId -> UserKey -> m () -insertKey u k = do - hk <- hashKey k - let kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k - retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) - retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) - -deleteKey :: (MonadClient m, MonadReader Env m) => UserKey -> m () -deleteKey k = do - hk <- hashKey k - retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) - retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) - -- | Delete `UserKey` for `UserId` -- -- This function ensures that keys of other users aren't accidentally deleted. @@ -173,20 +107,18 @@ deleteKey k = do -- executed several times due to cassandra not supporting transactions) -- `deleteKeyForUser` does not fail for missing keys or keys that belong to -- another user: It always returns `()` as result. -deleteKeyForUser :: (MonadClient m, MonadReader Env m) => UserId -> UserKey -> m () -deleteKeyForUser uid k = do - mbKeyUid <- lookupKey k +deleteKeyForUser :: + Member UserKeyStore r => + Digest -> + UserId -> + UserKey -> + Sem r () +deleteKeyForUser d uid k = do + mbKeyUid <- getKey k case mbKeyUid of - Just keyUid | keyUid == uid -> deleteKey k + Just keyUid | keyUid == uid -> deleteKey d k _ -> pure () -hashKey :: MonadReader Env m => UserKey -> m UserKeyHash -hashKey uk = do - d <- view digestSHA256 - let d' = digestBS d $ T.encodeUtf8 (keyText uk) - pure . UserKeyHash $ - MH.MultihashDigest MH.SHA256 (B.length d') d' - lookupPhoneHashes :: MonadClient m => [ByteString] -> m [(ByteString, UserId)] lookupPhoneHashes hp = mapMaybe mk <$> retry x1 (query selectHashed (params One (Identity hashed))) @@ -198,20 +130,5 @@ lookupPhoneHashes hp = -------------------------------------------------------------------------------- -- Queries -keyInsert :: PrepQuery W (Text, UserId) () -keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" - -keySelect :: PrepQuery R (Identity Text) (Identity UserId) -keySelect = "SELECT user FROM user_keys WHERE key = ?" - -keyDelete :: PrepQuery W (Identity Text) () -keyDelete = "DELETE FROM user_keys WHERE key = ?" - -insertHashed :: PrepQuery W (UserKeyHash, UKHashType, UserId) () -insertHashed = "INSERT INTO user_keys_hash(key, key_type, user) VALUES (?, ?, ?)" - -deleteHashed :: PrepQuery W (Identity UserKeyHash) () -deleteHashed = "DELETE FROM user_keys_hash WHERE key = ?" - selectHashed :: PrepQuery R (Identity [UserKeyHash]) (UserKeyHash, UKHashType, UserId) selectHashed = "SELECT key, key_type, user FROM user_keys_hash WHERE key IN ?" diff --git a/services/brig/src/Brig/Effects/ActivationKeyStore.hs b/services/brig/src/Brig/Effects/ActivationKeyStore.hs new file mode 100644 index 0000000000..bccd53ffa6 --- /dev/null +++ b/services/brig/src/Brig/Effects/ActivationKeyStore.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ActivationKeyStore where + +import Cassandra (Ascii) +import Data.Id +import Imports +import Polysemy +import Wire.API.User.Activation + +-- | Max. number of activation attempts per 'ActivationKey'. +maxAttempts :: Int32 +maxAttempts = 3 + +type GetKeyTuple = (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) + +type InsertKeyTuple = (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) + +data ActivationKeyStore m a where + GetActivationKey :: ActivationKey -> ActivationKeyStore m (Maybe GetKeyTuple) + InsertActivationKey :: InsertKeyTuple -> ActivationKeyStore m () + DeleteActivationPair :: ActivationKey -> ActivationKeyStore m () + +makeSem ''ActivationKeyStore diff --git a/services/brig/src/Brig/Effects/ActivationKeyStore/Cassandra.hs b/services/brig/src/Brig/Effects/ActivationKeyStore/Cassandra.hs new file mode 100644 index 0000000000..e94be37f84 --- /dev/null +++ b/services/brig/src/Brig/Effects/ActivationKeyStore/Cassandra.hs @@ -0,0 +1,60 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ActivationKeyStore.Cassandra (activationKeyStoreToCassandra) where + +import Brig.Data.Instances () +import Brig.Effects.ActivationKeyStore +import Cassandra +import Data.Id +import Imports +import Polysemy +import Wire.API.User.Activation + +activationKeyStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (ActivationKeyStore ': r) a -> + Sem r a +activationKeyStoreToCassandra = + interpret $ + embed @m . \case + GetActivationKey k -> getKey k + InsertActivationKey tuple -> keyInsertQuery tuple + DeleteActivationPair k -> keyDelete k + +getKey :: MonadClient m => ActivationKey -> m (Maybe GetKeyTuple) +getKey key = retry x1 . query1 keySelect $ params LocalQuorum (Identity key) + where + keySelect :: PrepQuery R (Identity ActivationKey) (Int32, Ascii, Text, ActivationCode, Maybe UserId, Int32) + keySelect = "SELECT ttl(code) as ttl, key_type, key_text, code, user, retries FROM activation_keys WHERE key = ?" + +keyInsertQuery :: MonadClient m => InsertKeyTuple -> m () +keyInsertQuery (key, t, k, c, u, attempts, timeout) = + retry x5 . write keyInsert $ params LocalQuorum (key, t, k, c, u, attempts, timeout) + where + keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () + keyInsert = + "INSERT INTO activation_keys \ + \(key, key_type, key_text, code, user, retries) VALUES \ + \(? , ? , ? , ? , ? , ? ) USING TTL ?" + +keyDelete :: MonadClient m => ActivationKey -> m () +keyDelete = write q . params LocalQuorum . Identity + where + q :: PrepQuery W (Identity ActivationKey) () + q = "DELETE FROM activation_keys WHERE key = ?" diff --git a/services/brig/src/Brig/Effects/ActivationSupply.hs b/services/brig/src/Brig/Effects/ActivationSupply.hs new file mode 100644 index 0000000000..b0263dfb4d --- /dev/null +++ b/services/brig/src/Brig/Effects/ActivationSupply.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ActivationSupply where + +import Brig.Types.Common +import Polysemy +import Wire.API.User.Activation + +data ActivationSupply m a where + MakeActivationKey :: UserKey -> ActivationSupply m ActivationKey + MakeActivationCode :: ActivationSupply m ActivationCode + +makeSem ''ActivationSupply diff --git a/services/brig/src/Brig/Effects/ActivationSupply/IO.hs b/services/brig/src/Brig/Effects/ActivationSupply/IO.hs new file mode 100644 index 0000000000..eb11e90ae8 --- /dev/null +++ b/services/brig/src/Brig/Effects/ActivationSupply/IO.hs @@ -0,0 +1,53 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ActivationSupply.IO (activationSupplyToIO) where + +import Brig.Effects.ActivationSupply +import Brig.Types.Common +import Data.Text +import qualified Data.Text.Ascii as Ascii +import qualified Data.Text.Encoding as T +import Imports +import OpenSSL.BN +import OpenSSL.EVP.Digest +import Polysemy +import Text.Printf +import Wire.API.User.Activation + +activationSupplyToIO :: + forall r a. + Member (Embed IO) r => + Sem (ActivationSupply ': r) a -> + Sem r a +activationSupplyToIO = + interpret $ + embed @IO . \case + MakeActivationKey key -> mkActivationKey key + MakeActivationCode -> mkActivationCode + +mkActivationKey :: UserKey -> IO ActivationKey +mkActivationKey k = do + d <- liftIO $ getDigestByName "SHA256" + d' <- maybe (fail "SHA256 not found") pure d + let bs = digestBS d' (T.encodeUtf8 $ keyText k) + pure . ActivationKey $ Ascii.encodeBase64Url bs + +mkActivationCode :: IO ActivationCode +mkActivationCode = + ActivationCode . Ascii.unsafeFromText . pack . printf "%06d" + <$> randIntegerZeroToNMinusOne 1000000 diff --git a/services/brig/src/Brig/Effects/BlacklistStore.hs b/services/brig/src/Brig/Effects/BlacklistStore.hs index d116bc5b18..783713d571 100644 --- a/services/brig/src/Brig/Effects/BlacklistStore.hs +++ b/services/brig/src/Brig/Effects/BlacklistStore.hs @@ -2,7 +2,7 @@ module Brig.Effects.BlacklistStore where -import Brig.Data.UserKey +import Brig.Types.Common import Imports import Polysemy diff --git a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs b/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs index 995926b704..c4321d5325 100644 --- a/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/BlacklistStore/Cassandra.hs @@ -1,3 +1,20 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.BlacklistStore.Cassandra ( interpretBlacklistStoreToCassandra, ) @@ -5,6 +22,7 @@ where import Brig.Data.UserKey import Brig.Effects.BlacklistStore (BlacklistStore (..)) +import Brig.Types.Common import Cassandra import Imports import Polysemy diff --git a/services/brig/src/Brig/Budget.hs b/services/brig/src/Brig/Effects/BudgetStore.hs similarity index 71% rename from services/brig/src/Brig/Budget.hs rename to services/brig/src/Brig/Effects/BudgetStore.hs index cf952a3ed7..a15600e5cf 100644 --- a/services/brig/src/Brig/Budget.hs +++ b/services/brig/src/Brig/Effects/BudgetStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} -- This file is part of the Wire Server implementation. -- @@ -17,20 +18,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Brig.Budget - ( Budget (..), - BudgetKey (..), - Budgeted (..), - withBudget, - checkBudget, - lookupBudget, - insertBudget, - ) -where +module Brig.Effects.BudgetStore where -import Cassandra +import Cassandra (Cql) import Data.Time.Clock import Imports +import Polysemy data Budget = Budget { budgetTimeout :: !NominalDiffTime, @@ -46,6 +39,12 @@ data Budgeted a newtype BudgetKey = BudgetKey Text deriving (Eq, Show, Cql) +data BudgetStore m a where + GetBudget :: BudgetKey -> BudgetStore m (Maybe (Int32, Int32)) + InsertBudget :: BudgetKey -> Budget -> BudgetStore m () + +makeSem ''BudgetStore + -- | @withBudget (BudgetKey "k") (Budget 30 5) action@ runs @action@ at most 5 times every 30 -- seconds. @"k"@ is used for keeping different calls to 'withBudget' apart; use something -- there that's unique to your context, like @"login#" <> uid@. @@ -58,7 +57,12 @@ newtype BudgetKey = BudgetKey Text -- -- FUTUREWORK: exceptions are not handled very nicely, but it's not clear what it would mean -- to improve this. -withBudget :: MonadClient m => BudgetKey -> Budget -> m a -> m (Budgeted a) +withBudget :: + Member BudgetStore r => + BudgetKey -> + Budget -> + Sem r a -> + Sem r (Budgeted a) withBudget k b ma = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 @@ -70,7 +74,7 @@ withBudget k b ma = do pure (BudgetedValue a remaining) -- | Like 'withBudget', but does not decrease budget, only takes a look. -checkBudget :: MonadClient m => BudgetKey -> Budget -> m (Budgeted ()) +checkBudget :: Member BudgetStore r => BudgetKey -> Budget -> Sem r (Budgeted ()) checkBudget k b = do Budget ttl val <- fromMaybe b <$> lookupBudget k let remaining = val - 1 @@ -79,20 +83,7 @@ checkBudget k b = do then BudgetExhausted ttl else BudgetedValue () remaining -lookupBudget :: MonadClient m => BudgetKey -> m (Maybe Budget) -lookupBudget k = fmap mk <$> query1 budgetSelect (params One (Identity k)) +lookupBudget :: Member BudgetStore r => BudgetKey -> Sem r (Maybe Budget) +lookupBudget k = fmap mk <$> getBudget k where mk (val, ttl) = Budget (fromIntegral ttl) val - -insertBudget :: MonadClient m => BudgetKey -> Budget -> m () -insertBudget k (Budget ttl val) = - retry x5 $ write budgetInsert (params One (k, val, round ttl)) - -------------------------------------------------------------------------------- --- Queries - -budgetInsert :: PrepQuery W (BudgetKey, Int32, Int32) () -budgetInsert = "INSERT INTO budget (key, budget) VALUES (?, ?) USING TTL ?" - -budgetSelect :: PrepQuery R (Identity BudgetKey) (Int32, Int32) -budgetSelect = "SELECT budget, ttl(budget) FROM budget where key = ?" diff --git a/services/brig/src/Brig/Effects/BudgetStore/Cassandra.hs b/services/brig/src/Brig/Effects/BudgetStore/Cassandra.hs new file mode 100644 index 0000000000..c71d723b85 --- /dev/null +++ b/services/brig/src/Brig/Effects/BudgetStore/Cassandra.hs @@ -0,0 +1,41 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.BudgetStore.Cassandra where + +import Brig.Effects.BudgetStore +import Cassandra +import Imports +import Polysemy + +budgetStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (BudgetStore ': r) a -> + Sem r a +budgetStoreToCassandra = + interpret $ + embed @m . \case + GetBudget k -> query1 budgetSelect (params One (Identity k)) + InsertBudget k (Budget ttl b) -> + retry x5 $ write budgetInsert (params One (k, b, round ttl)) + +budgetInsert :: PrepQuery W (BudgetKey, Int32, Int32) () +budgetInsert = "INSERT INTO budget (key, budget) VALUES (?, ?) USING TTL ?" + +budgetSelect :: PrepQuery R (Identity BudgetKey) (Int32, Int32) +budgetSelect = "SELECT budget, ttl(budget) FROM budget where key = ?" diff --git a/services/brig/src/Brig/Effects/ClientStore.hs b/services/brig/src/Brig/Effects/ClientStore.hs new file mode 100644 index 0000000000..d2e330db17 --- /dev/null +++ b/services/brig/src/Brig/Effects/ClientStore.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ClientStore where + +import Data.Id +import Polysemy +import Wire.API.User.Client + +data ClientStore m a where + LookupClients :: UserId -> ClientStore m [Client] + DeleteClient :: UserId -> ClientId -> ClientStore m () + +makeSem ''ClientStore diff --git a/services/brig/src/Brig/Effects/ClientStore/Cassandra.hs b/services/brig/src/Brig/Effects/ClientStore/Cassandra.hs new file mode 100644 index 0000000000..03ee42919b --- /dev/null +++ b/services/brig/src/Brig/Effects/ClientStore/Cassandra.hs @@ -0,0 +1,161 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.ClientStore.Cassandra + ( clientStoreToCassandra, + -- FUTUREWORK: Do not export the names below once the module Brig.Data.Client has been + -- polysemised. + lookupClients, + rmClient, + toClient, + key, + ) +where + +import qualified Amazonka.DynamoDB as AWS +import qualified Amazonka.DynamoDB.DeleteItem as AWS +import Brig.AWS hiding (Env) +import Brig.App +import Brig.Data.Instances () +import qualified Brig.Effects.ClientStore as E +import Brig.User.Auth.DB.Instances () +import Cassandra hiding (Client) +import qualified Cassandra as C +import Control.Lens (view, (.~)) +import Control.Monad.Catch +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import Data.Id +import Data.Json.Util +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.UUID as UUID +import Imports +import Polysemy +import Wire.API.MLS.Credential +import Wire.API.User.Auth +import Wire.API.User.Client + +clientStoreToCassandra :: + forall m r a. + ( MonadCatch m, + MonadClient m, + MonadReader Env m, + Member (Embed m) r + ) => + Sem (E.ClientStore ': r) a -> + Sem r a +clientStoreToCassandra = + interpret $ + embed @m . \case + E.LookupClients uid -> lookupClients uid + E.DeleteClient uid cid -> rmClient uid cid + +lookupClients :: MonadClient m => UserId -> m [Client] +lookupClients u = do + keys <- + (\(cid, ss, Blob b) -> (cid, [(ss, LBS.toStrict b)])) + <$$> retry x1 (query selectMLSPublicKeysByUser (params LocalQuorum (Identity u))) + let keyMap = Map.fromListWith (<>) keys + updateKeys c = + c + { clientMLSPublicKeys = + Map.fromList $ Map.findWithDefault [] (clientId c) keyMap + } + updateKeys . toClient [] + <$$> retry x1 (query selectClients (params LocalQuorum (Identity u))) + +selectMLSPublicKeysByUser :: PrepQuery R (Identity UserId) (ClientId, SignatureSchemeTag, Blob) +selectMLSPublicKeysByUser = "SELECT client, sig_scheme, key from mls_public_keys where user = ?" + +selectClients :: PrepQuery R (Identity UserId) (ClientId, ClientType, UTCTimeMillis, Maybe Text, Maybe ClientClass, Maybe CookieLabel, Maybe Latitude, Maybe Longitude, Maybe Text, Maybe (C.Set ClientCapability)) +selectClients = "SELECT client, type, tstamp, label, class, cookie, lat, lon, model, capabilities from clients where user = ?" + +rmClient :: + ( MonadClient m, + MonadReader Env m, + MonadCatch m + ) => + UserId -> + ClientId -> + m () +rmClient u c = do + retry x5 $ write removeClient (params LocalQuorum (u, c)) + retry x5 $ write removeClientKeys (params LocalQuorum (u, c)) + unlessM (isJust <$> view randomPrekeyLocalLock) $ deleteOptLock u c + +removeClient :: PrepQuery W (UserId, ClientId) () +removeClient = "DELETE FROM clients where user = ? and client = ?" + +removeClientKeys :: PrepQuery W (UserId, ClientId) () +removeClientKeys = "DELETE FROM prekeys where user = ? and client = ?" + +deleteOptLock :: + ( MonadReader Env m, + MonadCatch m, + MonadIO m + ) => + UserId -> + ClientId -> + m () +deleteOptLock u c = do + t <- view (awsEnv . prekeyTable) + e <- view (awsEnv . amazonkaEnv) + void $ exec e (AWS.newDeleteItem t & AWS.deleteItem_key .~ key u c) + +-------------------------------------------------------------------------------- +-- Conversions + +toClient :: + [(SignatureSchemeTag, Blob)] -> + ( ClientId, + ClientType, + UTCTimeMillis, + Maybe Text, + Maybe ClientClass, + Maybe CookieLabel, + Maybe Latitude, + Maybe Longitude, + Maybe Text, + Maybe (C.Set ClientCapability) + ) -> + Client +toClient keys (cid, cty, tme, lbl, cls, cok, lat, lon, mdl, cps) = + Client + { clientId = cid, + clientType = cty, + clientTime = tme, + clientClass = cls, + clientLabel = lbl, + clientCookie = cok, + clientLocation = location <$> lat <*> lon, + clientModel = mdl, + clientCapabilities = ClientCapabilityList $ maybe Set.empty (Set.fromList . C.fromSet) cps, + clientMLSPublicKeys = fmap (LBS.toStrict . fromBlob) (Map.fromList keys) + } + +key :: UserId -> ClientId -> HashMap Text AWS.AttributeValue +key uid cid = HashMap.singleton ddbClient (ddbKey uid cid) + +------------------------------------------------------------------------------- +-- Best-effort optimistic locking for prekeys via DynamoDB + +ddbClient :: Text +ddbClient = "client" + +ddbKey :: UserId -> ClientId -> AWS.AttributeValue +ddbKey u c = AWS.S (UUID.toText (toUUID u) <> "." <> client c) diff --git a/services/brig/src/Brig/Effects/CodeStore.hs b/services/brig/src/Brig/Effects/CodeStore.hs index 96f3e7c63b..a2c17d7daa 100644 --- a/services/brig/src/Brig/Effects/CodeStore.hs +++ b/services/brig/src/Brig/Effects/CodeStore.hs @@ -34,9 +34,6 @@ data PRQueryData f = PRQueryData } data CodeStore m a where - MkPasswordResetKey :: UserId -> CodeStore m PasswordResetKey - GenerateEmailCode :: CodeStore m PasswordResetCode - GeneratePhoneCode :: CodeStore m PasswordResetCode CodeSelect :: PasswordResetKey -> CodeStore m (Maybe (PRQueryData Maybe)) diff --git a/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs b/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs index e6cae09099..0d9a0cf68f 100644 --- a/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs +++ b/services/brig/src/Brig/Effects/CodeStore/Cassandra.hs @@ -18,24 +18,16 @@ module Brig.Effects.CodeStore.Cassandra ( codeStoreToCassandra, - interpretClientToIO, ) where import Brig.Data.Instances () import Brig.Effects.CodeStore import Cassandra -import Data.ByteString.Conversion (toByteString') import Data.Id -import Data.Text (pack) -import Data.Text.Ascii import Data.Time.Clock import Imports -import OpenSSL.BN (randIntegerZeroToNMinusOne) -import OpenSSL.EVP.Digest (digestBS, getDigestByName) -import OpenSSL.Random (randBytes) import Polysemy -import Text.Printf import Wire.API.User.Password codeStoreToCassandra :: @@ -47,9 +39,6 @@ codeStoreToCassandra = interpret $ embed @m . \case - MkPasswordResetKey uid -> mkPwdResetKey uid - GenerateEmailCode -> genEmailCode - GeneratePhoneCode -> genPhoneCode CodeSelect prk -> (fmap . fmap) toRecord . retry x1 @@ -75,27 +64,6 @@ codeStoreToCassandra = toRecord (prqdCode, prqdUser, prqdRetries, prqdTimeout) = PRQueryData {..} -genEmailCode :: MonadIO m => m PasswordResetCode -genEmailCode = PasswordResetCode . encodeBase64Url <$> liftIO (randBytes 24) - -genPhoneCode :: MonadIO m => m PasswordResetCode -genPhoneCode = - PasswordResetCode . unsafeFromText . pack . printf "%06d" - <$> liftIO (randIntegerZeroToNMinusOne 1000000) - -mkPwdResetKey :: MonadIO m => UserId -> m PasswordResetKey -mkPwdResetKey u = do - d <- liftIO $ getDigestByName "SHA256" >>= maybe (error "SHA256 not found") pure - pure . PasswordResetKey . encodeBase64Url . digestBS d $ toByteString' u - -interpretClientToIO :: - Member (Final IO) r => - ClientState -> - Sem (Embed Cassandra.Client ': r) a -> - Sem r a -interpretClientToIO ctx = interpret $ \case - Embed action -> embedFinal @IO $ runClient ctx action - --------------------------------------------------------------------------------- -- Queries diff --git a/services/brig/src/Brig/Effects/Common.hs b/services/brig/src/Brig/Effects/Common.hs new file mode 100644 index 0000000000..f6f28f978e --- /dev/null +++ b/services/brig/src/Brig/Effects/Common.hs @@ -0,0 +1,69 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.Common where + +import qualified Bilge as RPC +import Bilge.IO +import Bilge.RPC +import Bilge.Request +import Bilge.Retry +import Cassandra +import Control.Monad.Catch +import Control.Monad.Trans.Except +import Control.Retry +import qualified Data.ByteString.Lazy as LBS +import Imports +import Network.HTTP.Client (Response) +import Network.HTTP.Types.Method +import Polysemy +import Polysemy.Error + +interpretClientToIO :: + Member (Final IO) r => + ClientState -> + Sem (Embed Client ': r) a -> + Sem r a +interpretClientToIO ctx = interpret $ \case + Embed action -> embedFinal @IO $ runClient ctx action + +makeReq :: + ( MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + LText -> + RPC.Request -> + StdMethod -> + (Request -> Request) -> + m (Response (Maybe LBS.ByteString)) +makeReq component cReq m r = + recovering x3 rpcHandlers $ + const $ + rpc' component cReq (method m . r) + +x3 :: RetryPolicy +x3 = limitRetries 3 <> exponentialBackoff 100000 + +semErrToExceptT :: + Sem (Error e ': r) a -> + ExceptT e (Sem r) a +semErrToExceptT act = + lift (runError act) >>= \case + Left p -> throwE p + Right v -> pure v diff --git a/services/brig/src/Brig/Effects/CookieStore.hs b/services/brig/src/Brig/Effects/CookieStore.hs new file mode 100644 index 0000000000..a8326e16eb --- /dev/null +++ b/services/brig/src/Brig/Effects/CookieStore.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.CookieStore where + +import Data.Id +import Polysemy +import Wire.API.User.Auth + +data CookieStore m a where + GetCookies :: UserId -> CookieStore m [Cookie ()] + DeleteCookies :: UserId -> [Cookie c] -> CookieStore m () + DeleteAllCookies :: UserId -> CookieStore m () + +makeSem ''CookieStore diff --git a/services/brig/src/Brig/Effects/CookieStore/Cassandra.hs b/services/brig/src/Brig/Effects/CookieStore/Cassandra.hs new file mode 100644 index 0000000000..a4028f9890 --- /dev/null +++ b/services/brig/src/Brig/Effects/CookieStore/Cassandra.hs @@ -0,0 +1,76 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.CookieStore.Cassandra (cookieStoreToCassandra) where + +import Brig.Effects.CookieStore +import Brig.User.Auth.DB.Instances () +import Cassandra +import Data.Id +import Data.Time.Clock +import Imports +import Polysemy +import Wire.API.User.Auth + +cookieStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (CookieStore ': r) a -> + Sem r a +cookieStoreToCassandra = + interpret $ + embed @m . \case + GetCookies u -> listCookies u + DeleteCookies u cs -> deleteCookiesQuery u cs + DeleteAllCookies u -> deleteAllCookiesQuery u + +deleteCookiesQuery :: MonadClient m => UserId -> [Cookie a] -> m () +deleteCookiesQuery u cs = retry x5 . batch $ do + setType BatchUnLogged + setConsistency LocalQuorum + for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) + where + cql :: PrepQuery W (UserId, UTCTime, CookieId) () + cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?" + +deleteAllCookiesQuery :: MonadClient m => UserId -> m () +deleteAllCookiesQuery u = retry x5 (write cql (params LocalQuorum (Identity u))) + where + cql :: PrepQuery W (Identity UserId) () + cql = "DELETE FROM user_cookies WHERE user = ?" + +listCookies :: MonadClient m => UserId -> m [Cookie ()] +listCookies u = + map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u))) + where + cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) + cql = + "SELECT id, created, expires, type, label, succ_id \ + \FROM user_cookies \ + \WHERE user = ? \ + \ORDER BY expires ASC" + toCookie :: (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) -> Cookie () + toCookie (i, ct, et, t, l, sc) = + Cookie + { cookieId = i, + cookieType = t, + cookieCreated = ct, + cookieExpires = et, + cookieLabel = l, + cookieSucc = sc, + cookieValue = () + } diff --git a/services/brig/src/Brig/Effects/GalleyAccess.hs b/services/brig/src/Brig/Effects/GalleyAccess.hs new file mode 100644 index 0000000000..897a208e92 --- /dev/null +++ b/services/brig/src/Brig/Effects/GalleyAccess.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.GalleyAccess where + +import Data.Id +import Imports +import Polysemy +import Wire.API.Event.Conversation +import Wire.API.Team.Feature +import Wire.API.Team.Member + +data GalleyAccess m a where + GetTeamSndFactorPasswordChallenge :: TeamId -> GalleyAccess m FeatureStatus + -- | Only works on 'BindingTeam's! The lisetBindingTeamMembersH'. + GetTeamContacts :: UserId -> GalleyAccess m (Maybe TeamMemberList) + -- | Calls 'Galley.API.getBindingTeamIdH'. + GetTeamId :: UserId -> GalleyAccess m (Maybe TeamId) + -- | Calls 'Galley.API.getTeamFeatureStatusH'. + GetTeamLegalHoldStatus :: TeamId -> GalleyAccess m (WithStatus LegalholdConfig) + -- | Tell Galley to remove a service bot from a conversation. + RemoveBotMember :: + UserId -> + Maybe ConnId -> + ConvId -> + BotId -> + GalleyAccess m (Maybe Event) + +makeSem ''GalleyAccess diff --git a/services/brig/src/Brig/Effects/GalleyAccess/Http.hs b/services/brig/src/Brig/Effects/GalleyAccess/Http.hs new file mode 100644 index 0000000000..e14331ca13 --- /dev/null +++ b/services/brig/src/Brig/Effects/GalleyAccess/Http.hs @@ -0,0 +1,118 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.GalleyAccess.Http (galleyAccessToHttp) where + +import qualified Bilge as RPC +import Bilge.IO +import Bilge.RPC +import Bilge.Request +import Brig.Effects.Common +import Brig.Effects.GalleyAccess +import Brig.RPC +import qualified Brig.RPC.Decode as RPC +import Control.Monad.Catch +import Data.Aeson (encode) +import Data.ByteString.Conversion.To +import Galley.Types.Bot +import Imports +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import Polysemy +import Polysemy.TinyLog +import System.Logger.Class hiding (debug) +import Wire.API.Team.Feature + +galleyAccessToHttp :: + forall m r a. + Member TinyLog r => + ( MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + Member (Embed m) r + ) => + RPC.Request -> + Sem (GalleyAccess ': r) a -> + Sem r a +galleyAccessToHttp g = + interpret $ \case + GetTeamSndFactorPasswordChallenge tid -> embed @m $ do + let req = + paths + [ "i", + "teams", + toByteString' tid, + "features", + featureNameBS @SndFactorPasswordChallengeConfig + ] + . expect2xx + response <- makeReq "galley" g GET req + wsStatus @SndFactorPasswordChallengeConfig + <$> RPC.decodeBody "galley" response + GetTeamContacts uid -> do + debug $ remote "galley" . msg (val "Get team contacts") + embed @m $ do + let req = + paths ["i", "users", toByteString' uid, "team", "members"] + . expect [status200, status404] + response <- makeReq "galley" g GET req + case RPC.statusCode response of + 200 -> Just <$> decodeBody "galley" response + _ -> pure Nothing + GetTeamId uid -> do + debug $ remote "galley" . msg (val "Get team from user") + embed @m $ do + let req = + paths ["i", "users", toByteString' uid, "team"] + . expect [status200, status404] + response <- makeReq "galley" g GET req + case RPC.statusCode response of + 200 -> Just <$> decodeBody "galley" response + _ -> pure Nothing + GetTeamLegalHoldStatus tid -> do + debug $ remote "galley" . msg (val "Get legalhold settings") + embed @m $ do + let req = + paths + [ "i", + "teams", + toByteString' tid, + "features", + featureNameBS @LegalholdConfig + ] + . expect2xx + makeReq "galley" g GET req >>= decodeBody "galley" + RemoveBotMember zusr conn conv bot -> do + debug $ + remote "galley" + . field "user" (toByteString zusr) + . field "conv" (toByteString conv) + . field "bot" (toByteString bot) + . msg (val "Removing bot member") + embed @m $ do + let req = + path "/i/bots" + . header "Z-User" (toByteString' zusr) + . maybe id (header "Z-Connection" . toByteString') conn + . contentJson + . lbytes (encode (removeBot conv bot)) + . expect [status200, status404] -- 404 is allowed: a given conversation may no longer exist + response <- makeReq "galley" g DELETE req + if isJust (RPC.responseBody response) && RPC.statusCode response == 200 + then Just <$> decodeBody "galley" response + else pure Nothing diff --git a/services/brig/src/Brig/Effects/GundeckAccess.hs b/services/brig/src/Brig/Effects/GundeckAccess.hs new file mode 100644 index 0000000000..8bae78dfbd --- /dev/null +++ b/services/brig/src/Brig/Effects/GundeckAccess.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.GundeckAccess where + +import Brig.Types.User.Event +import Data.Id +import Data.List.NonEmpty +import Gundeck.Types.Push.V2 +import Imports +import Polysemy + +data GundeckAccess m a where + PushEvents :: + -- | The events to push. + NonEmpty Event -> + -- | The users to push to. + NonEmpty UserId -> + -- | The originator of the events. + UserId -> + -- | The push routing strategy. + Route -> + -- | The originating device connection. + Maybe ConnId -> + GundeckAccess m () + PushEventsAsync :: + -- | The events to push. + NonEmpty Event -> + -- | The users to push to. + NonEmpty UserId -> + -- | The originator of the events. + UserId -> + -- | The push routing strategy. + Route -> + -- | The originating device connection. + Maybe ConnId -> + GundeckAccess m () + +makeSem ''GundeckAccess + +-- | (Asynchronously) notifies other users of events. +notify :: + Member GundeckAccess r => + NonEmpty Event -> + -- | Origin user, TODO: Delete + UserId -> + -- | Push routing strategy. + Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + -- | Users to notify. + NonEmpty UserId -> + Sem r () +notify events orig route conn recipients = + pushEventsAsync events recipients orig route conn + +notifySelf :: + Member GundeckAccess r => + NonEmpty Event -> + -- | Origin user. + UserId -> + -- | Push routing strategy. + Route -> + -- | Origin device connection, if any. + Maybe ConnId -> + Sem r () +notifySelf events orig route conn = + notify events orig route conn (pure orig) diff --git a/services/brig/src/Brig/Effects/GundeckAccess/Http.hs b/services/brig/src/Brig/Effects/GundeckAccess/Http.hs new file mode 100644 index 0000000000..80dae14a84 --- /dev/null +++ b/services/brig/src/Brig/Effects/GundeckAccess/Http.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE RecordWildCards #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.GundeckAccess.Http (gundeckAccessToHttp) where + +import qualified Bilge as RPC +import Bilge.IO +import Bilge.RPC +import Bilge.Request hiding (requestId) +import Brig.App +import Brig.Effects.Common +import Brig.Effects.GundeckAccess +import Brig.RPC +import Brig.Types.User.Event +import Control.Error.Util +import Control.Lens (view, (.~), (?~)) +import Control.Monad.Catch +import Control.Monad.Trans.Except +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as A +import Data.ByteString.Conversion.To +import Data.Id +import Data.Json.Util ((#)) +import Data.List.NonEmpty +import Data.List.Split (chunksOf) +import Data.Qualified +import Data.Range +import qualified Data.Set as Set +import Gundeck.Types.Push.V2 +import Imports hiding (toList) +import Network.HTTP.Types.Method +import Polysemy +import System.Logger.Class as Log hiding (name, (.=)) +import qualified System.Logger.Extended as ExLog +import Wire.API.Connection +import Wire.API.Properties +import Wire.API.User +import Wire.API.User.Client + +gundeckAccessToHttp :: + forall m r a. + ( MonadIO m, + MonadLogger m, + MonadMask m, + MonadHttp m, + MonadUnliftIO m, + MonadReader Env m, + HasRequestId m, + Member (Embed m) r + ) => + RPC.Request -> + Sem (GundeckAccess ': r) a -> + Sem r a +gundeckAccessToHttp g = + interpret $ + embed @m . \case + PushEvents events users orig route mConn -> do + push g events users orig route mConn + PushEventsAsync events users orig route mConn -> do + fork (Just orig) $ + push g events users orig route mConn + +fork :: + (MonadIO m, MonadUnliftIO m, MonadReader Env m) => + Maybe UserId -> + m a -> + m () +fork u ma = do + g <- view applog + r <- view requestId + let logErr e = ExLog.err g $ request r ~~ user u ~~ msg (show e) + withRunInIO $ \lower -> + void . liftIO . forkIO $ + either logErr (const $ pure ()) + =<< runExceptT (syncIO $ lower ma) + where + request = field "request" . unRequestId + user = maybe id (field "user" . toByteString) + +-- | Push events to other users. +push :: + ( MonadIO m, + Log.MonadLogger m, + MonadMask m, + MonadCatch m, + MonadHttp m, + HasRequestId m + ) => + -- | The request to the Gundeck component + RPC.Request -> + -- | The events to push. + NonEmpty Event -> + -- | The users to push to. + NonEmpty UserId -> + -- | The originator of the events. + UserId -> + -- | The push routing strategy. + Route -> + -- | The originating device connection. + Maybe ConnId -> + m () +push g (toList -> events) usrs orig route conn = + case mapMaybe toPushData events of + [] -> pure () + x : xs -> rawPush g (x :| xs) usrs orig route conn + where + toPushData :: Event -> Maybe (Builder, (A.Object, Maybe ApsData)) + toPushData e = case toPushFormat e of + Just o -> Just (Log.bytes e, (o, toApsData e)) + Nothing -> Nothing + +-- | Push encoded events to other users. Useful if you want to push +-- something that's not defined in Brig. +rawPush :: + ( MonadIO m, + Log.MonadLogger m, + MonadMask m, + MonadCatch m, + MonadHttp m, + HasRequestId m + ) => + -- | The request to the Gundeck component + RPC.Request -> + -- | The events to push. + NonEmpty (Builder, (A.Object, Maybe ApsData)) -> + -- | The users to push to. + NonEmpty UserId -> + -- | The originator of the events. + UserId -> + -- | The push routing strategy. + Route -> + -- | The originating device connection. + Maybe ConnId -> + m () +-- TODO: if we decide to have service whitelist events in Brig instead of +-- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. +rawPush g (toList -> events) usrs orig route conn = do + for_ events $ \e -> debug $ remote "gundeck" . msg (fst e) + let gReq rs = + method POST + . path "/i/push/v2" + . zUser orig -- FUTUREWORK: Remove, because gundeck handler ignores this. + . json (fmap (mkPush rs . snd) events) + . expect2xx + forM_ recipients $ \rcps -> makeReq "gundeck" g POST (gReq rcps) + where + recipients :: [Range 1 1024 (Set.Set Recipient)] + recipients = + fmap (unsafeRange . Set.fromList) $ + chunksOf 512 $ + fmap (`recipient` route) $ + toList usrs + mkPush :: Range 1 1024 (Set.Set Recipient) -> (A.Object, Maybe ApsData) -> Push + mkPush rcps (o, aps) = + newPush + (Just orig) + rcps + (singletonPayload o) + & pushOriginConnection .~ conn + & pushNativeAps .~ aps + +toPushFormat :: Event -> Maybe A.Object +toPushFormat (UserEvent (UserCreated u)) = + Just $ + A.fromList + [ "type" .= ("user.new" :: Text), + "user" .= SelfProfile (u {userIdentity = Nothing}) + ] +toPushFormat (UserEvent (UserActivated u)) = + Just $ + A.fromList + [ "type" .= ("user.activate" :: Text), + "user" .= SelfProfile u + ] +toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb ssoId ssoIdDel))) = + Just $ + A.fromList + [ "type" .= ("user.update" :: Text), + "user" + .= object + ( "id" .= i + # "name" .= n + # "picture" .= pic -- DEPRECATED + # "accent_id" .= acc + # "assets" .= ass + # "handle" .= hdl + # "locale" .= loc + # "managed_by" .= mb + # "sso_id" .= ssoId + # "sso_id_deleted" .= ssoIdDel + # [] + ) + ] +toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = + Just $ + A.fromList + [ "type" .= ("user.update" :: Text), + "user" + .= object + ( "id" .= eiuId + # "email" .= eiuEmail + # "phone" .= eiuPhone + # [] + ) + ] +toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = + Just $ + A.fromList + [ "type" .= ("user.identity-remove" :: Text), + "user" + .= object + ( "id" .= i + # "email" .= e + # "phone" .= p + # [] + ) + ] +toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = + Just $ + A.fromList $ + "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] +toPushFormat (UserEvent (UserSuspended i)) = + Just $ + A.fromList + [ "type" .= ("user.suspend" :: Text), + "id" .= i + ] +toPushFormat (UserEvent (UserResumed i)) = + Just $ + A.fromList + [ "type" .= ("user.resume" :: Text), + "id" .= i + ] +toPushFormat (UserEvent (UserDeleted qid)) = + Just $ + A.fromList + [ "type" .= ("user.delete" :: Text), + "id" .= qUnqualified qid, + "qualified_id" .= qid + ] +toPushFormat (UserEvent (UserLegalHoldDisabled i)) = + Just $ + A.fromList + [ "type" .= ("user.legalhold-disable" :: Text), + "id" .= i + ] +toPushFormat (UserEvent (UserLegalHoldEnabled i)) = + Just $ + A.fromList + [ "type" .= ("user.legalhold-enable" :: Text), + "id" .= i + ] +toPushFormat (PropertyEvent (PropertySet _ k v)) = + Just $ + A.fromList + [ "type" .= ("user.properties-set" :: Text), + "key" .= k, + "value" .= propertyValue v + ] +toPushFormat (PropertyEvent (PropertyDeleted _ k)) = + Just $ + A.fromList + [ "type" .= ("user.properties-delete" :: Text), + "key" .= k + ] +toPushFormat (PropertyEvent (PropertiesCleared _)) = + Just $ + A.fromList + [ "type" .= ("user.properties-clear" :: Text) + ] +toPushFormat (ClientEvent (ClientAdded _ c)) = + Just $ + A.fromList + [ "type" .= ("user.client-add" :: Text), + "client" .= c + ] +toPushFormat (ClientEvent (ClientRemoved _ c)) = + Just $ + A.fromList + [ "type" .= ("user.client-remove" :: Text), + "client" .= IdObject (clientId c) + ] +toPushFormat (UserEvent (LegalHoldClientRequested payload)) = + let LegalHoldClientRequestedData targetUser lastPrekey' clientId = payload + in Just $ + A.fromList + [ "type" .= ("user.legalhold-request" :: Text), + "id" .= targetUser, + "last_prekey" .= lastPrekey', + "client" .= IdObject clientId + ] + +toApsData :: Event -> Maybe ApsData +toApsData (ConnectionEvent (ConnectionUpdated uc _ name)) = + case (ucStatus uc, name) of + (MissingLegalholdConsent, _) -> Nothing + (Pending, n) -> apsConnRequest <$> n + (Accepted, n) -> apsConnAccept <$> n + (Blocked, _) -> Nothing + (Ignored, _) -> Nothing + (Sent, _) -> Nothing + (Cancelled, _) -> Nothing + where + apsConnRequest n = + apsData (ApsLocKey "push.notification.connection.request") [fromName n] + & apsSound ?~ ApsSound "new_message_apns.caf" + apsConnAccept n = + apsData (ApsLocKey "push.notification.connection.accepted") [fromName n] + & apsSound ?~ ApsSound "new_message_apns.caf" +toApsData _ = Nothing diff --git a/services/brig/src/Brig/Effects/PasswordResetStore.hs b/services/brig/src/Brig/Effects/PasswordResetStore.hs index aab8274893..150c5dbfb5 100644 --- a/services/brig/src/Brig/Effects/PasswordResetStore.hs +++ b/services/brig/src/Brig/Effects/PasswordResetStore.hs @@ -36,5 +36,8 @@ data PasswordResetStore m a where VerifyPasswordResetCode :: PasswordResetPair -> PasswordResetStore m (Maybe UserId) + DeletePasswordResetCode :: + PasswordResetKey -> + PasswordResetStore m () makeSem ''PasswordResetStore diff --git a/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs b/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs index c0248aa4e5..7cd0451dc9 100644 --- a/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs +++ b/services/brig/src/Brig/Effects/PasswordResetStore/CodeStore.hs @@ -22,6 +22,7 @@ where import Brig.Effects.CodeStore import Brig.Effects.PasswordResetStore +import Brig.Effects.PasswordResetSupply import Brig.Types.User (PasswordResetPair) import Data.Id import Data.Time @@ -34,13 +35,14 @@ import qualified Wire.Sem.Now as Now passwordResetStoreToCodeStore :: forall r a. - Members '[CodeStore, Now] r => + Members '[CodeStore, Now, PasswordResetSupply] r => Sem (PasswordResetStore ': r) a -> Sem r a passwordResetStoreToCodeStore = interpret $ \case CreatePasswordResetCode uid eEmailPhone -> create uid eEmailPhone LookupPasswordResetCode uid -> lookup uid VerifyPasswordResetCode prp -> verify prp + DeletePasswordResetCode key -> delete key maxAttempts :: Int32 maxAttempts = 3 @@ -49,7 +51,7 @@ ttl :: NominalDiffTime ttl = 3600 -- 60 minutes create :: - Members '[CodeStore, Now] r => + Members '[CodeStore, Now, PasswordResetSupply] r => UserId -> Either Email Phone -> Sem r PasswordResetPair @@ -64,7 +66,7 @@ create u target = do pure (key, code) lookup :: - Members '[CodeStore, Now] r => + Members '[CodeStore, Now, PasswordResetSupply] r => UserId -> Sem r (Maybe PasswordResetCode) lookup u = do @@ -89,3 +91,6 @@ verify (k, c) = do pure Nothing Just PRQueryData {} -> codeDelete k $> Nothing Nothing -> pure Nothing + +delete :: Member CodeStore r => PasswordResetKey -> Sem r () +delete = codeDelete diff --git a/services/brig/src/Brig/Effects/PasswordResetSupply.hs b/services/brig/src/Brig/Effects/PasswordResetSupply.hs new file mode 100644 index 0000000000..054bcd16cd --- /dev/null +++ b/services/brig/src/Brig/Effects/PasswordResetSupply.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 . +{-# LANGUAGE TemplateHaskell #-} + +module Brig.Effects.PasswordResetSupply where + +import Data.Id +import Polysemy +import Wire.API.User.Password + +data PasswordResetSupply m a where + MkPasswordResetKey :: UserId -> PasswordResetSupply m PasswordResetKey + GenerateEmailCode :: PasswordResetSupply m PasswordResetCode + GeneratePhoneCode :: PasswordResetSupply m PasswordResetCode + +makeSem ''PasswordResetSupply diff --git a/services/brig/src/Brig/Effects/PasswordResetSupply/IO.hs b/services/brig/src/Brig/Effects/PasswordResetSupply/IO.hs new file mode 100644 index 0000000000..9a2015b276 --- /dev/null +++ b/services/brig/src/Brig/Effects/PasswordResetSupply/IO.hs @@ -0,0 +1,56 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.PasswordResetSupply.IO (passwordResetSupplyToIO) where + +import Brig.Effects.PasswordResetSupply +import Data.ByteString.Conversion +import Data.Id +import Data.Text +import Data.Text.Ascii +import Imports +import OpenSSL.BN +import OpenSSL.EVP.Digest +import OpenSSL.Random +import Polysemy +import Text.Printf +import Wire.API.User.Password + +passwordResetSupplyToIO :: + forall r a. + (Member (Embed IO) r) => + Sem (PasswordResetSupply ': r) a -> + Sem r a +passwordResetSupplyToIO = + interpret $ + embed @IO . \case + MkPasswordResetKey uid -> mkPwdResetKey uid + GenerateEmailCode -> genEmailCode + GeneratePhoneCode -> genPhoneCode + +genEmailCode :: MonadIO m => m PasswordResetCode +genEmailCode = PasswordResetCode . encodeBase64Url <$> liftIO (randBytes 24) + +genPhoneCode :: MonadIO m => m PasswordResetCode +genPhoneCode = + PasswordResetCode . unsafeFromText . pack . printf "%06d" + <$> liftIO (randIntegerZeroToNMinusOne 1000000) + +mkPwdResetKey :: MonadIO m => UserId -> m PasswordResetKey +mkPwdResetKey u = do + d <- liftIO $ getDigestByName "SHA256" >>= maybe (error "SHA256 not found") pure + pure . PasswordResetKey . encodeBase64Url . digestBS d $ toByteString' u diff --git a/services/brig/src/Brig/Effects/Twilio.hs b/services/brig/src/Brig/Effects/Twilio.hs new file mode 100644 index 0000000000..96244c5eb2 --- /dev/null +++ b/services/brig/src/Brig/Effects/Twilio.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.Twilio where + +import Data.ISO3166_CountryCodes +import Imports +import Polysemy +import Ropes.Twilio + +data Twilio m a where + LookupPhone :: + Text -> + LookupDetail -> + Maybe CountryCode -> + Twilio m (Either ErrorResponse LookupResult) + +makeSem ''Twilio diff --git a/services/brig/src/Brig/Effects/Twilio/IO.hs b/services/brig/src/Brig/Effects/Twilio/IO.hs new file mode 100644 index 0000000000..af79d53e48 --- /dev/null +++ b/services/brig/src/Brig/Effects/Twilio/IO.hs @@ -0,0 +1,46 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.Twilio.IO (twilioToIO) where + +import Bilge.Retry +import Brig.App +import Brig.Effects.Twilio +import Control.Lens (view) +import Control.Monad.Catch +import Control.Retry +import Imports +import Polysemy +import qualified Ropes.Twilio as Ropes + +twilioToIO :: + forall m r a. + (Member (Embed m) r, MonadReader Env m, MonadIO m) => + Sem (Twilio ': r) a -> + Sem r a +twilioToIO = + interpret $ + embed @m . \case + LookupPhone txt detail code -> do + cred <- view twilioCreds + m <- view httpManager + liftIO . try @_ @Ropes.ErrorResponse $ + recovering x3 httpHandlers $ + const $ Ropes.lookupPhone cred m txt detail code + +x3 :: RetryPolicy +x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/brig/src/Brig/Effects/UniqueClaimsStore.hs b/services/brig/src/Brig/Effects/UniqueClaimsStore.hs new file mode 100644 index 0000000000..8b72f17fad --- /dev/null +++ b/services/brig/src/Brig/Effects/UniqueClaimsStore.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UniqueClaimsStore where + +import Data.Id +import Data.Timeout +import Imports +import Polysemy + +data UniqueClaimsStore m a where + AddClaims :: Id a -> Timeout -> Text -> UniqueClaimsStore m () + -- | Lookup the current claims on a value. + GetClaims :: Text -> UniqueClaimsStore m [Id a] + DeleteClaims :: Id i -> Timeout -> Text -> UniqueClaimsStore m () + +makeSem ''UniqueClaimsStore diff --git a/services/brig/src/Brig/Effects/UniqueClaimsStore/Cassandra.hs b/services/brig/src/Brig/Effects/UniqueClaimsStore/Cassandra.hs new file mode 100644 index 0000000000..c042efdd3d --- /dev/null +++ b/services/brig/src/Brig/Effects/UniqueClaimsStore/Cassandra.hs @@ -0,0 +1,81 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UniqueClaimsStore.Cassandra (uniqueClaimsStoreToCassandra) where + +import Brig.Effects.UniqueClaimsStore +import Cassandra +import qualified Cassandra as C +import Data.Id +import Data.Timeout +import Imports +import Polysemy + +minTtl :: Timeout +minTtl = 60 # Second + +uniqueClaimsStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (UniqueClaimsStore ': r) a -> + Sem r a +uniqueClaimsStoreToCassandra = + interpret $ + embed @m . \case + AddClaims u t txt -> addClaimsQuery u t txt + GetClaims txt -> lookupClaims txt + DeleteClaims u t txt -> deleteClaimsQuery u t txt + +deleteClaimsQuery :: + MonadClient m => + -- | The 'Id' associated with the claim. + Id a -> + -- | The minimum timeout (i.e. duration) of the rest of the claim. (Each + -- claim can have more than one claimer (even though this is a feature we + -- never use), so removing a claim is an update operation on the database. + -- Therefore, we reset the TTL the same way we reset it in 'withClaim'.) + Timeout -> + -- | The value on which to acquire the claim. + Text -> + m () +deleteClaimsQuery u t v = do + let ttl = max minTtl t + retry x5 $ write cql $ params LocalQuorum (fromIntegral $ (ttl * 2) #> Second, C.Set [u], v) + where + cql :: PrepQuery W (Int32, C.Set (Id a), Text) () + cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" + +addClaimsQuery :: MonadClient m => Id a -> Timeout -> Text -> m () +addClaimsQuery u t v = do + let ttl = max minTtl t + retry x5 + . write cql + $ params LocalQuorum (fromIntegral $ (ttl * 2) #> Second, C.Set [u], v) + where + cql :: PrepQuery W (Int32, C.Set (Id a), Text) () + cql = "UPDATE unique_claims USING TTL ? SET claims = claims + ? WHERE value = ?" + +-- | Lookup the current claims on a value. +lookupClaims :: MonadClient m => Text -> m [Id a] +lookupClaims v = + fmap (maybe [] (fromSet . runIdentity)) $ + retry x1 $ + query1 cql $ + params LocalQuorum (Identity v) + where + cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) + cql = "SELECT claims FROM unique_claims WHERE value = ?" diff --git a/services/brig/src/Brig/Effects/UserHandleStore.hs b/services/brig/src/Brig/Effects/UserHandleStore.hs new file mode 100644 index 0000000000..2873b79ecc --- /dev/null +++ b/services/brig/src/Brig/Effects/UserHandleStore.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UserHandleStore where + +import Data.Handle +import Data.Id +import Imports +import Polysemy + +-- | An enum with a one-to-one mapping to 'Cassandra.Consistency'. +data Consistency + = One + | LocalQuorum + | All + deriving (Eq) + +data UserHandleStore m a where + InsertHandle :: Handle -> UserId -> UserHandleStore m () + -- | Lookup the current owner of a 'Handle'. │ + GetHandleWithConsistency :: Consistency -> Handle -> UserHandleStore m (Maybe UserId) + DeleteHandle :: Handle -> UserHandleStore m () + +makeSem ''UserHandleStore + +-- | Lookup the current owner of a 'Handle'. +lookupHandle :: Member UserHandleStore r => Handle -> Sem r (Maybe UserId) +lookupHandle = getHandleWithConsistency LocalQuorum diff --git a/services/brig/src/Brig/Effects/UserHandleStore/Cassandra.hs b/services/brig/src/Brig/Effects/UserHandleStore/Cassandra.hs new file mode 100644 index 0000000000..c4e838f25b --- /dev/null +++ b/services/brig/src/Brig/Effects/UserHandleStore/Cassandra.hs @@ -0,0 +1,73 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UserHandleStore.Cassandra (userHandleStoreToCassandra) where + +import Brig.Data.Instances () +import Brig.Effects.UserHandleStore +import Cassandra hiding (Consistency (..)) +import qualified Cassandra as C +import Data.Handle +import Data.Id +import Imports hiding (All) +import Polysemy + +userHandleStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (UserHandleStore ': r) a -> + Sem r a +userHandleStoreToCassandra = + interpret $ + embed @m . \case + InsertHandle h uid -> insertHandleQuery h uid + GetHandleWithConsistency c h -> lookupHandleWithPolicy (mapConsistency c) h + DeleteHandle h -> deleteHandleQuery h + +deleteHandleQuery :: MonadClient m => Handle -> m () +deleteHandleQuery h = retry x5 $ write handleDelete (params C.LocalQuorum (Identity h)) + +mapConsistency :: Consistency -> C.Consistency +mapConsistency = \case + One -> C.One + LocalQuorum -> C.LocalQuorum + All -> C.All + +{-# INLINE lookupHandleWithPolicy #-} + +insertHandleQuery :: MonadClient m => Handle -> UserId -> m () +insertHandleQuery newHandle uid = + retry x5 $ write handleInsert (params C.LocalQuorum (newHandle, uid)) + +-- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty" +-- error. +-- +-- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' +-- and only allowing it to be parsed. +lookupHandleWithPolicy :: MonadClient m => C.Consistency -> Handle -> m (Maybe UserId) +lookupHandleWithPolicy policy h = do + (runIdentity =<<) + <$> retry x1 (query1 handleSelect (params policy (Identity h))) + +handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId)) +handleSelect = "SELECT user FROM user_handle WHERE handle = ?" + +handleInsert :: PrepQuery W (Handle, UserId) () +handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)" + +handleDelete :: PrepQuery W (Identity Handle) () +handleDelete = "DELETE FROM user_handle WHERE handle = ?" diff --git a/services/brig/src/Brig/Effects/UserKeyStore.hs b/services/brig/src/Brig/Effects/UserKeyStore.hs new file mode 100644 index 0000000000..bf3bb0a5ce --- /dev/null +++ b/services/brig/src/Brig/Effects/UserKeyStore.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UserKeyStore where + +import Brig.Types.Common +import Cassandra +import Data.ByteString.Lazy +import Data.Id +import qualified Data.Multihash.Digest as MH +import Imports +import OpenSSL.EVP.Digest +import Polysemy + +newtype UserKeyHash = UserKeyHash MH.MultihashDigest + +instance Cql UserKeyHash where + ctype = Tagged BlobColumn + + fromCql (CqlBlob lbs) = case MH.decode (toStrict lbs) of + Left e -> Left ("userkeyhash: " ++ e) + Right h -> pure $ UserKeyHash h + fromCql _ = Left "userkeyhash: expected blob" + + toCql (UserKeyHash d) = CqlBlob $ MH.encode (MH.algorithm d) (MH.digest d) + +data UKHashType + = UKHashPhone + | UKHashEmail + deriving (Eq) + +instance Cql UKHashType where + ctype = Tagged IntColumn + + fromCql (CqlInt i) = case i of + 0 -> pure UKHashPhone + 1 -> pure UKHashEmail + n -> Left $ "unexpected hashtype: " ++ show n + fromCql _ = Left "userkeyhashtype: int expected" + + toCql UKHashPhone = CqlInt 0 + toCql UKHashEmail = CqlInt 1 + +data UserKeyStore m a where + GetKey :: UserKey -> UserKeyStore m (Maybe UserId) + InsertKey :: Digest -> UserId -> UserKey -> UserKeyStore m () + DeleteKey :: Digest -> UserKey -> UserKeyStore m () + +makeSem ''UserKeyStore diff --git a/services/brig/src/Brig/Effects/UserKeyStore/Cassandra.hs b/services/brig/src/Brig/Effects/UserKeyStore/Cassandra.hs new file mode 100644 index 0000000000..6378e19259 --- /dev/null +++ b/services/brig/src/Brig/Effects/UserKeyStore/Cassandra.hs @@ -0,0 +1,80 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.UserKeyStore.Cassandra (userKeyStoreToCassandra) where + +import Brig.Effects.UserKeyStore +import Brig.Email +import Brig.Types.Common +import Cassandra +import qualified Data.ByteString as B +import Data.Id +import qualified Data.Multihash.Digest as MH +import qualified Data.Text.Encoding as T +import Imports +import OpenSSL.EVP.Digest +import Polysemy +import Wire.API.User.Identity + +userKeyStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (UserKeyStore ': r) a -> + Sem r a +userKeyStoreToCassandra = + interpret $ + embed @m . \case + GetKey uid -> lookupKeyQuery uid + InsertKey d uid k -> insertKeyQuery d uid k + DeleteKey d k -> deleteKeyQuery d k + +hashKey :: Digest -> UserKey -> UserKeyHash +hashKey d uk = + let d' = digestBS d $ T.encodeUtf8 (keyText uk) + in UserKeyHash $ MH.MultihashDigest MH.SHA256 (B.length d') d' + +lookupKeyQuery :: MonadClient m => UserKey -> m (Maybe UserId) +lookupKeyQuery k = + fmap runIdentity + <$> retry x1 (query1 keySelect (params LocalQuorum (Identity $ keyText k))) + +keySelect :: PrepQuery R (Identity Text) (Identity UserId) +keySelect = "SELECT user FROM user_keys WHERE key = ?" + +insertKeyQuery :: MonadClient m => Digest -> UserId -> UserKey -> m () +insertKeyQuery d u k = do + let hk = hashKey d k + kt = foldKey (\(_ :: Email) -> UKHashEmail) (\(_ :: Phone) -> UKHashPhone) k + retry x5 $ write insertHashed (params LocalQuorum (hk, kt, u)) + retry x5 $ write keyInsert (params LocalQuorum (keyText k, u)) + +insertHashed :: PrepQuery W (UserKeyHash, UKHashType, UserId) () +insertHashed = "INSERT INTO user_keys_hash(key, key_type, user) VALUES (?, ?, ?)" + +keyInsert :: PrepQuery W (Text, UserId) () +keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)" + +deleteKeyQuery :: MonadClient m => Digest -> UserKey -> m () +deleteKeyQuery d k = do + let hk = hashKey d k + retry x5 $ write deleteHashed (params LocalQuorum (Identity hk)) + retry x5 $ write keyDelete (params LocalQuorum (Identity $ keyText k)) + where + deleteHashed :: PrepQuery W (Identity UserKeyHash) () + deleteHashed = "DELETE FROM user_keys_hash WHERE key = ?" + keyDelete :: PrepQuery W (Identity Text) () + keyDelete = "DELETE FROM user_keys WHERE key = ?" diff --git a/services/brig/src/Brig/Effects/UserQuery.hs b/services/brig/src/Brig/Effects/UserQuery.hs new file mode 100644 index 0000000000..6a4653b14c --- /dev/null +++ b/services/brig/src/Brig/Effects/UserQuery.hs @@ -0,0 +1,345 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 . +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Brig.Effects.UserQuery + ( UserQuery (..), + getId, + getUsers, + getServiceUsers, + getServiceUsersForTeam, + getName, + getLocale, + getAuthentication, + getPassword, + getActivated, + getAccountStatus, + getAccountStatuses, + getTeam, + getAccounts, + isActivated, + insertAccount, + updateUser, + updateEmail, + updateHandle, + updatePhone, + updateStatus, + activateUser, + deleteEmailUnvalidated, + deleteServiceUser, + + -- * effect-derived functions + lookupAccount, + lookupAccounts, + + -- * error types + AuthError (..), + ReAuthError (..), + + -- * misc types + AccountRow, + UserRow, + UserRowInsert, + ) +where + +import Brig.Password +import Brig.Types.Intra +import Data.Domain +import Data.Handle +import Data.Id +import Data.Json.Util +import Data.Qualified +import Imports +import Network.HTTP.Types.Status +import qualified Network.Wai.Utilities.Error as Wai +import Polysemy +import Polysemy.Input +import Wire.API.Error +import qualified Wire.API.Error.Brig as E +import Wire.API.Provider.Service +import Wire.API.User +import Wire.Sem.Paging + +type Activated = Bool + +type UserRow = + ( UserId, + Name, + Maybe Pict, + Maybe Email, + Maybe Phone, + Maybe UserSSOId, + ColourId, + Maybe [Asset], + Activated, + Maybe AccountStatus, + Maybe UTCTimeMillis, + Maybe Language, + Maybe Country, + Maybe ProviderId, + Maybe ServiceId, + Maybe Handle, + Maybe TeamId, + Maybe ManagedBy + ) + +-- Represents a 'UserAccount' +type AccountRow = + ( UserId, + Name, + Maybe Pict, + Maybe Email, + Maybe Phone, + Maybe UserSSOId, + ColourId, + Maybe [Asset], + Activated, + Maybe AccountStatus, + Maybe UTCTimeMillis, + Maybe Language, + Maybe Country, + Maybe ProviderId, + Maybe ServiceId, + Maybe Handle, + Maybe TeamId, + Maybe ManagedBy + ) + +type UserRowInsert = + ( UserId, + Name, + Pict, + [Asset], + Maybe Email, + Maybe Phone, + Maybe UserSSOId, + ColourId, + Maybe Password, + Activated, + AccountStatus, + Maybe UTCTimeMillis, + Language, + Maybe Country, + Maybe ProviderId, + Maybe ServiceId, + Maybe Handle, + Maybe TeamId, + ManagedBy + ) + +deriving instance Show UserRowInsert + +-- | Authentication errors. +data AuthError + = AuthInvalidUser + | AuthInvalidCredentials + | AuthSuspended + | AuthEphemeral + | AuthPendingInvitation + +instance APIError AuthError where + toWai AuthInvalidUser = errorToWai @'E.BadCredentials + toWai AuthInvalidCredentials = errorToWai @'E.BadCredentials + toWai AuthSuspended = accountSuspended + toWai AuthEphemeral = accountEphemeral + toWai AuthPendingInvitation = accountPending + +-- TODO(md): all the Wai.Error values in this module have been copied from +-- Brig.API.Error to avoid a cycle in module imports. Fix that. +accountSuspended :: Wai.Error +accountSuspended = Wai.mkError status403 "suspended" "Account suspended." + +accountEphemeral :: Wai.Error +accountEphemeral = Wai.mkError status403 "ephemeral" "Account is ephemeral." + +accountPending :: Wai.Error +accountPending = Wai.mkError status403 "pending-activation" "Account pending activation." + +-- | Re-authentication errors. +data ReAuthError + = ReAuthError !AuthError + | ReAuthMissingPassword + | ReAuthCodeVerificationRequired + | ReAuthCodeVerificationNoPendingCode + | ReAuthCodeVerificationNoEmail + +instance APIError ReAuthError where + toWai (ReAuthError e) = toWai e + toWai ReAuthMissingPassword = errorToWai @'E.MissingAuth + toWai ReAuthCodeVerificationRequired = verificationCodeRequired + toWai ReAuthCodeVerificationNoPendingCode = verificationCodeNoPendingCode + toWai ReAuthCodeVerificationNoEmail = verificationCodeNoEmail + +verificationCodeRequired :: Wai.Error +verificationCodeRequired = Wai.mkError status403 "code-authentication-required" "Verification code required." + +verificationCodeNoPendingCode :: Wai.Error +verificationCodeNoPendingCode = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such code)." + +verificationCodeNoEmail :: Wai.Error +verificationCodeNoEmail = Wai.mkError status403 "code-authentication-failed" "Code authentication failed (no such email)." + +------------------------------------------------------------------------------- +-- Conversions + +-- | Construct a 'UserAccount' from a raw user record in the database. +toUserAccount :: Domain -> Locale -> AccountRow -> UserAccount +toUserAccount + domain + defaultLocale + ( uid, + name, + pict, + email, + phone, + ssoid, + accent, + assets, + activated, + status, + expires, + lan, + con, + pid, + sid, + handle, + tid, + managed_by + ) = + let ident = toIdentity activated email phone ssoid + deleted = Just Deleted == status + expiration = if status == Just Ephemeral then expires else Nothing + loc = toLocale defaultLocale (lan, con) + svc = newServiceRef <$> sid <*> pid + in UserAccount + ( User + uid + (Qualified uid domain) + ident + name + (fromMaybe noPict pict) + (fromMaybe [] assets) + accent + deleted + loc + svc + handle + expiration + tid + (fromMaybe ManagedByWire managed_by) + ) + (fromMaybe Active status) + +toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale +toLocale _ (Just l, c) = Locale l c +toLocale l _ = l + +-- | Construct a 'UserIdentity'. +-- +-- If the user is not activated, 'toIdentity' will return 'Nothing' as a precaution, because +-- elsewhere we rely on the fact that a non-empty 'UserIdentity' means that the user is +-- activated. +-- +-- The reason it's just a "precaution" is that we /also/ have an invariant that having an +-- email or phone in the database means the user has to be activated. +toIdentity :: + -- | Whether the user is activated + Bool -> + Maybe Email -> + Maybe Phone -> + Maybe UserSSOId -> + Maybe UserIdentity +toIdentity True (Just e) (Just p) Nothing = Just $! FullIdentity e p +toIdentity True (Just e) Nothing Nothing = Just $! EmailIdentity e +toIdentity True Nothing (Just p) Nothing = Just $! PhoneIdentity p +toIdentity True email phone (Just ssoid) = Just $! SSOIdentity ssoid email phone +toIdentity True Nothing Nothing Nothing = Nothing +toIdentity False _ _ _ = Nothing + +------------------------------------------------------------------------------- + +type BotInConv = (BotId, ConvId, Maybe TeamId) + +data UserQuery p m a where + -- FUTUREWORK: The 'InsertAccount' action should perhaps be in an account store effect + InsertAccount :: + UserAccount -> + -- | If a bot: conversation and team + -- (if a team conversation) + Maybe (ConvId, Maybe TeamId) -> + Maybe Password -> + -- | Whether the user is activated + Bool -> + UserQuery p m () + GetId :: UserId -> UserQuery p m (Maybe UserId) -- idSelect + GetUsers :: [UserId] -> UserQuery p m [UserRow] -- usersSelect + GetServiceUsers :: -- lookupServiceUsers + ProviderId -> + ServiceId -> + Maybe (PagingState p BotInConv) -> + UserQuery p m (Page p BotInConv) + GetServiceUsersForTeam :: -- lookupServiceUsersForTeam + ProviderId -> + ServiceId -> + TeamId -> + Maybe (PagingState p (BotId, ConvId)) -> + UserQuery p m (Page p (BotId, ConvId)) + GetName :: UserId -> UserQuery p m (Maybe Name) -- nameSelect + GetLocale :: UserId -> UserQuery p m (Maybe (Maybe Language, Maybe Country)) -- localeSelect + GetAuthentication :: UserId -> UserQuery p m (Maybe (Maybe Password, Maybe AccountStatus)) -- authSelect + GetPassword :: UserId -> UserQuery p m (Maybe Password) -- passwordSelect + GetActivated :: UserId -> UserQuery p m Bool -- activatedSelect + GetAccountStatus :: UserId -> UserQuery p m (Maybe AccountStatus) -- statusSelect + GetAccountStatuses :: [UserId] -> UserQuery p m [(UserId, Bool, Maybe AccountStatus)] -- accountStateSelectAll + GetTeam :: UserId -> UserQuery p m (Maybe TeamId) -- teamSelect + GetAccounts :: [UserId] -> UserQuery p m [AccountRow] -- accountsSelect + + -- | Whether the account has been activated by verifying an email address or + -- phone number. + IsActivated :: UserId -> UserQuery p m Bool + UpdateUser :: UserId -> UserUpdate -> UserQuery p m () + UpdateEmail :: UserId -> Email -> UserQuery p m () + UpdateHandle :: UserId -> Handle -> UserQuery p m () + UpdatePhone :: UserId -> Phone -> UserQuery p m () + UpdateStatus :: UserId -> AccountStatus -> UserQuery p m () + ActivateUser :: UserId -> UserIdentity -> UserQuery p m () + DeleteEmailUnvalidated :: UserId -> UserQuery p m () + DeleteServiceUser :: + ProviderId -> + ServiceId -> + BotId -> + UserQuery p m () + +makeSem ''UserQuery + +lookupAccount :: + Members '[Input (Local ()), UserQuery p] r => + Locale -> + UserId -> + Sem r (Maybe UserAccount) +lookupAccount locale u = listToMaybe <$> lookupAccounts locale [u] + +lookupAccounts :: + Members '[Input (Local ()), UserQuery p] r => + Locale -> + [UserId] -> + Sem r [UserAccount] +lookupAccounts locale users = do + domain <- tDomain <$> input @(Local ()) + fmap (toUserAccount domain locale) <$> getAccounts users diff --git a/services/brig/src/Brig/Effects/UserQuery/Cassandra.hs b/services/brig/src/Brig/Effects/UserQuery/Cassandra.hs new file mode 100644 index 0000000000..327b138437 --- /dev/null +++ b/services/brig/src/Brig/Effects/UserQuery/Cassandra.hs @@ -0,0 +1,298 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 . +{-# LANGUAGE RecordWildCards #-} + +module Brig.Effects.UserQuery.Cassandra (userQueryToCassandra) where + +import Brig.Data.Instances () +import Brig.Effects.UserQuery +import Brig.Password +import Brig.Types.Intra +import Cassandra +import Control.Lens (view, (^.)) +import Data.Handle +import Data.Id +import Imports +import Polysemy +import Wire.API.Provider.Service +import Wire.API.User +import qualified Wire.Sem.Paging.Cassandra as PC + +userQueryToCassandra :: + forall r a. + (Member (Embed Client) r) => + Sem (UserQuery PC.InternalPaging ': r) a -> + Sem r a +userQueryToCassandra = + interpret $ + embed @Client . \case + GetId uid -> runIdentity <$$> retry x1 (query1 idSelect (params LocalQuorum (Identity uid))) + GetUsers uids -> retry x1 (query usersSelect (params LocalQuorum (Identity uids))) + GetServiceUsers pid sid Nothing -> flip PC.mkInternalPage pure =<< lookupServiceUsers pid sid + GetServiceUsers _pid _sid (Just ps) -> PC.ipNext ps + GetServiceUsersForTeam pid sid tid Nothing -> + flip PC.mkInternalPage pure + =<< lookupServiceUsersForTeam pid sid tid + GetServiceUsersForTeam _pid _sid _tid (Just ps) -> PC.ipNext ps + GetName uid -> runIdentity <$$> retry x1 (query1 nameSelect (params LocalQuorum (Identity uid))) + GetLocale uid -> retry x1 (query1 localeSelect (params LocalQuorum (Identity uid))) + GetAuthentication uid -> retry x1 (query1 authSelect (params LocalQuorum (Identity uid))) + GetPassword uid -> (runIdentity =<<) <$> retry x1 (query1 passwordSelect (params LocalQuorum (Identity uid))) + GetActivated uid -> (== Just (Identity True)) <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity uid))) + GetAccountStatus uid -> (runIdentity =<<) <$> retry x1 (query1 statusSelect (params LocalQuorum (Identity uid))) + GetAccountStatuses uids -> retry x1 (query accountStateSelectAll (params LocalQuorum (Identity uids))) + GetTeam uid -> (runIdentity =<<) <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity uid))) + GetAccounts uids -> retry x1 (query accountsSelect (params LocalQuorum (Identity uids))) + IsActivated uid -> isActivatedQuery uid + InsertAccount ua mConvTeam mPass act -> accountInsert ua mConvTeam mPass act + UpdateUser uid update -> userUpdate uid update + UpdateEmail uid email -> updateEmailQuery uid email + UpdateHandle uid handle -> updateHandleQuery uid handle + UpdatePhone uid phone -> updatePhoneQuery uid phone + UpdateStatus uid s -> updateStatusQuery uid s + ActivateUser uid ui -> activateUserQuery uid ui + DeleteEmailUnvalidated uid -> deleteEmailUnvalidatedQuery uid + DeleteServiceUser pid sid bid -> deleteServiceUserQuery pid sid bid + +-------------------------------------------------------------------------------- +-- Queries + +idSelect :: PrepQuery R (Identity UserId) (Identity UserId) +idSelect = "SELECT id FROM user WHERE id = ?" + +usersSelect :: PrepQuery R (Identity [UserId]) UserRow +usersSelect = + "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ + \activated, status, expires, language, country, provider, service, \ + \handle, team, managed_by \ + \FROM user where id IN ?" + +nameSelect :: PrepQuery R (Identity UserId) (Identity Name) +nameSelect = "SELECT name FROM user WHERE id = ?" + +localeSelect :: PrepQuery R (Identity UserId) (Maybe Language, Maybe Country) +localeSelect = "SELECT language, country FROM user WHERE id = ?" + +authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus) +authSelect = "SELECT password, status FROM user WHERE id = ?" + +passwordSelect :: PrepQuery R (Identity UserId) (Identity (Maybe Password)) +passwordSelect = "SELECT password FROM user WHERE id = ?" + +activatedSelect :: PrepQuery R (Identity UserId) (Identity Bool) +activatedSelect = "SELECT activated FROM user WHERE id = ?" + +statusSelect :: PrepQuery R (Identity UserId) (Identity (Maybe AccountStatus)) +statusSelect = "SELECT status FROM user WHERE id = ?" + +accountStateSelectAll :: PrepQuery R (Identity [UserId]) (UserId, Bool, Maybe AccountStatus) +accountStateSelectAll = "SELECT id, activated, status FROM user WHERE id IN ?" + +teamSelect :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId)) +teamSelect = "SELECT team FROM user WHERE id = ?" + +accountsSelect :: PrepQuery R (Identity [UserId]) AccountRow +accountsSelect = + "SELECT id, name, picture, email, phone, sso_id, accent_id, assets, \ + \activated, status, expires, language, country, provider, \ + \service, handle, team, managed_by \ + \FROM user WHERE id IN ?" + +accountInsert :: + MonadClient m => + UserAccount -> + -- | If a bot: conversation and team + -- (if a team conversation) + Maybe (ConvId, Maybe TeamId) -> + Maybe Password -> + -- | Whether the user is activated + Bool -> + m () +accountInsert (UserAccount u status) mbConv password activated = retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + let Locale l c = userLocale u + addPrepQuery + userInsert + ( userId u, + userDisplayName u, + userPict u, + userAssets u, + userEmail u, + userPhone u, + userSSOId u, + userAccentId u, + password, + activated, + status, + userExpire u, + l, + c, + view serviceRefProvider <$> userService u, + view serviceRefId <$> userService u, + userHandle u, + userTeam u, + userManagedBy u + ) + for_ ((,) <$> userService u <*> mbConv) $ \(sref, (cid, mbTid)) -> do + let pid = sref ^. serviceRefProvider + sid = sref ^. serviceRefId + addPrepQuery cqlServiceUser (pid, sid, BotId (userId u), cid, mbTid) + for_ mbTid $ \tid -> + addPrepQuery cqlServiceTeam (pid, sid, BotId (userId u), cid, tid) + where + cqlServiceUser :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, Maybe TeamId) () + cqlServiceUser = + "INSERT INTO service_user (provider, service, user, conv, team) \ + \VALUES (?, ?, ?, ?, ?)" + cqlServiceTeam :: PrepQuery W (ProviderId, ServiceId, BotId, ConvId, TeamId) () + cqlServiceTeam = + "INSERT INTO service_team (provider, service, user, conv, team) \ + \VALUES (?, ?, ?, ?, ?)" + userInsert :: PrepQuery W UserRowInsert () + userInsert = + "INSERT INTO user (id, name, picture, assets, email, phone, sso_id, \ + \accent_id, password, activated, status, expires, language, \ + \country, provider, service, handle, team, managed_by) \ + \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" + +userUpdate :: MonadClient m => UserId -> UserUpdate -> m () +userUpdate u UserUpdate {..} = retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + for_ uupName $ \n -> addPrepQuery userDisplayNameUpdate (n, u) + for_ uupPict $ \p -> addPrepQuery userPictUpdate (p, u) + for_ uupAssets $ \a -> addPrepQuery userAssetsUpdate (a, u) + for_ uupAccentId $ \c -> addPrepQuery userAccentIdUpdate (c, u) + where + userDisplayNameUpdate :: PrepQuery W (Name, UserId) () + userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" + + userPictUpdate :: PrepQuery W (Pict, UserId) () + userPictUpdate = "UPDATE user SET picture = ? WHERE id = ?" + + userAssetsUpdate :: PrepQuery W ([Asset], UserId) () + userAssetsUpdate = "UPDATE user SET assets = ? WHERE id = ?" + + userAccentIdUpdate :: PrepQuery W (ColourId, UserId) () + userAccentIdUpdate = "UPDATE user SET accent_id = ? WHERE id = ?" + +isActivatedQuery :: MonadClient m => UserId -> m Bool +isActivatedQuery u = + (== Just (Identity True)) + <$> retry x1 (query1 activatedSelect (params LocalQuorum (Identity u))) + +updateEmailQuery :: MonadClient m => UserId -> Email -> m () +updateEmailQuery u e = retry x5 $ write userEmailUpdate (params LocalQuorum (e, u)) + where + userEmailUpdate :: PrepQuery W (Email, UserId) () + userEmailUpdate = "UPDATE user SET email = ? WHERE id = ?" + +deleteEmailUnvalidatedQuery :: MonadClient m => UserId -> m () +deleteEmailUnvalidatedQuery u = + retry x5 $ write userEmailUnvalidatedDelete (params LocalQuorum (Identity u)) + where + userEmailUnvalidatedDelete :: PrepQuery W (Identity UserId) () + userEmailUnvalidatedDelete = "UPDATE user SET email_unvalidated = null WHERE id = ?" + +updatePhoneQuery :: MonadClient m => UserId -> Phone -> m () +updatePhoneQuery u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) + where + userPhoneUpdate :: PrepQuery W (Phone, UserId) () + userPhoneUpdate = "UPDATE user SET phone = ? WHERE id = ?" + +activateUserQuery :: MonadClient m => UserId -> UserIdentity -> m () +activateUserQuery u ident = do + let email = emailIdentity ident + let phone = phoneIdentity ident + retry x5 $ write userActivatedUpdate (params LocalQuorum (email, phone, u)) + where + userActivatedUpdate :: PrepQuery W (Maybe Email, Maybe Phone, UserId) () + userActivatedUpdate = "UPDATE user SET activated = true, email = ?, phone = ? WHERE id = ?" + +updateHandleQuery :: MonadClient m => UserId -> Handle -> m () +updateHandleQuery u h = retry x5 $ write userHandleUpdate (params LocalQuorum (h, u)) + where + userHandleUpdate :: PrepQuery W (Handle, UserId) () + userHandleUpdate = "UPDATE user SET handle = ? WHERE id = ?" + +deleteServiceUserQuery :: + MonadClient m => + ProviderId -> + ServiceId -> + BotId -> + m () +deleteServiceUserQuery pid sid bid = + lookupServiceUser >>= \case + Nothing -> pure () + Just (_, mbTid) -> retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery cql (pid, sid, bid) + for_ mbTid $ \tid -> + addPrepQuery cqlTeam (pid, sid, tid, bid) + where + lookupServiceUser :: MonadClient m => m (Maybe (ConvId, Maybe TeamId)) + lookupServiceUser = retry x1 (query1 q (params LocalQuorum (pid, sid, bid))) + where + q :: PrepQuery R (ProviderId, ServiceId, BotId) (ConvId, Maybe TeamId) + q = + "SELECT conv, team FROM service_user \ + \WHERE provider = ? AND service = ? AND user = ?" + cql :: PrepQuery W (ProviderId, ServiceId, BotId) () + cql = + "DELETE FROM service_user \ + \WHERE provider = ? AND service = ? AND user = ?" + cqlTeam :: PrepQuery W (ProviderId, ServiceId, TeamId, BotId) () + cqlTeam = + "DELETE FROM service_team \ + \WHERE provider = ? AND service = ? AND team = ? AND user = ?" + +updateStatusQuery :: MonadClient m => UserId -> AccountStatus -> m () +updateStatusQuery u s = + retry x5 $ write userStatusUpdate (params LocalQuorum (s, u)) + where + userStatusUpdate :: PrepQuery W (AccountStatus, UserId) () + userStatusUpdate = "UPDATE user SET status = ? WHERE id = ?" + +-- | NB: might return a lot of users, and therefore we do paging here. +lookupServiceUsers :: + MonadClient m => + ProviderId -> + ServiceId -> + m (Page (BotId, ConvId, Maybe TeamId)) +lookupServiceUsers pid sid = + retry x1 (paginate cql (params LocalQuorum (pid, sid))) + where + cql :: PrepQuery R (ProviderId, ServiceId) (BotId, ConvId, Maybe TeamId) + cql = + "SELECT user, conv, team FROM service_user \ + \WHERE provider = ? AND service = ?" + +lookupServiceUsersForTeam :: + MonadClient m => + ProviderId -> + ServiceId -> + TeamId -> + m (Page (BotId, ConvId)) +lookupServiceUsersForTeam pid sid tid = + retry x1 (paginate cql (params LocalQuorum (pid, sid, tid))) + where + cql :: PrepQuery R (ProviderId, ServiceId, TeamId) (BotId, ConvId) + cql = + "SELECT user, conv FROM service_team \ + \WHERE provider = ? AND service = ? AND team = ?" diff --git a/services/brig/src/Brig/Effects/VerificationCodeStore.hs b/services/brig/src/Brig/Effects/VerificationCodeStore.hs new file mode 100644 index 0000000000..7a0d1e8bf0 --- /dev/null +++ b/services/brig/src/Brig/Effects/VerificationCodeStore.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.Effects.VerificationCodeStore where + +import Brig.API.Types +import Data.Code +import Data.UUID +import Imports +import Polysemy +import Wire.API.User.Identity + +data Code = Code + { codeKey :: !Key, + codeScope :: !Scope, + codeValue :: !Value, + codeRetries :: !Retries, + codeTTL :: !Timeout, + codeFor :: !CodeFor, + codeAccount :: !(Maybe UUID) + } + deriving (Eq, Show) + +data CodeFor + = ForEmail !Email + | ForPhone !Phone + deriving (Eq, Show) + +-- | The same 'Key' can exist with different 'Value's in different +-- 'Scope's at the same time. +data Scope + = AccountDeletion + | IdentityVerification + | PasswordReset + | AccountLogin + | AccountApproval + | CreateScimToken + | DeleteTeam + deriving (Eq, Show) + +newtype Retries = Retries {numRetries :: Word8} + deriving (Eq, Show, Ord, Num, Integral, Enum, Real) + +data VerificationCodeStore m a where + GetPendingCode :: Key -> Scope -> VerificationCodeStore m (Maybe Code) -- 'lookup' in 'Brig.Code' + InsertCode :: Code -> Int -> VerificationCodeStore m (Maybe RetryAfter) -- 'insert' in 'Brig.Code' + InsertCodeInternal :: Code -> VerificationCodeStore m () -- 'insertInternal' in 'Brig.Code' + +makeSem ''VerificationCodeStore + +-- | Lookup and verify the code for the given key and scope +-- against the given value. +verifyCode :: + Member VerificationCodeStore r => + Key -> + Scope -> + Value -> + Sem r (Maybe Code) +verifyCode k s v = getPendingCode k s >>= maybe (pure Nothing) continue + where + continue c + | codeValue c == v = pure (Just c) + | codeRetries c > 0 = do + insertCodeInternal (c {codeRetries = codeRetries c - 1}) + pure Nothing + | otherwise = pure Nothing + +codeForEmail :: Code -> Maybe Email +codeForEmail c + | ForEmail e <- codeFor c = Just e + | otherwise = Nothing + +codeForPhone :: Code -> Maybe Phone +codeForPhone c + | ForPhone p <- codeFor c = Just p + | otherwise = Nothing diff --git a/services/brig/src/Brig/Effects/VerificationCodeStore/Cassandra.hs b/services/brig/src/Brig/Effects/VerificationCodeStore/Cassandra.hs new file mode 100644 index 0000000000..ae7c1f0cb4 --- /dev/null +++ b/services/brig/src/Brig/Effects/VerificationCodeStore/Cassandra.hs @@ -0,0 +1,143 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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 . +{-# OPTIONS_GHC -Wno-orphans #-} + +module Brig.Effects.VerificationCodeStore.Cassandra (verificationCodeStoreToCassandra) where + +import Brig.API.Types +import Brig.Data.Instances () +import Brig.Effects.VerificationCodeStore +import Cassandra hiding (Value) +import Data.Code +import Data.UUID +import Imports +import Polysemy +import Wire.API.User.Identity + +instance Cql Scope where + ctype = Tagged IntColumn + + toCql AccountDeletion = CqlInt 1 + toCql IdentityVerification = CqlInt 2 + toCql PasswordReset = CqlInt 3 + toCql AccountLogin = CqlInt 4 + toCql AccountApproval = CqlInt 5 + toCql CreateScimToken = CqlInt 6 + toCql DeleteTeam = CqlInt 7 + + fromCql (CqlInt 1) = pure AccountDeletion + fromCql (CqlInt 2) = pure IdentityVerification + fromCql (CqlInt 3) = pure PasswordReset + fromCql (CqlInt 4) = pure AccountLogin + fromCql (CqlInt 5) = pure AccountApproval + fromCql (CqlInt 6) = pure CreateScimToken + fromCql (CqlInt 7) = pure DeleteTeam + fromCql _ = Left "fromCql: Scope: int expected" + +instance Cql Retries where + ctype = Tagged IntColumn + toCql = CqlInt . fromIntegral . numRetries + fromCql (CqlInt n) = pure (Retries (fromIntegral n)) + fromCql _ = Left "fromCql: Retries: int expected" + +verificationCodeStoreToCassandra :: + forall m r a. + (MonadClient m, Member (Embed m) r) => + Sem (VerificationCodeStore ': r) a -> + Sem r a +verificationCodeStoreToCassandra = + interpret $ + embed @m . \case + x -> case x of + GetPendingCode key scope -> lookupCode key scope + InsertCode code ttl -> insert code ttl + InsertCodeInternal code -> insertInternal code + +-- | Lookup a pending code. +lookupCode :: MonadClient m => Key -> Scope -> m (Maybe Code) +lookupCode k s = fmap (toCode k s) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) + where + cql :: PrepQuery R (Key, Scope) (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) + cql = + "SELECT value, ttl(value), retries, email, phone, account \ + \FROM vcodes WHERE key = ? AND scope = ?" + +insert :: MonadClient m => Code -> Int -> m (Maybe RetryAfter) +insert code ttl = do + mRetryAfter <- lookupThrottle (codeKey code) (codeScope code) + case mRetryAfter of + Just ra -> pure (Just ra) + Nothing -> do + insertThrottle code ttl + insertInternal code + pure Nothing + where + insertThrottle :: MonadClient m => Code -> Int -> m () + insertThrottle c t = do + let k = codeKey c + let s = codeScope c + retry x5 (write cql (params LocalQuorum (k, s, fromIntegral t, fromIntegral t))) + where + cql :: PrepQuery W (Key, Scope, Int32, Int32) () + cql = + "INSERT INTO vcodes_throttle (key, scope, initial_delay) \ + \VALUES (?, ?, ?) USING TTL ?" + +insertInternal :: MonadClient m => Code -> m () +insertInternal c = do + let k = codeKey c + let s = codeScope c + let v = codeValue c + let r = fromIntegral (codeRetries c) + let a = codeAccount c + let e = codeForEmail c + let p = codeForPhone c + let t = round (codeTTL c) + retry x5 (write cql (params LocalQuorum (k, s, v, r, e, p, a, t))) + where + cql :: PrepQuery W (Key, Scope, Value, Retries, Maybe Email, Maybe Phone, Maybe UUID, Int32) () + cql = + "INSERT INTO vcodes (key, scope, value, retries, email, phone, account) \ + \VALUES (?, ?, ?, ?, ?, ?, ?) USING TTL ?" + +-- | Check if code generation should be throttled. +lookupThrottle :: MonadClient m => Key -> Scope -> m (Maybe RetryAfter) +lookupThrottle k s = do + fmap (RetryAfter . fromIntegral . runIdentity) <$> retry x1 (query1 cql (params LocalQuorum (k, s))) + where + cql :: PrepQuery R (Key, Scope) (Identity Int32) + cql = + "SELECT ttl(initial_delay) \ + \FROM vcodes_throttle WHERE key = ? AND scope = ?" + +toCode :: Key -> Scope -> (Value, Int32, Retries, Maybe Email, Maybe Phone, Maybe UUID) -> Code +toCode k s (val, ttl, retries, email, phone, account) = + let ek = ForEmail <$> email + pk = ForPhone <$> phone + to = Timeout (fromIntegral ttl) + in case ek <|> pk of + Nothing -> error "toCode: email or phone must be present" + Just cf -> + Code + { codeKey = k, + codeScope = s, + codeValue = val, + codeTTL = to, + codeRetries = retries, + codeFor = cf, + codeAccount = account + } diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index 00ce2c1ce4..4ff4c20b0a 100644 --- a/services/brig/src/Brig/Email.hs +++ b/services/brig/src/Brig/Email.hs @@ -19,15 +19,13 @@ module Brig.Email ( -- * Validation validateEmail, - -- * Unique Keys + -- * Re-exports + Email (..), EmailKey, mkEmailKey, emailKeyUniq, emailKeyOrig, - -- * Re-exports - Email (..), - -- * MIME Re-exports Mail (..), emptyMail, @@ -42,6 +40,7 @@ where import qualified Brig.AWS as AWS import Brig.App (Env, awsEnv, smtpEnv) import qualified Brig.SMTP as SMTP +import Brig.Types.Common import Control.Lens (view) import qualified Data.Text as Text import Imports @@ -55,39 +54,6 @@ sendMail m = Just smtp -> SMTP.sendMail smtp m Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m -------------------------------------------------------------------------------- --- 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"] - ------------------------------------------------------------------------------- -- MIME Conversions diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index c5c4b65042..5e6fd7cbe9 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -78,6 +78,8 @@ import Brig.API.Util import Brig.App import Brig.Data.Connection (lookupContactList) import qualified Brig.Data.Connection as Data +import Brig.Effects.GalleyAccess hiding (getTeamId, getTeamLegalHoldStatus) +import Brig.Effects.GundeckAccess import Brig.Federation.Client (notifyUserDeleted) import qualified Brig.IO.Journal as Journal import Brig.RPC @@ -88,13 +90,11 @@ import qualified Brig.User.Search.Index as Search import Cassandra (MonadClient) import Conduit (runConduit, (.|)) import Control.Error (ExceptT) -import Control.Error.Util -import Control.Lens (view, (.~), (?~), (^.)) +import Control.Lens (view, (^.)) import Control.Monad.Catch import Control.Monad.Trans.Except (runExceptT, throwE) import Control.Retry import Data.Aeson hiding (json) -import qualified Data.Aeson.KeyMap as KeyMap import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) @@ -103,13 +103,11 @@ import qualified Data.Currency as Currency import Data.Domain import Data.Either.Combinators (whenLeft) import Data.Id -import Data.Json.Util (UTCTimeMillis, (#)) -import Data.List.Split (chunksOf) -import Data.List1 (List1, list1, singleton) +import Data.Json.Util (UTCTimeMillis) +import Data.List.NonEmpty import Data.Proxy import Data.Qualified import Data.Range -import qualified Data.Set as Set import GHC.TypeLits import Galley.Types.Conversations.Intra (UpsertOne2OneConversationRequest, UpsertOne2OneConversationResponse) import qualified Galley.Types.Teams as Team @@ -121,14 +119,13 @@ import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai +import Polysemy import System.Logger.Class as Log hiding (name, (.=)) -import qualified System.Logger.Extended as ExLog import Wire.API.Connection -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import Wire.API.Event.Conversation (Connect (Connect)) import Wire.API.Federation.API.Brig import Wire.API.Federation.Error -import Wire.API.Properties import Wire.API.Team import qualified Wire.API.Team.Conversation as Conv import Wire.API.Team.Feature @@ -144,80 +141,72 @@ import Wire.API.User.Client -- Event Handlers onUserEvent :: - ( MonadLogger m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m - ) => + Members + '[ GalleyAccess, + GundeckAccess + ] + r => UserId -> Maybe ConnId -> UserEvent -> - m () + AppT r () onUserEvent orig conn e = - updateSearchIndex orig e + wrapClient (updateSearchIndex orig e) *> dispatchNotifications orig conn e - *> journalEvent orig e + *> wrapClient (journalEvent orig e) -- FUTUREWORK: this just needs MonadIO m and MonadReader + -- Env m. It seems to access AWS, so + -- perhaps that's an effect on its own. onConnectionEvent :: + Member GundeckAccess r => -- | Originator of the event. UserId -> -- | Client connection ID, if any. Maybe ConnId -> -- | The event. ConnectionEvent -> - (AppT r) () + Sem r () onConnectionEvent orig conn evt = do let from = ucFrom (ucConn evt) - wrapHttp $ - notify - (singleton $ ConnectionEvent evt) - orig - Push.RouteAny - conn - (pure $ list1 from []) + notify + (pure $ ConnectionEvent evt) + orig + Push.RouteAny + conn + (pure from) onPropertyEvent :: + Member GundeckAccess r => -- | Originator of the event. UserId -> -- | Client connection ID. ConnId -> PropertyEvent -> - (AppT r) () + Sem r () onPropertyEvent orig conn e = - wrapHttp $ - notify - (singleton $ PropertyEvent e) - orig - Push.RouteDirect - (Just conn) - (pure $ list1 orig []) + notify + (pure $ PropertyEvent e) + orig + Push.RouteDirect + (Just conn) + (pure orig) onClientEvent :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[GundeckAccess] r => -- | Originator of the event. UserId -> -- | Client connection ID. Maybe ConnId -> -- | The event. ClientEvent -> - m () + Sem r () onClientEvent orig conn e = do - let events = singleton (ClientEvent e) - let rcps = list1 orig [] + let events = pure (ClientEvent e) + let rcps = pure orig -- Synchronous push for better delivery guarantees of these -- events and to make sure new clients have a first notification -- in the stream. - push events rcps orig Push.RouteAny conn + pushEvents events rcps orig Push.RouteAny conn updateSearchIndex :: ( MonadClient m, @@ -276,19 +265,15 @@ journalEvent orig e = case e of -- as well as his other clients about a change to his user account -- or profile. dispatchNotifications :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m - ) => + Members + '[ GalleyAccess, + GundeckAccess + ] + r => UserId -> Maybe ConnId -> UserEvent -> - m () + AppT r () dispatchNotifications orig conn e = case e of UserCreated {} -> pure () UserSuspended {} -> pure () @@ -298,36 +283,28 @@ dispatchNotifications orig conn e = case e of UserLegalHoldEnabled {} -> notifyContacts event orig Push.RouteAny conn UserUpdated UserUpdatedData {..} -- This relies on the fact that we never change the locale AND something else. - | isJust eupLocale -> notifySelf event orig Push.RouteDirect conn + | isJust eupLocale -> liftSem $ notifySelf event orig Push.RouteDirect conn | otherwise -> notifyContacts event orig Push.RouteDirect conn - UserActivated {} -> notifySelf event orig Push.RouteAny conn - UserIdentityUpdated {} -> notifySelf event orig Push.RouteDirect conn - UserIdentityRemoved {} -> notifySelf event orig Push.RouteDirect conn + UserActivated {} -> liftSem $ notifySelf event orig Push.RouteAny conn + UserIdentityUpdated {} -> liftSem $ notifySelf event orig Push.RouteDirect conn + UserIdentityRemoved {} -> liftSem $ notifySelf event orig Push.RouteDirect conn UserDeleted {} -> do -- n.b. Synchronously fetch the contact list on the current thread. -- If done asynchronously, the connections may already have been deleted. notifyUserDeletionLocals orig conn event - notifyUserDeletionRemotes orig + wrapClient $ notifyUserDeletionRemotes orig where - event = singleton $ UserEvent e + event = pure $ UserEvent e notifyUserDeletionLocals :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m - ) => + Member GundeckAccess r => UserId -> Maybe ConnId -> - List1 Event -> - m () + NonEmpty Event -> + AppT r () notifyUserDeletionLocals deleted conn event = do - recipients <- list1 deleted <$> lookupContactList deleted - notify event deleted Push.RouteDirect conn (pure recipients) + recipients <- wrapClient $ (deleted :|) <$> lookupContactList deleted + liftSem $ notify event deleted Push.RouteDirect conn recipients notifyUserDeletionRemotes :: forall m. @@ -366,343 +343,37 @@ notifyUserDeletionRemotes deleted = do . Log.field "domain" (domainText domain) . Log.field "error" (show fErr) --- | Push events to other users. -push :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - -- | The events to push. - List1 Event -> - -- | The users to push to. - List1 UserId -> - -- | The originator of the events. - UserId -> - -- | The push routing strategy. - Push.Route -> - -- | The originating device connection. - Maybe ConnId -> - m () -push (toList -> events) usrs orig route conn = - case mapMaybe toPushData events of - [] -> pure () - x : xs -> rawPush (list1 x xs) usrs orig route conn - where - toPushData :: Event -> Maybe (Builder, (Object, Maybe ApsData)) - toPushData e = case toPushFormat e of - Just o -> Just (Log.bytes e, (o, toApsData e)) - Nothing -> Nothing - --- | Push encoded events to other users. Useful if you want to push --- something that's not defined in Brig. -rawPush :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - -- | The events to push. - List1 (Builder, (Object, Maybe ApsData)) -> - -- | The users to push to. - List1 UserId -> - -- | The originator of the events. - UserId -> - -- | The push routing strategy. - Push.Route -> - -- | The originating device connection. - Maybe ConnId -> - m () --- TODO: if we decide to have service whitelist events in Brig instead of --- Galley, let's merge 'push' and 'rawPush' back. See Note [whitelist events]. -rawPush (toList -> events) usrs orig route conn = do - for_ events $ \e -> debug $ remote "gundeck" . msg (fst e) - g <- view gundeck - forM_ recipients $ \rcps -> - void . recovering x3 rpcHandlers $ - const $ - rpc' - "gundeck" - g - ( method POST - . path "/i/push/v2" - . zUser orig -- FUTUREWORK: Remove, because gundeck handler ignores this. - . json (map (mkPush rcps . snd) events) - . expect2xx - ) - where - recipients :: [Range 1 1024 (Set.Set Recipient)] - recipients = - map (unsafeRange . Set.fromList) $ - chunksOf 512 $ - map (`recipient` route) $ - toList usrs - mkPush :: Range 1 1024 (Set.Set Recipient) -> (Object, Maybe ApsData) -> Push - mkPush rcps (o, aps) = - newPush - (Just orig) - rcps - (singletonPayload o) - & pushOriginConnection .~ conn - & pushNativeAps .~ aps - --- | (Asynchronously) notifies other users of events. -notify :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => - List1 Event -> - -- | Origin user, TODO: Delete - UserId -> - -- | Push routing strategy. - Push.Route -> - -- | Origin device connection, if any. - Maybe ConnId -> - -- | Users to notify. - m (List1 UserId) -> - m () -notify events orig route conn recipients = fork (Just orig) $ do - rs <- recipients - push events rs orig route conn - -fork :: - (MonadIO m, MonadUnliftIO m, MonadReader Env m) => - Maybe UserId -> - m a -> - m () -fork u ma = do - g <- view applog - r <- view requestId - let logErr e = ExLog.err g $ request r ~~ user u ~~ msg (show e) - withRunInIO $ \lower -> - void . liftIO . forkIO $ - either logErr (const $ pure ()) - =<< runExceptT (syncIO $ lower ma) - where - request = field "request" . unRequestId - user = maybe id (field "user" . toByteString) - -notifySelf :: - ( MonadIO m, - Log.MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => - List1 Event -> - -- | Origin user. - UserId -> - -- | Push routing strategy. - Push.Route -> - -- | Origin device connection, if any. - Maybe ConnId -> - m () -notifySelf events orig route conn = - notify events orig route conn (pure (singleton orig)) - notifyContacts :: - forall m. - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m, - MonadClient m, - MonadUnliftIO m - ) => - List1 Event -> + Members + '[ GalleyAccess, + GundeckAccess + ] + r => + NonEmpty Event -> -- | Origin user. UserId -> -- | Push routing strategy. Push.Route -> -- | Origin device connection, if any. Maybe ConnId -> - m () + AppT r () notifyContacts events orig route conn = do - notify events orig route conn $ - list1 orig <$> liftA2 (++) contacts teamContacts + rs <- (orig :|) <$> liftA2 (++) (wrapClient contacts) (liftSem teamContacts) + liftSem $ notify events orig route conn rs where - contacts :: m [UserId] + contacts :: MonadClient m => m [UserId] contacts = lookupContactList orig - teamContacts :: m [UserId] + teamContacts :: Member GalleyAccess r => Sem r [UserId] teamContacts = screenMemberList =<< getTeamContacts orig -- If we have a truncated team, we just ignore it all together to avoid very large fanouts -- - screenMemberList :: Maybe Team.TeamMemberList -> m [UserId] + screenMemberList :: Monad m => Maybe Team.TeamMemberList -> m [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = pure $ fmap (view Team.userId) (mems ^. Team.teamMembers) screenMemberList _ = pure [] --- Event Serialisation: - -toPushFormat :: Event -> Maybe Object -toPushFormat (UserEvent (UserCreated u)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.new" :: Text), - "user" .= SelfProfile (u {userIdentity = Nothing}) - ] -toPushFormat (UserEvent (UserActivated u)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.activate" :: Text), - "user" .= SelfProfile u - ] -toPushFormat (UserEvent (UserUpdated (UserUpdatedData i n pic acc ass hdl loc mb ssoId ssoIdDel))) = - Just $ - KeyMap.fromList - [ "type" .= ("user.update" :: Text), - "user" - .= object - ( "id" .= i - # "name" .= n - # "picture" .= pic -- DEPRECATED - # "accent_id" .= acc - # "assets" .= ass - # "handle" .= hdl - # "locale" .= loc - # "managed_by" .= mb - # "sso_id" .= ssoId - # "sso_id_deleted" .= ssoIdDel - # [] - ) - ] -toPushFormat (UserEvent (UserIdentityUpdated UserIdentityUpdatedData {..})) = - Just $ - KeyMap.fromList - [ "type" .= ("user.update" :: Text), - "user" - .= object - ( "id" .= eiuId - # "email" .= eiuEmail - # "phone" .= eiuPhone - # [] - ) - ] -toPushFormat (UserEvent (UserIdentityRemoved (UserIdentityRemovedData i e p))) = - Just $ - KeyMap.fromList - [ "type" .= ("user.identity-remove" :: Text), - "user" - .= object - ( "id" .= i - # "email" .= e - # "phone" .= p - # [] - ) - ] -toPushFormat (ConnectionEvent (ConnectionUpdated uc _ name)) = - Just $ - KeyMap.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] -toPushFormat (UserEvent (UserSuspended i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.suspend" :: Text), - "id" .= i - ] -toPushFormat (UserEvent (UserResumed i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.resume" :: Text), - "id" .= i - ] -toPushFormat (UserEvent (UserDeleted qid)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.delete" :: Text), - "id" .= qUnqualified qid, - "qualified_id" .= qid - ] -toPushFormat (UserEvent (UserLegalHoldDisabled i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-disable" :: Text), - "id" .= i - ] -toPushFormat (UserEvent (UserLegalHoldEnabled i)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-enable" :: Text), - "id" .= i - ] -toPushFormat (PropertyEvent (PropertySet _ k v)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-set" :: Text), - "key" .= k, - "value" .= propertyValue v - ] -toPushFormat (PropertyEvent (PropertyDeleted _ k)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-delete" :: Text), - "key" .= k - ] -toPushFormat (PropertyEvent (PropertiesCleared _)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.properties-clear" :: Text) - ] -toPushFormat (ClientEvent (ClientAdded _ c)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.client-add" :: Text), - "client" .= c - ] -toPushFormat (ClientEvent (ClientRemoved _ c)) = - Just $ - KeyMap.fromList - [ "type" .= ("user.client-remove" :: Text), - "client" .= IdObject (clientId c) - ] -toPushFormat (UserEvent (LegalHoldClientRequested payload)) = - let LegalHoldClientRequestedData targetUser lastPrekey' clientId = payload - in Just $ - KeyMap.fromList - [ "type" .= ("user.legalhold-request" :: Text), - "id" .= targetUser, - "last_prekey" .= lastPrekey', - "client" .= IdObject clientId - ] - -toApsData :: Event -> Maybe ApsData -toApsData (ConnectionEvent (ConnectionUpdated uc _ name)) = - case (ucStatus uc, name) of - (MissingLegalholdConsent, _) -> Nothing - (Pending, n) -> apsConnRequest <$> n - (Accepted, n) -> apsConnAccept <$> n - (Blocked, _) -> Nothing - (Ignored, _) -> Nothing - (Sent, _) -> Nothing - (Cancelled, _) -> Nothing - where - apsConnRequest n = - apsData (ApsLocKey "push.notification.connection.request") [fromName n] - & apsSound ?~ ApsSound "new_message_apns.caf" - apsConnAccept n = - apsData (ApsLocKey "push.notification.connection.accepted") [fromName n] - & apsSound ?~ ApsSound "new_message_apns.caf" -toApsData _ = Nothing - ------------------------------------------------------------------------------- -- Conversation Management @@ -1249,26 +920,26 @@ memberIsTeamOwner tid uid = do -- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. -- -- Calls 'Galley.API.getBindingTeamMembersH'. -getTeamContacts :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - m (Maybe Team.TeamMemberList) -getTeamContacts u = do - debug $ remote "galley" . msg (val "Get team contacts") - rs <- galleyRequest GET req - case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["i", "users", toByteString' u, "team", "members"] - . expect [status200, status404] +-- getTeamContacts :: +-- ( MonadReader Env m, +-- MonadIO m, +-- MonadMask m, +-- MonadHttp m, +-- HasRequestId m, +-- MonadLogger m +-- ) => +-- UserId -> +-- m (Maybe Team.TeamMemberList) +-- getTeamContacts u = do +-- debug $ remote "galley" . msg (val "Get team contacts") +-- rs <- galleyRequest GET req +-- case Bilge.statusCode rs of +-- 200 -> Just <$> decodeBody "galley" rs +-- _ -> pure Nothing +-- where +-- req = +-- paths ["i", "users", toByteString' u, "team", "members"] +-- . expect [status200, status404] -- | Calls 'Galley.API.getBindingTeamIdH'. getTeamId :: diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 8097f54bcc..d3a61a150c 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -20,68 +20,99 @@ module Brig.InternalEvent.Process ) where -import Bilge.IO (MonadHttp) -import Bilge.RPC (HasRequestId) import qualified Brig.API.User as API import Brig.App +import qualified Brig.Data.Client as Data +import Brig.Effects.ClientStore (ClientStore) +import qualified Brig.Effects.ClientStore as E +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess (GalleyAccess) +import Brig.Effects.GundeckAccess (GundeckAccess) +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore (UserKeyStore) +import Brig.Effects.UserQuery import Brig.IO.Intra (rmClient) import qualified Brig.IO.Intra as Intra import Brig.InternalEvent.Types -import Brig.Options (defDeleteThrottleMillis, setDeleteThrottleMillis) +import Brig.Options (defDeleteThrottleMillis, setDefaultUserLocale, setDeleteThrottleMillis) import qualified Brig.Provider.API as API import Brig.Types.User.Event -import Brig.User.Search.Index (MonadIndexIO) -import Cassandra (MonadClient) import Control.Lens (view) import Control.Monad.Catch import Data.ByteString.Conversion +import Data.Qualified import Imports +import Polysemy +import Polysemy.Conc.Effect.Race +import Polysemy.Conc.Race +import Polysemy.Input +import Polysemy.Time.Data.TimeUnit +import qualified Polysemy.TinyLog as P import System.Logger.Class (field, msg, val, (~~)) -import qualified System.Logger.Class as Log -import UnliftIO (timeout) -import Wire.API.User.Client (clientId) +import Wire.API.User.Client +import Wire.Sem.Concurrency +import Wire.Sem.Paging -- | Handle an internal event. -- -- Has a one-minute timeout that should be enough for anything that it does. onEvent :: - ( Log.MonadLogger m, - MonadCatch m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - MonadClient m - ) => + forall r p. + Paging p => + Members + '[ ClientStore, + Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + Race, + UniqueClaimsStore, + UserHandleStore, + UserKeyStore, + UserQuery p + ] + r => InternalNotification -> - m () -onEvent n = handleTimeout $ case n of - DeleteClient c uid mcon -> do - rmClient uid (clientId c) - Intra.onClientEvent uid mcon (ClientRemoved uid c) - DeleteUser uid -> do - Log.info $ - msg (val "Processing user delete event") - ~~ field "user" (toByteString uid) - API.lookupAccount uid >>= mapM_ API.deleteAccount - -- As user deletions are expensive resource-wise in the context of - -- bulk user deletions (e.g. during team deletions), - -- wait 'delay' ms before processing the next event - delay <- fromMaybe defDeleteThrottleMillis . setDeleteThrottleMillis <$> view settings - liftIO $ threadDelay (1000 * delay) - DeleteService pid sid -> do - Log.info $ - msg (val "Processing service delete event") - ~~ field "provider" (toByteString pid) - ~~ field "service" (toByteString sid) - API.finishDeleteService pid sid + AppT r () +onEvent n = do + locale <- setDefaultUserLocale <$> view settings + delay <- fromMaybe defDeleteThrottleMillis . setDeleteThrottleMillis <$> view settings + handleTimeout $ case n of + DeleteClient client uid mcon -> do + let cid = clientId client + mc <- wrapClient $ Data.lookupClient uid cid + for_ mc $ \c -> do + wrapHttp $ rmClient uid cid + liftSem $ E.deleteClient uid cid + liftSem $ Intra.onClientEvent uid mcon (ClientRemoved uid c) + DeleteUser uid -> do + liftSem . P.info $ + msg (val "Processing user delete event") + ~~ field "user" (toByteString uid) + liftSem (API.lookupAccount locale uid) >>= mapM_ API.deleteAccount + -- As user deletions are expensive resource-wise in the context of + -- bulk user deletions (e.g. during team deletions), + -- wait 'delay' ms before processing the next event + liftSem $ timeoutU (MicroSeconds $ 1000 * fromIntegral delay) $ pure () + DeleteService pid sid -> do + liftSem . P.info $ + msg (val "Processing service delete event") + ~~ field "provider" (toByteString pid) + ~~ field "service" (toByteString sid) + API.finishDeleteService pid sid where - handleTimeout act = - timeout 60000000 act >>= \case - Just x -> pure x - Nothing -> throwM (InternalEventTimeout n) + handleTimeout :: AppT r a -> AppT r a + handleTimeout _act = undefined + +-- act +-- >>= ( \case +-- Just x -> pure x +-- Nothing -> throwM (InternalEventTimeout n) +-- ) +-- . flip (withAsyncWait (Minutes 1)) await newtype InternalEventException = -- | 'onEvent' has timed out diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index eea25e0f5f..3a1cf18e8e 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -26,30 +26,34 @@ module Brig.Phone -- * Validation validatePhone, - -- * Unique Keys + -- * Re-exports + Phone (..), PhoneKey, mkPhoneKey, phoneKeyUniq, phoneKeyOrig, - - -- * Re-exports - Phone (..), ) where import Bilge.Retry (httpHandlers) import Brig.App -import Brig.Budget +import Brig.Effects.BudgetStore +import Brig.Effects.BudgetStore.Cassandra +import Brig.Effects.Twilio +import Brig.Types.Common import Cassandra (MonadClient) import Control.Lens (view) import Control.Monad.Catch import Control.Retry import Data.LanguageCodes import qualified Data.Metrics as Metrics +import Data.String.Conversions import qualified Data.Text as Text import Data.Time.Clock import Imports import Network.HTTP.Client (HttpException, Manager) +import Polysemy +import qualified Polysemy.Error as P import qualified Ropes.Nexmo as Nexmo import Ropes.Twilio (LookupDetail (..)) import qualified Ropes.Twilio as Twilio @@ -202,21 +206,17 @@ sendSms loc SMSMessage {..} = unless (isTestPhone smsTo) $ do -- | Validate a phone number. Returns the canonical -- E.164 format of the given phone number on success. -validatePhone :: (MonadClient m, MonadReader Env m) => Phone -> m (Maybe Phone) +validatePhone :: + Members '[P.Error Twilio.ErrorResponse, Twilio] r => + Phone -> + Sem r (Maybe Phone) validatePhone (Phone p) | isTestPhone p = pure (Just (Phone p)) | otherwise = do - c <- view twilioCreds - m <- view httpManager - r <- - liftIO . try @_ @Twilio.ErrorResponse $ - recovering x3 httpHandlers $ - const $ - Twilio.lookupPhone c m p LookupNoDetail Nothing - case r of + lookupPhone p LookupNoDetail Nothing >>= \case Right x -> pure (Just (Phone (Twilio.lookupE164 x))) Left e | Twilio.errStatus e == 404 -> pure Nothing - Left e -> throwM e + Left e -> P.throw e isTestPhone :: Text -> Bool isTestPhone = Text.isPrefixOf "+0" @@ -232,6 +232,7 @@ smsBudget = } withSmsBudget :: + forall m a. ( MonadClient m, Log.MonadLogger m, MonadReader Env m @@ -241,7 +242,7 @@ withSmsBudget :: m a withSmsBudget phone go = do let k = BudgetKey ("sms#" <> phone) - r <- withBudget k smsBudget go + r <- runM $ budgetStoreToCassandra @m @'[Embed m] $ withBudget k smsBudget (embed @m go) case r of BudgetExhausted t -> do Log.info $ @@ -267,6 +268,7 @@ callBudget = } withCallBudget :: + forall m a. ( MonadClient m, Log.MonadLogger m, MonadReader Env m @@ -276,7 +278,7 @@ withCallBudget :: m a withCallBudget phone go = do let k = BudgetKey ("call#" <> phone) - r <- withBudget k callBudget go + r <- runM $ budgetStoreToCassandra @m @'[Embed m] $ withBudget k callBudget (embed @m go) case r of BudgetExhausted t -> do Log.info $ @@ -291,27 +293,6 @@ withCallBudget phone go = do ~~ field "phone" phone pure a --------------------------------------------------------------------------------- --- Unique Keys - -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 - ------------------------------------------------------------------------------- -- Retry Settings diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index f02a1d5bb2..298ff6a09c 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -36,10 +36,14 @@ import Brig.App import qualified Brig.Code as Code import qualified Brig.Data.Client as User import qualified Brig.Data.User as User +import Brig.Effects.ClientStore +import Brig.Effects.GalleyAccess +import Brig.Effects.UserQuery (UserQuery, getServiceUsers, getServiceUsersForTeam) +import Brig.Effects.VerificationCodeStore import Brig.Email (mkEmailKey) import qualified Brig.IO.Intra as RPC import qualified Brig.InternalEvent.Types as Internal -import Brig.Options (Settings (..)) +import Brig.Options (Settings (..), setDefaultUserLocale) import qualified Brig.Options as Opt import Brig.Password import Brig.Provider.DB (ServiceConn (..)) @@ -60,8 +64,6 @@ import Control.Monad.Except import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy.Char8 as LC8 -import Data.Conduit (runConduit, (.|)) -import qualified Data.Conduit.List as C import Data.Hashable (hash) import Data.Id import Data.LegalHold @@ -91,11 +93,12 @@ import qualified OpenSSL.EVP.PKey as SSL import qualified OpenSSL.PEM as SSL import qualified OpenSSL.RSA as SSL import OpenSSL.Random (randBytes) +import Polysemy +import Polysemy.Input import qualified Ssl.Util as SSL import System.Logger.Class (MonadLogger) -import UnliftIO.Async (pooledMapConcurrentlyN_) import qualified Web.Cookie as Cookie -import Wire.API.Conversation +import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Bot import qualified Wire.API.Conversation.Bot as Public import Wire.API.Conversation.Role @@ -120,8 +123,21 @@ import Wire.API.User.Client import qualified Wire.API.User.Client as Public (Client, ClientCapability (ClientSupportsLegalholdImplicitConsent), PubClient (..), UserClientPrekeyMap, UserClients, userClients) import qualified Wire.API.User.Client.Prekey as Public (PrekeyId) import qualified Wire.API.User.Identity as Public (Email) - -routesPublic :: Routes Doc.ApiBuilder (Handler r) () +import Wire.Sem.Concurrency +import Wire.Sem.Paging + +routesPublic :: + Paging p => + Members + '[ ClientStore, + Concurrency 'Unsafe, + GalleyAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Public API (Unauthenticated) -------------------------------------------- @@ -320,7 +336,9 @@ routesPublic = do .&> zauth ZAuthBot .&> capture "uid" -routesInternal :: Routes a (Handler r) () +routesInternal :: + Members '[VerificationCodeStore] r => + Routes a (Handler r) () routesInternal = do get "/i/provider/activation-code" (continue getActivationCodeH) $ accept "application" "json" @@ -329,12 +347,18 @@ routesInternal = do -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccountH :: JsonRequest Public.NewProvider -> (Handler r) Response +newAccountH :: + Members '[VerificationCodeStore] r => + JsonRequest Public.NewProvider -> + Handler r Response newAccountH req = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing setStatus status201 . json <$> (newAccount =<< parseJsonBody req) -newAccount :: Public.NewProvider -> (Handler r) Public.NewProviderResponse +newAccount :: + Members '[VerificationCodeStore] r => + Public.NewProvider -> + Handler r Public.NewProviderResponse newAccount new = do email <- case validateEmail (Public.newProviderEmail new) of Right em -> pure em @@ -360,20 +384,28 @@ newAccount new = do (Code.Retries 3) (Code.Timeout (3600 * 24)) -- 24h (Just (toUUID pid)) + -- lift . liftSem $ Code.insertCode code tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled let key = Code.codeKey code let val = Code.codeValue code lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response +activateAccountKeyH :: + Members '[VerificationCodeStore] r => + Code.Key ::: Code.Value -> + Handler r Response activateAccountKeyH (key ::: val) = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing maybe (setStatus status204 empty) json <$> activateAccountKey key val -activateAccountKey :: Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) +activateAccountKey :: + Members '[VerificationCodeStore] r => + Code.Key -> + Code.Value -> + Handler r (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do - c <- wrapClientE (Code.verify key Code.IdentityVerification val) >>= maybeInvalidCode + c <- (lift . liftSem) (Code.verifyCode key Code.IdentityVerification val) >>= maybeInvalidCode (pid, email) <- case (Code.codeAccount c, Code.codeForEmail c) of (Just p, Just e) -> pure (Id p, e) _ -> throwStd (errorToWai @'E.InvalidCode) @@ -393,18 +425,24 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Public.Email -> (Handler r) Response +getActivationCodeH :: + Members '[VerificationCodeStore] r => + Public.Email -> + Handler r Response getActivationCodeH e = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing json <$> getActivationCode e -getActivationCode :: Public.Email -> (Handler r) FoundActivationCode +getActivationCode :: + Members '[VerificationCodeStore] r => + Public.Email -> + Handler r FoundActivationCode getActivationCode e = do email <- case validateEmail e of Right em -> pure em Left _ -> throwStd (errorToWai @'E.InvalidEmail) gen <- Code.mkGen (Code.ForEmail email) - code <- wrapClientE $ Code.lookup (Code.genKey gen) Code.IdentityVerification + code <- lift . liftSem $ Code.getPendingCode (Code.genKey gen) Code.IdentityVerification maybe (throwStd activationKeyNotFound) (pure . FoundActivationCode) code newtype FoundActivationCode = FoundActivationCode Code.Code @@ -414,14 +452,21 @@ instance ToJSON FoundActivationCode where toJSON $ Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) -approveAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response +approveAccountKeyH :: + Members '[VerificationCodeStore] r => + Code.Key ::: Code.Value -> + Handler r Response approveAccountKeyH (key ::: val) = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing empty <$ approveAccountKey key val -approveAccountKey :: Code.Key -> Code.Value -> (Handler r) () +approveAccountKey :: + Members '[VerificationCodeStore] r => + Code.Key -> + Code.Value -> + Handler r () approveAccountKey key val = do - c <- wrapClientE (Code.verify key Code.AccountApproval val) >>= maybeInvalidCode + c <- (lift . liftSem) (Code.verifyCode key Code.AccountApproval val) >>= maybeInvalidCode case (Code.codeAccount c, Code.codeForEmail c) of (Just pid, Just email) -> do (name, _, _, _) <- wrapClientE (DB.lookupAccountData (Id pid)) >>= maybeInvalidCode @@ -443,16 +488,22 @@ login l = do throwStd (errorToWai @'E.BadCredentials) ZAuth.newProviderToken pid -beginPasswordResetH :: JsonRequest Public.PasswordReset -> (Handler r) Response +beginPasswordResetH :: + Members '[VerificationCodeStore] r => + JsonRequest Public.PasswordReset -> + Handler r Response beginPasswordResetH req = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing setStatus status201 empty <$ (beginPasswordReset =<< parseJsonBody req) -beginPasswordReset :: Public.PasswordReset -> (Handler r) () +beginPasswordReset :: + Members '[VerificationCodeStore] r => + Public.PasswordReset -> + Handler r () beginPasswordReset (Public.PasswordReset target) = do pid <- wrapClientE (DB.lookupKey (mkEmailKey target)) >>= maybeBadCredentials gen <- Code.mkGen (Code.ForEmail target) - pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.PasswordReset + pending <- lift . liftSem $ Code.getPendingCode (Code.genKey gen) Code.PasswordReset code <- case pending of Just p -> throwE $ pwResetError (PasswordResetInProgress . Just $ Code.codeTTL p) Nothing -> @@ -462,17 +513,24 @@ beginPasswordReset (Public.PasswordReset target) = do (Code.Retries 3) (Code.Timeout 3600) -- 1h (Just (toUUID pid)) + -- lift . liftSem $ Code.insertCode code tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) -completePasswordResetH :: JsonRequest Public.CompletePasswordReset -> (Handler r) Response +completePasswordResetH :: + Members '[VerificationCodeStore] r => + JsonRequest Public.CompletePasswordReset -> + Handler r Response completePasswordResetH req = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing empty <$ (completePasswordReset =<< parseJsonBody req) -completePasswordReset :: Public.CompletePasswordReset -> (Handler r) () +completePasswordReset :: + Members '[VerificationCodeStore] r => + Public.CompletePasswordReset -> + Handler r () completePasswordReset (Public.CompletePasswordReset key val newpwd) = do - code <- wrapClientE (Code.verify key Code.PasswordReset val) >>= maybeInvalidCode + code <- (lift . liftSem) (Code.verifyCode key Code.PasswordReset val) >>= maybeInvalidCode case Id <$> Code.codeAccount code of Nothing -> throwE $ pwResetError InvalidPasswordResetCode Just pid -> do @@ -511,12 +569,19 @@ updateAccountProfile pid upd = do (updateProviderUrl upd) (updateProviderDescr upd) -updateAccountEmailH :: ProviderId ::: JsonRequest Public.EmailUpdate -> (Handler r) Response +updateAccountEmailH :: + Members '[VerificationCodeStore] r => + ProviderId ::: JsonRequest Public.EmailUpdate -> + Handler r Response updateAccountEmailH (pid ::: req) = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing setStatus status202 empty <$ (updateAccountEmail pid =<< parseJsonBody req) -updateAccountEmail :: ProviderId -> Public.EmailUpdate -> (Handler r) () +updateAccountEmail :: + Members '[VerificationCodeStore] r => + ProviderId -> + Public.EmailUpdate -> + Handler r () updateAccountEmail pid (Public.EmailUpdate new) = do email <- case validateEmail new of Right em -> pure em @@ -531,6 +596,7 @@ updateAccountEmail pid (Public.EmailUpdate new) = do (Code.Retries 3) (Code.Timeout (3600 * 24)) -- 24h (Just (toUUID pid)) + -- lift . liftSem $ Code.insertCode code tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True @@ -688,29 +754,33 @@ deleteService pid sid del = do lift $ Queue.enqueue queue (Internal.DeleteService pid sid) finishDeleteService :: - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m, - MonadClient m, - MonadUnliftIO m - ) => + forall p r. + Paging p => + Members + '[ ClientStore, + Concurrency 'Unsafe, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => ProviderId -> ServiceId -> - m () + AppT r () finishDeleteService pid sid = do - mbSvc <- DB.lookupService pid sid + mbSvc <- wrapClient $ DB.lookupService pid sid + locale <- setDefaultUserLocale <$> view settings for_ mbSvc $ \svc -> do let tags = unsafeRange (serviceTags svc) name = serviceName svc - runConduit $ - User.lookupServiceUsers pid sid - .| C.mapM_ (pooledMapConcurrentlyN_ 16 kick) - RPC.removeServiceConn pid sid - DB.deleteService pid sid name tags + liftSem $ + withChunks @p + (getServiceUsers pid sid) + (unsafePooledMapConcurrentlyN_ 16 (kick locale)) + wrapHttp $ RPC.removeServiceConn pid sid + wrapClient $ DB.deleteService pid sid name tags where - kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid + kick l (bid, cid, _) = deleteBot l (botUserId bid) Nothing bid cid deleteAccountH :: ( MonadReader Env m, @@ -834,7 +904,18 @@ getServiceTagList () = pure (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelistH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> (Handler r) Response +updateServiceWhitelistH :: + Paging p => + Members + '[ ClientStore, + Concurrency 'Unsafe, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> + Handler r Response updateServiceWhitelistH (uid ::: con ::: tid ::: req) = do mapExceptT wrapHttp $ guardSecondFactorDisabled (Just uid) resp <- updateServiceWhitelist uid con tid =<< parseJsonBody req @@ -847,7 +928,22 @@ data UpdateServiceWhitelistResp = UpdateServiceWhitelistRespChanged | UpdateServiceWhitelistRespUnchanged -updateServiceWhitelist :: UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp +updateServiceWhitelist :: + forall r p. + Paging p => + Members + '[ ClientStore, + Concurrency 'Unsafe, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId -> + ConnId -> + TeamId -> + Public.UpdateServiceWhitelist -> + (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do let pid = updateServiceWhitelistProvider upd sid = updateServiceWhitelistService upd @@ -857,6 +953,7 @@ updateServiceWhitelist uid con tid upd = do _ <- wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound -- Add to various tables whitelisted <- wrapClientE $ DB.getServiceWhitelistStatus tid pid sid + locale <- setDefaultUserLocale <$> view settings case (whitelisted, newWhitelisted) of (False, False) -> pure UpdateServiceWhitelistRespUnchanged (True, True) -> pure UpdateServiceWhitelistRespUnchanged @@ -866,28 +963,44 @@ updateServiceWhitelist uid con tid upd = do (True, False) -> do -- When the service is de-whitelisted, remove its bots from team -- conversations - lift $ - fmap - wrapHttpClient - runConduit - $ User.lookupServiceUsersForTeam pid sid tid - .| C.mapM_ - ( pooledMapConcurrentlyN_ - 16 - ( uncurry (deleteBot uid (Just con)) - ) + lift . liftSem $ + withChunks @p + (getServiceUsersForTeam pid sid tid) + ( unsafePooledMapConcurrentlyN_ + 16 + ( uncurry (deleteBot locale uid (Just con)) ) + ) wrapClientE $ DB.deleteServiceWhitelist (Just tid) pid sid pure UpdateServiceWhitelistRespChanged -addBotH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> (Handler r) Response +addBotH :: + Members + '[ Input (Local ()), + UserQuery p + ] + r => + UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> + (Handler r) Response addBotH (zuid ::: zcon ::: cid ::: req) = do mapExceptT wrapHttp $ guardSecondFactorDisabled (Just zuid) setStatus status201 . json <$> (addBot zuid zcon cid =<< parseJsonBody req) -addBot :: UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse +addBot :: + Members + '[ Input (Local ()), + UserQuery p + ] + r => + UserId -> + ConnId -> + ConvId -> + Public.AddBot -> + (Handler r) Public.AddBotResponse addBot zuid zcon cid add = do - zusr <- lift (wrapClient $ User.lookupUser NoPendingInvitations zuid) >>= maybeInvalidUser + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + zusr <- lift (liftSem $ User.lookupUser loc locale NoPendingInvitations zuid) >>= maybeInvalidUser let pid = addBotProvider add let sid = addBotService add -- Get the conversation and check preconditions @@ -926,7 +1039,6 @@ addBot zuid zcon cid add = do let botReq = NewBotRequest bid bcl busr bcnv btk bloc rs <- RPC.createBot scon botReq !>> StdError . serviceError -- Insert the bot user and client - locale <- Opt.setDefaultUserLocale <$> view settings let name = fromMaybe (serviceProfileName svp) (Ext.rsNewBotName rs) let assets = fromMaybe (serviceProfileAssets svp) (Ext.rsNewBotAssets rs) let colour = fromMaybe defaultAccentId (Ext.rsNewBotColour rs) @@ -937,14 +1049,14 @@ addBot zuid zcon cid add = do (newClient PermanentClientType (Ext.rsNewBotLastPrekey rs)) { newClientPrekeys = Ext.rsNewBotPrekeys rs } - lift $ wrapClient $ User.insertAccount (UserAccount usr Active) (Just (cid, cnvTeam cnv)) Nothing True + lift . liftSem $ User.insertAccount (UserAccount usr Active) (Just (cid, cnvTeam cnv)) Nothing True maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings (clt, _, _) <- do _ <- do -- if we want to protect bots against lh, 'addClient' cannot just send lh capability -- implicitly in the next line. pure $ FutureWork @'UnprotectedBot undefined - wrapClientE (User.addClient (botUserId bid) bcl newClt maxPermClients Nothing (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent)) + User.addClient (botUserId bid) bcl newClt maxPermClients Nothing (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent) !>> const (StdError badGateway) -- MalformedPrekeys -- Add the bot to the conversation @@ -959,12 +1071,33 @@ addBot zuid zcon cid add = do Public.rsAddBotEvent = ev } -removeBotH :: UserId ::: ConnId ::: ConvId ::: BotId -> (Handler r) Response +removeBotH :: + Members + '[ ClientStore, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId ::: ConnId ::: ConvId ::: BotId -> + Handler r Response removeBotH (zusr ::: zcon ::: cid ::: bid) = do mapExceptT wrapHttp $ guardSecondFactorDisabled (Just zusr) maybe (setStatus status204 empty) json <$> removeBot zusr zcon cid bid -removeBot :: UserId -> ConnId -> ConvId -> BotId -> (Handler r) (Maybe Public.RemoveBotResponse) +removeBot :: + Members + '[ ClientStore, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + UserId -> + ConnId -> + ConvId -> + BotId -> + Handler r (Maybe Public.RemoveBotResponse) removeBot zusr zcon cid bid = do -- Get the conversation and check preconditions cnv <- lift (wrapHttp $ RPC.getConv zusr cid) >>= maybeConvNotFound @@ -974,22 +1107,33 @@ removeBot zusr zcon cid bid = do -- Find the bot in the member list and delete it let busr = botUserId bid let bot = List.find ((== busr) . qUnqualified . omQualifiedId) (cmOthers mems) + locale <- setDefaultUserLocale <$> view settings case bot >>= omService of Nothing -> pure Nothing Just _ -> do - lift $ Public.RemoveBotResponse <$$> wrapHttpClient (deleteBot zusr (Just zcon) bid cid) + lift . liftSem $ + Public.RemoveBotResponse + <$$> deleteBot locale zusr (Just zcon) bid cid -------------------------------------------------------------------------------- -- Bot API -botGetSelfH :: BotId -> (Handler r) Response +botGetSelfH :: + Member (UserQuery p) r => + BotId -> + (Handler r) Response botGetSelfH bot = do mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bot)) json <$> botGetSelf bot -botGetSelf :: BotId -> (Handler r) Public.UserProfile +botGetSelf :: + Member (UserQuery p) r => + BotId -> + (Handler r) Public.UserProfile botGetSelf bot = do - p <- lift $ wrapClient $ User.lookupUser NoPendingInvitations (botUserId bot) + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + p <- lift . liftSem $ User.lookupUser loc locale NoPendingInvitations (botUserId bot) maybe (throwStd (errorToWai @'E.UserNotFound)) (pure . (`Public.publicProfile` UserLegalHoldNoConsent)) p botGetClientH :: BotId -> (Handler r) Response @@ -1039,14 +1183,22 @@ botClaimUsersPrekeys body = do throwStd (errorToWai @'E.TooManyClients) Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError -botListUserProfilesH :: List UserId -> (Handler r) Response +botListUserProfilesH :: + Member (UserQuery p) r => + List UserId -> + (Handler r) Response botListUserProfilesH uids = do mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing -- should we check all user ids? json <$> botListUserProfiles uids -botListUserProfiles :: List UserId -> (Handler r) [Public.BotUserView] +botListUserProfiles :: + Member (UserQuery p) r => + List UserId -> + (Handler r) [Public.BotUserView] botListUserProfiles uids = do - us <- lift . wrapClient $ User.lookupUsers NoPendingInvitations (fromList uids) + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + us <- lift . liftSem $ User.lookupUsers loc locale NoPendingInvitations (fromList uids) pure (map mkBotUserView us) botGetUserClientsH :: UserId -> (Handler r) Response @@ -1060,17 +1212,38 @@ botGetUserClients uid = where pubClient c = Public.PubClient (clientId c) (clientClass c) -botDeleteSelfH :: BotId ::: ConvId -> (Handler r) Response +botDeleteSelfH :: + Members + '[ ClientStore, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + BotId ::: ConvId -> + (Handler r) Response botDeleteSelfH (bid ::: cid) = do mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bid)) empty <$ botDeleteSelf bid cid -botDeleteSelf :: BotId -> ConvId -> (Handler r) () +botDeleteSelf :: + Members + '[ ClientStore, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + BotId -> + ConvId -> + (Handler r) () botDeleteSelf bid cid = do + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bid)) - bot <- lift . wrapClient $ User.lookupUser NoPendingInvitations (botUserId bid) + bot <- lift . liftSem $ User.lookupUser loc locale NoPendingInvitations (botUserId bid) _ <- maybeInvalidBot (userService =<< bot) - _ <- lift $ wrapHttpClient $ deleteBot (botUserId bid) Nothing bid cid + _ <- lift . liftSem $ deleteBot locale (botUserId bid) Nothing bid cid pure () -------------------------------------------------------------------------------- @@ -1104,32 +1277,36 @@ activate pid old new = do wrapClientE $ DB.insertKey pid (mkEmailKey <$> old) emailKey deleteBot :: - ( MonadHttp m, - MonadReader Env m, - MonadMask m, - HasRequestId m, - MonadLogger m, - MonadClient m - ) => + forall r p. + Members + '[ ClientStore, + GalleyAccess, + Input (Local ()), + UserQuery p + ] + r => + Locale -> UserId -> Maybe ConnId -> BotId -> ConvId -> - m (Maybe Public.Event) -deleteBot zusr zcon bid cid = do + Sem r (Maybe Public.Event) +deleteBot locale zusr zcon bid cid = do -- Remove the bot from the conversation - ev <- RPC.removeBotMember zusr zcon cid bid + ev <- removeBotMember zusr zcon cid bid -- Delete the bot user and client let buid = botUserId bid - mbUser <- User.lookupUser NoPendingInvitations buid - User.lookupClients buid >>= mapM_ (User.rmClient buid . clientId) + loc <- input + mbUser <- + User.lookupUser loc locale NoPendingInvitations buid + lookupClients buid >>= mapM_ (deleteClient buid . clientId) for_ (userService =<< mbUser) $ \sref -> do let pid = sref ^. serviceRefProvider sid = sref ^. serviceRefId User.deleteServiceUser pid sid bid -- TODO: Consider if we can actually delete the bot user entirely, -- i.e. not just marking the account as deleted. - void $ runExceptT $ User.updateStatus buid Deleted + User.updateStatus buid Deleted pure ev validateServiceKey :: MonadIO m => Public.ServiceKeyPEM -> m (Maybe (Public.ServiceKey, Fingerprint Rsa)) diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index f722226918..28231daa9a 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -18,10 +18,8 @@ module Brig.Provider.DB where import Brig.Data.Instances () -import Brig.Email (EmailKey, emailKeyOrig, emailKeyUniq) +import Brig.Email import Brig.Password --- import Brig.Provider.DB.Instances () - import Brig.Types.Instances () import Brig.Types.Provider.Tag import Cassandra as C diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 5320a81f19..796b9b55a8 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -16,20 +16,23 @@ -- with this program. If not, see . -- | General RPC utilities. -module Brig.RPC where +module Brig.RPC + ( module Brig.RPC, + module Brig.RPC.Decode, + ) +where import Bilge import Bilge.RPC import Bilge.Retry import Brig.App +import Brig.RPC.Decode import Control.Lens import Control.Monad.Catch import Control.Retry -import Data.Aeson import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as BL import Data.Id -import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import Imports import Network.HTTP.Client (HttpExceptionContent (..), checkResponse) @@ -46,9 +49,6 @@ zUser = header "Z-User" . toByteString' remote :: ByteString -> Msg -> Msg remote = field "remote" -decodeBody :: (Typeable a, FromJSON a, MonadThrow m) => Text -> Response (Maybe BL.ByteString) -> m a -decodeBody ctx = responseJsonThrow (ParseException ctx) - expect :: [Status] -> Request -> Request expect ss rq = rq {checkResponse = check} where @@ -92,18 +92,3 @@ serviceRequest nm svc m r = do recovering x3 rpcHandlers $ const $ rpc' nm service (method m . r) - --- | Failed to parse a response from another service. -data ParseException = ParseException - { _parseExceptionRemote :: !Text, - _parseExceptionMsg :: String - } - -instance Show ParseException where - show (ParseException r m) = - "Failed to parse response from remote " - ++ Text.unpack r - ++ " with message: " - ++ m - -instance Exception ParseException diff --git a/services/brig/src/Brig/RPC/Decode.hs b/services/brig/src/Brig/RPC/Decode.hs new file mode 100644 index 0000000000..ec6bdb8e87 --- /dev/null +++ b/services/brig/src/Brig/RPC/Decode.hs @@ -0,0 +1,47 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 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.RPC.Decode where + +import Bilge.Response +import Control.Monad.Catch +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import Imports + +decodeBody :: + (Typeable a, FromJSON a, MonadThrow m) => + Text -> + Response (Maybe LBS.ByteString) -> + m a +decodeBody ctx = responseJsonThrow (ParseException ctx) + +-- | Failed to parse a response from another service. +data ParseException = ParseException + { _parseExceptionRemote :: !Text, + _parseExceptionMsg :: String + } + +instance Show ParseException where + show (ParseException r m) = + "Failed to parse response from remote " + ++ Text.unpack r + ++ " with message: " + ++ m + +instance Exception ParseException diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index d435284e4a..417e11159b 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -36,11 +36,11 @@ import qualified Brig.AWS.SesNotification as SesNotification import Brig.App import qualified Brig.Calling as Calling import Brig.CanonicalInterpreter +-- import qualified Brig.InternalEvent.Process as Internal import Brig.Effects.UserPendingActivationStore (UserPendingActivation (UserPendingActivation), UserPendingActivationStore) import qualified Brig.Effects.UserPendingActivationStore as UsersPendingActivationStore -import qualified Brig.InternalEvent.Process as Internal import Brig.Options hiding (internalEvents, sesQueue) -import qualified Brig.Queue as Queue +-- import qualified Brig.Queue as Queue import Brig.Types.Intra (AccountStatus (PendingInvitation)) import Brig.Version import qualified Control.Concurrent.Async as Async @@ -87,11 +87,11 @@ run :: Opts -> IO () run o = do (app, e) <- mkApp o s <- Server.newSettings (server e) - internalEventListener <- - Async.async $ - runBrigToIO e $ - wrapHttpClient $ - Queue.listen (e ^. internalEvents) Internal.onEvent + -- TODO(md): Find or implement a Polysemy equivalent + internalEventListener :: Async.Async () <- undefined + -- Async.async + -- runBrigToIO e $ + -- Queue.listen (e ^. internalEvents) Internal.onEvent let throttleMillis = fromMaybe defSqsThrottleMillis $ setSqsThrottleMillis (optSettings o) emailListener <- for (e ^. awsEnv . sesQueue) $ \q -> Async.async $ diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index f00cd9ae1b..d07f5e7b6c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -31,7 +31,13 @@ import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data import Brig.Effects.BlacklistStore (BlacklistStore) import qualified Brig.Effects.BlacklistStore as BlacklistStore +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess +import Brig.Effects.Twilio (Twilio) +import Brig.Effects.UserKeyStore (UserKeyStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) +import Brig.Effects.UserQuery (UserQuery) import qualified Brig.Email as Email import qualified Brig.IO.Intra as Intra import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) @@ -48,7 +54,8 @@ import Control.Monad.Trans.Except (mapExceptT) import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.Id -import qualified Data.List1 as List1 +import Data.List.NonEmpty (nonEmpty) +import Data.Qualified import Data.Range import Data.String.Conversions (cs) import qualified Data.Swagger.Build.Api as Doc @@ -62,7 +69,10 @@ import Network.Wai.Routing import Network.Wai.Utilities hiding (code, message) import Network.Wai.Utilities.Swagger (document) import qualified Network.Wai.Utilities.Swagger as Doc -import Polysemy (Member, Members) +import Polysemy +import qualified Polysemy.Error as P +import Polysemy.Input +import qualified Ropes.Twilio as Twilio import System.Logger (Msg) import qualified System.Logger.Class as Log import Util.Logging (logFunction, logTeam) @@ -79,8 +89,19 @@ import qualified Wire.API.Team.Role as Public import qualified Wire.API.Team.Size as Public import Wire.API.User hiding (fromEmail) import qualified Wire.API.User as Public +import Wire.Sem.Concurrency -routesPublic :: Member BlacklistStore r => Routes Doc.ApiBuilder (Handler r) () +routesPublic :: + Members + '[ BlacklistStore, + Input (Local ()), + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p + ] + r => + Routes Doc.ApiBuilder (Handler r) () routesPublic = do post "/teams/:tid/invitations" (continue createInvitationPublicH) $ accept "application" "json" @@ -193,7 +214,15 @@ routesPublic = do routesInternal :: Members '[ BlacklistStore, - UserPendingActivationStore p + Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => Routes a (Handler r) () @@ -252,7 +281,18 @@ newtype FoundInvitationCode = FoundInvitationCode InvitationCode instance ToJSON FoundInvitationCode where toJSON (FoundInvitationCode c) = object ["code" .= c] -createInvitationPublicH :: Member BlacklistStore r => JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> (Handler r) Response +createInvitationPublicH :: + Members + '[ BlacklistStore, + Input (Local ()), + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p + ] + r => + JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> + Handler r Response createInvitationPublicH (_ ::: uid ::: tid ::: req) = do body <- parseJsonBody req newInv <- createInvitationPublic uid tid body @@ -268,7 +308,20 @@ data CreateInvitationInviter = CreateInvitationInviter } deriving (Eq, Show) -createInvitationPublic :: Member BlacklistStore r => UserId -> TeamId -> Public.InvitationRequest -> Handler r Public.Invitation +createInvitationPublic :: + Members + '[ BlacklistStore, + Input (Local ()), + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserQuery p + ] + r => + UserId -> + TeamId -> + Public.InvitationRequest -> + Handler r Public.Invitation createInvitationPublic uid tid body = do let inviteeRole = fromMaybe defaultRole . irRole $ body inviter <- do @@ -291,11 +344,15 @@ createInvitationPublic uid tid body = do createInvitationViaScimH :: Members '[ BlacklistStore, - UserPendingActivationStore p + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => JSON ::: JsonRequest NewUserScimInvitation -> - (Handler r) Response + Handler r Response createInvitationViaScimH (_ ::: req) = do body <- parseJsonBody req setStatus status201 . json <$> createInvitationViaScim body @@ -303,11 +360,15 @@ createInvitationViaScimH (_ ::: req) = do createInvitationViaScim :: Members '[ BlacklistStore, - UserPendingActivationStore p + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore, + UserPendingActivationStore p, + UserQuery p ] r => NewUserScimInvitation -> - (Handler r) UserAccount + Handler r UserAccount createInvitationViaScim newUser@(NewUserScimInvitation tid loc name email) = do env <- ask let inviteeRole = defaultRole @@ -345,7 +406,20 @@ logInvitationRequest context action = Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) -createInvitation' :: Member BlacklistStore r => TeamId -> Public.Role -> Maybe UserId -> Email -> Public.InvitationRequest -> Handler r (Public.Invitation, Public.InvitationCode) +createInvitation' :: + Members + '[ BlacklistStore, + P.Error Twilio.ErrorResponse, + Twilio, + UserKeyStore + ] + r => + TeamId -> + Public.Role -> + Maybe UserId -> + Email -> + Public.InvitationRequest -> + Handler r (Public.Invitation, Public.InvitationCode) createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- FUTUREWORK: These validations are nearly copy+paste from accountCreation and -- sendActivationCode. Refactor this to a single place @@ -356,18 +430,19 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do blacklistedEm <- lift $ liftSem $ BlacklistStore.exists uke when blacklistedEm $ throwStd blacklistedEmail - emailTaken <- lift $ isJust <$> wrapClient (Data.lookupKey uke) + emailTaken <- lift $ isJust <$> liftSem (Data.getKey uke) when emailTaken $ throwStd emailExists -- Validate phone inviteePhone <- for (irInviteePhone body) $ \p -> do - validatedPhone <- maybe (throwStd (errorToWai @'E.InvalidPhone)) pure =<< lift (wrapClient $ Phone.validatePhone p) + validatedPhone <- + maybe (throwStd (errorToWai @'E.InvalidPhone)) pure =<< lift (liftSem $ Phone.validatePhone p) let ukp = userPhoneKey validatedPhone blacklistedPh <- lift $ liftSem $ BlacklistStore.exists ukp when blacklistedPh $ throwStd (errorToWai @'E.BlacklistedPhone) - phoneTaken <- lift $ isJust <$> wrapClient (Data.lookupKey ukp) + phoneTaken <- lift $ isJust <$> liftSem (Data.getKey ukp) when phoneTaken $ throwStd phoneExists pure validatedPhone @@ -461,21 +536,61 @@ getInvitationByEmail email = do inv <- lift $ wrapClient $ DB.lookupInvitationByEmail HideInvitationUrl email maybe (throwStd (notFound "Invitation not found")) pure inv -suspendTeamH :: JSON ::: TeamId -> (Handler r) Response +suspendTeamH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + JSON ::: TeamId -> + Handler r Response suspendTeamH (_ ::: tid) = do empty <$ suspendTeam tid -suspendTeam :: TeamId -> (Handler r) () +suspendTeam :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + TeamId -> + Handler r () suspendTeam tid = do changeTeamAccountStatuses tid Suspended lift $ wrapClient $ DB.deleteInvitations tid lift $ wrapHttp $ Intra.changeTeamStatus tid Team.Suspended Nothing -unsuspendTeamH :: JSON ::: TeamId -> (Handler r) Response +unsuspendTeamH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + JSON ::: TeamId -> + Handler r Response unsuspendTeamH (_ ::: tid) = do empty <$ unsuspendTeam tid -unsuspendTeam :: TeamId -> (Handler r) () +unsuspendTeam :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + TeamId -> + Handler r () unsuspendTeam tid = do changeTeamAccountStatuses tid Active lift $ wrapHttp $ Intra.changeTeamStatus tid Team.Active Nothing @@ -483,13 +598,29 @@ unsuspendTeam tid = do ------------------------------------------------------------------------------- -- Internal -changeTeamAccountStatuses :: TeamId -> AccountStatus -> (Handler r) () +changeTeamAccountStatuses :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + TeamId -> + AccountStatus -> + Handler r () changeTeamAccountStatuses tid s = do team <- Team.tdTeam <$> lift (wrapHttp $ Intra.getTeam tid) unless (team ^. teamBinding == Binding) $ throwStd noBindingTeam - uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> wrapHttp (Intra.getTeamMembers tid)) - wrapHttpClientE (API.changeAccountStatus uids s) !>> accountStatusError - where - toList1 (x : xs) = pure $ List1.list1 x xs - toList1 [] = throwStd (notFound "Team not found or no members") + uids <- do + r <- + lift + ( fmap (view Teams.userId) . view teamMembers + <$> wrapHttp (Intra.getTeamMembers tid) + ) + case nonEmpty r of + Nothing -> throwStd (notFound "Team not found or no members") + Just v -> pure v + API.changeAccountStatus uids s !>> accountStatusError diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index 88e325e8c4..7482e69505 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -19,8 +19,7 @@ -- to contention, i.e. where strong guarantees on uniqueness are desired. module Brig.Unique ( withClaim, - deleteClaim, - lookupClaims, + getClaims, -- * Re-exports Timeout, @@ -30,11 +29,16 @@ module Brig.Unique where import Brig.Data.Instances () -import Cassandra as C -import Control.Concurrent.Timeout +import Brig.Effects.UniqueClaimsStore import Data.Id import Data.Timeout import Imports +import Polysemy +import Polysemy.Async +import Polysemy.Conc.Async +import Polysemy.Conc.Effect.Race +import Polysemy.Resource +import Polysemy.Time.Data.TimeUnit -- | Obtain a (temporary) exclusive claim on a 'Text' value for some -- 'Id'entifier. The claim expires after the provided timeout, whether @@ -44,7 +48,8 @@ import Imports -- and is responsible for turning the temporary claim into permanent -- ownership, if desired. withClaim :: - MonadClient m => + -- TODO(md): Replace the dependency on the Async effect as it is totally broken. + Members '[Async, Race, Resource, UniqueClaimsStore] r => -- | The 'Id' associated with the claim. Id a -> -- | The value on which to acquire the claim. @@ -52,60 +57,29 @@ withClaim :: -- | The minimum timeout (i.e. duration) of the claim. Timeout -> -- | The computation to run with a successful claim. - IO b -> - -- | 'Just b' if the claim was successful and the 'IO' - -- computation completed within the given timeout. - m (Maybe b) -withClaim u v t io = do - claims <- lookupClaims v + Sem r b -> + -- | 'Just b' if the claim was successful and the computation completed within + -- the given timeout. + Sem r (Maybe b) +withClaim u v t action = do + claims <- getClaims v + -- [Note: Guarantees] + let claim = do + let ttl = max minTtl t + addClaims u t v + if claims == [u] + then withAsyncWait (toPolyTime ttl) action await + else pure Nothing case claims of [] -> claim -- Free [u'] | u == u' -> claim -- Claimed by 'u' (retries are allowed). _ -> pure Nothing -- Conflicting claims, TTL must expire. - where - -- [Note: Guarantees] - claim = do - let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) - claimed <- (== [u]) <$> lookupClaims v - if claimed - then liftIO $ timeout (fromIntegral ttl # Second) io - else pure Nothing - cql :: PrepQuery W (Int32, C.Set (Id a), Text) () - cql = "UPDATE unique_claims USING TTL ? SET claims = claims + ? WHERE value = ?" -deleteClaim :: - MonadClient m => - -- | The 'Id' associated with the claim. - Id a -> - -- | The value on which to acquire the claim. - Text -> - -- | The minimum timeout (i.e. duration) of the rest of the claim. (Each - -- claim can have more than one claimer (even though this is a feature we - -- never use), so removing a claim is an update operation on the database. - -- Therefore, we reset the TTL the same way we reset it in 'withClaim'.) - Timeout -> - m () -deleteClaim u v t = do - let ttl = max minTtl (fromIntegral (t #> Second)) - retry x5 $ write cql $ params LocalQuorum (ttl * 2, C.Set [u], v) - where - cql :: PrepQuery W (Int32, C.Set (Id a), Text) () - cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" - --- | Lookup the current claims on a value. -lookupClaims :: MonadClient m => Text -> m [Id a] -lookupClaims v = - fmap (maybe [] (fromSet . runIdentity)) $ - retry x1 $ - query1 cql $ - params LocalQuorum (Identity v) - where - cql :: PrepQuery R (Identity Text) (Identity (C.Set (Id a))) - cql = "SELECT claims FROM unique_claims WHERE value = ?" +toPolyTime :: Timeout -> NanoSeconds +toPolyTime t = NanoSeconds . fromIntegral $ t #> NanoSecond -minTtl :: Int32 -minTtl = 60 -- Seconds +minTtl :: Timeout +minTtl = 60 # Second -- [Note: Guarantees] -- ~~~~~~~~~~~~~~~~~~ diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 2ea7a8d86f..604e1cb52a 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -21,14 +21,30 @@ module Brig.User.API.Auth ) where -import Brig.API.Error +import Brig.API.Error hiding (Error) import Brig.API.Handler import Brig.API.Types import qualified Brig.API.User as User import Brig.App +-- import Brig.Options (setDefaultUserLocale) + +import Brig.Effects.ActivationKeyStore +import Brig.Effects.ActivationSupply import Brig.Effects.BlacklistStore (BlacklistStore) +import Brig.Effects.BudgetStore +-- import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction, reAuthPassword) +-- import Control.Lens (view) + +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess (GundeckAccess) +import Brig.Effects.Twilio +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore import Brig.Phone -import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction, reAuthPassword) +import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction) import Brig.Types.User.Auth import qualified Brig.User.Auth as Auth import qualified Brig.User.Auth.Cookie as Auth @@ -43,12 +59,13 @@ import Data.Id import Data.List1 (List1) import qualified Data.List1 as List1 import Data.Predicate +import Data.Qualified import qualified Data.Swagger.Build.Api as Doc import qualified Data.ZAuth.Token as ZAuth import Imports import Network.HTTP.Types.Status import Network.Wai (Response) -import Network.Wai.Predicate +import Network.Wai.Predicate hiding (Error) import qualified Network.Wai.Predicate as P import qualified Network.Wai.Predicate.Request as R import Network.Wai.Routing @@ -58,15 +75,39 @@ import Network.Wai.Utilities.Response (empty, json) import qualified Network.Wai.Utilities.Response as WaiResp import Network.Wai.Utilities.Swagger (document) import qualified Network.Wai.Utilities.Swagger as Doc -import Polysemy (Member) +import Polysemy +import Polysemy.Error +import Polysemy.Input +import Polysemy.TinyLog (TinyLog) +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio import Wire.API.Error import qualified Wire.API.Error.Brig as E import qualified Wire.API.User as Public import Wire.API.User.Auth as Public +import Wire.Sem.Concurrency import Wire.Swagger as Doc (pendingLoginError) routesPublic :: - Member BlacklistStore r => + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + BudgetStore, + Concurrency 'Unsafe, + CookieStore, + Error Twilio.ErrorResponse, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + Twilio, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Note: this endpoint should always remain available at its unversioned @@ -197,7 +238,21 @@ routesPublic = do Doc.body (Doc.ref Public.modelRemoveCookies) Doc.end Doc.errorResponse (errorToWai @'E.BadCredentials) -routesInternal :: Routes a (Handler r) () +routesInternal :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + Error ReAuthError, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + Routes a (Handler r) () routesInternal = do -- galley can query this endpoint at the right moment in the LegalHold flow post "/i/legalhold-login" (continue legalHoldLoginH) $ @@ -219,73 +274,207 @@ routesInternal = do -- Handlers -sendLoginCodeH :: JsonRequest Public.SendLoginCode -> (Handler r) Response +sendLoginCodeH :: + Members + '[ Error Twilio.ErrorResponse, + P.TinyLog, + UserKeyStore, + UserQuery p, + Twilio + ] + r => + JsonRequest Public.SendLoginCode -> + Handler r Response sendLoginCodeH req = do json <$> (sendLoginCode =<< parseJsonBody req) -sendLoginCode :: Public.SendLoginCode -> (Handler r) Public.LoginCodeTimeout +sendLoginCode :: + Members + '[ Error Twilio.ErrorResponse, + P.TinyLog, + UserKeyStore, + UserQuery p, + Twilio + ] + r => + Public.SendLoginCode -> + Handler r Public.LoginCodeTimeout sendLoginCode (Public.SendLoginCode phone call force) = do checkWhitelist (Right phone) - c <- wrapClientE (Auth.sendLoginCode phone call force) !>> sendLoginCodeError + c <- Auth.sendLoginCode phone call force !>> sendLoginCodeError pure $ Public.LoginCodeTimeout (pendingLoginTimeout c) -getLoginCodeH :: JSON ::: Phone -> (Handler r) Response +getLoginCodeH :: + Members '[P.TinyLog, UserKeyStore] r => + JSON ::: Phone -> + Handler r Response getLoginCodeH (_ ::: phone) = json <$> getLoginCode phone -getLoginCode :: Phone -> (Handler r) Public.PendingLoginCode +getLoginCode :: + Members '[P.TinyLog, UserKeyStore] r => + Phone -> + Handler r Public.PendingLoginCode getLoginCode phone = do - code <- lift $ wrapClient $ Auth.lookupLoginCode phone + code <- lift $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) pure code -reAuthUserH :: UserId ::: JsonRequest ReAuthUser -> (Handler r) Response +reAuthUserH :: + Members + '[ Error ReAuthError, + GalleyAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + UserId ::: JsonRequest ReAuthUser -> + (Handler r) Response reAuthUserH (uid ::: req) = do reAuthUser uid =<< parseJsonBody req pure empty -reAuthUser :: UserId -> ReAuthUser -> (Handler r) () +reAuthUser :: + Members + '[ Error ReAuthError, + GalleyAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => + UserId -> + ReAuthUser -> + (Handler r) () reAuthUser uid body = do - wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError + -- locale <- setDefaultUserLocale <$> view settings + -- lift (liftSem (User.reauthenticate locale uid (reAuthPassword body))) !>> reauthError case reAuthCodeAction body of Just action -> - wrapHttpClientE (Auth.verifyCode (reAuthCode body) action uid) + Auth.verifyCode (reAuthCode body) action uid `catchE` \case VerificationCodeRequired -> throwE $ reauthError ReAuthCodeVerificationRequired VerificationCodeNoPendingCode -> throwE $ reauthError ReAuthCodeVerificationNoPendingCode VerificationCodeNoEmail -> throwE $ reauthError ReAuthCodeVerificationNoEmail Nothing -> pure () -loginH :: JsonRequest Public.Login ::: Bool ::: JSON -> (Handler r) Response +loginH :: + Members + '[ BudgetStore, + Concurrency 'Unsafe, + CookieStore, + Error Twilio.ErrorResponse, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + Twilio, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + JsonRequest Public.Login ::: Bool ::: JSON -> + Handler r Response loginH (req ::: persist ::: _) = do lift . tokenResponse =<< flip login persist =<< parseJsonBody req -login :: Public.Login -> Bool -> (Handler r) (Auth.Access ZAuth.User) +login :: + Members + '[ BudgetStore, + Concurrency 'Unsafe, + CookieStore, + Error Twilio.ErrorResponse, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + Twilio, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => + Public.Login -> + Bool -> + Handler r (Auth.Access ZAuth.User) login l persist = do let typ = if persist then PersistentCookie else SessionCookie - wrapHttpClientE (Auth.login l typ) !>> loginError - -ssoLoginH :: JsonRequest SsoLogin ::: Bool ::: JSON -> (Handler r) Response + Auth.login l typ !>> loginError + +ssoLoginH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + JsonRequest SsoLogin ::: Bool ::: JSON -> + Handler r Response ssoLoginH (req ::: persist ::: _) = do lift . tokenResponse =<< flip ssoLogin persist =<< parseJsonBody req -ssoLogin :: SsoLogin -> Bool -> (Handler r) (Auth.Access ZAuth.User) +ssoLogin :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + SsoLogin -> + Bool -> + Handler r (Auth.Access ZAuth.User) ssoLogin l persist = do let typ = if persist then PersistentCookie else SessionCookie - wrapHttpClientE (Auth.ssoLogin l typ) !>> loginError - -legalHoldLoginH :: JsonRequest LegalHoldLogin ::: JSON -> (Handler r) Response + Auth.ssoLogin l typ !>> loginError + +legalHoldLoginH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + JsonRequest LegalHoldLogin ::: JSON -> + Handler r Response legalHoldLoginH (req ::: _) = do lift . tokenResponse =<< legalHoldLogin =<< parseJsonBody req -legalHoldLogin :: LegalHoldLogin -> (Handler r) (Auth.Access ZAuth.LegalHoldUser) +legalHoldLogin :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => + LegalHoldLogin -> + Handler r (Auth.Access ZAuth.LegalHoldUser) legalHoldLogin l = do let typ = PersistentCookie -- Session cookie isn't a supported use case here - wrapHttpClientE (Auth.legalHoldLogin l typ) !>> legalHoldLoginError + Auth.legalHoldLogin l typ !>> legalHoldLoginError -logoutH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> (Handler r) Response +logoutH :: + Member CookieStore r => + JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> + Handler r Response logoutH (_ ::: ut ::: at) = empty <$ logout ut at -- TODO: add legalhold test checking cookies are revoked (/access/logout is called) when legalhold device is deleted. logout :: + Member CookieStore r => Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> (Handler r) () @@ -294,16 +483,23 @@ logout Nothing (Just _) = throwStd authMissingCookie logout (Just _) Nothing = throwStd authMissingToken logout (Just (Left _)) (Just (Right _)) = throwStd authTokenMismatch logout (Just (Right _)) (Just (Left _)) = throwStd authTokenMismatch -logout (Just (Left ut)) (Just (Left at)) = wrapHttpClientE (Auth.logout ut at) !>> zauthError -logout (Just (Right ut)) (Just (Right at)) = wrapHttpClientE (Auth.logout ut at) !>> zauthError +logout (Just (Left ut)) (Just (Left at)) = Auth.logout ut at !>> zauthError +logout (Just (Right ut)) (Just (Right at)) = Auth.logout ut at !>> zauthError changeSelfEmailH :: - Member BlacklistStore r => + Members + '[ ActivationKeyStore, + ActivationSupply, + BlacklistStore, + UserKeyStore, + UserQuery p + ] + r => JSON ::: JsonRequest Public.EmailUpdate ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - (Handler r) Response + Handler r Response changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do usr <- validateCredentials ckies toks email <- Public.euEmail <$> parseJsonBody req @@ -314,7 +510,7 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do validateCredentials :: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - (Handler r) UserId + Handler r UserId validateCredentials = \case Nothing -> const $ throwStd authMissingCookie @@ -329,22 +525,58 @@ changeSelfEmailH (_ ::: req ::: ckies ::: toks) = do Just (Left userTokens) -> fst <$> wrapHttpClientE (Auth.validateTokens userCookies (Just userTokens)) !>> zauthError -listCookiesH :: UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> (Handler r) Response -listCookiesH (u ::: ll ::: _) = json <$> lift (listCookies u ll) - -listCookies :: UserId -> Maybe (List Public.CookieLabel) -> (AppT r) Public.CookieList +listCookiesH :: + Member CookieStore r => + UserId ::: Maybe (List Public.CookieLabel) ::: JSON -> + Handler r Response +listCookiesH (u ::: ll ::: _) = json <$> (lift . liftSem $ listCookies u ll) + +listCookies :: + Member CookieStore r => + UserId -> + Maybe (List Public.CookieLabel) -> + Sem r Public.CookieList listCookies u ll = do - Public.CookieList <$> wrapClient (Auth.listCookies u (maybe [] fromList ll)) - -rmCookiesH :: UserId ::: JsonRequest Public.RemoveCookies -> (Handler r) Response + Public.CookieList <$> Auth.listCookies u (maybe [] fromList ll) + +rmCookiesH :: + Members + '[ CookieStore, + Input (Local ()), + TinyLog, + UserQuery p + ] + r => + UserId ::: JsonRequest Public.RemoveCookies -> + Handler r Response rmCookiesH (uid ::: req) = do empty <$ (rmCookies uid =<< parseJsonBody req) -rmCookies :: UserId -> Public.RemoveCookies -> (Handler r) () +rmCookies :: + Members + '[ CookieStore, + Input (Local ()), + TinyLog, + UserQuery p + ] + r => + UserId -> + Public.RemoveCookies -> + Handler r () rmCookies uid (Public.RemoveCookies pw lls ids) = - wrapClientE (Auth.revokeAccess uid pw ids lls) !>> authError - -renewH :: JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> (Handler r) Response + Auth.revokeAccess uid pw ids lls !>> authError + +renewH :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => + JSON ::: Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) ::: Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> + Handler r Response renewH (_ ::: ut ::: at) = lift . either tokenResponse tokenResponse =<< renew ut at -- | renew access for either: @@ -353,18 +585,26 @@ renewH (_ ::: ut ::: at) = lift . either tokenResponse tokenResponse =<< renew u -- -- Other combinations of provided inputs will cause an error to be raised. renew :: + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => Maybe (Either (List1 ZAuth.UserToken) (List1 ZAuth.LegalHoldUserToken)) -> Maybe (Either ZAuth.AccessToken ZAuth.LegalHoldAccessToken) -> - (Handler r) (Either (Auth.Access ZAuth.User) (Auth.Access ZAuth.LegalHoldUser)) + Handler r (Either (Auth.Access ZAuth.User) (Auth.Access ZAuth.LegalHoldUser)) renew = \case Nothing -> const $ throwStd authMissingCookie (Just (Left userTokens)) -> -- normal UserToken, so we want a normal AccessToken - fmap Left . wrapHttpClientE . renewAccess userTokens <=< matchingOrNone leftToMaybe + fmap Left . renewAccess userTokens <=< matchingOrNone leftToMaybe (Just (Right legalholdUserTokens)) -> -- LegalholdUserToken, so we want a LegalholdAccessToken - fmap Right . wrapHttpClientE . renewAccess legalholdUserTokens <=< matchingOrNone rightToMaybe + fmap Right . renewAccess legalholdUserTokens <=< matchingOrNone rightToMaybe where renewAccess uts mat = Auth.renewAccess uts mat !>> zauthError diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index db71c04406..8bfa1cfe6f 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -28,6 +28,8 @@ import Brig.API.Handler (Handler) import qualified Brig.API.User as API import Brig.App import qualified Brig.Data.User as Data +import Brig.Effects.UserHandleStore +import Brig.Effects.UserQuery import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) import Control.Lens (view) @@ -36,13 +38,24 @@ import Data.Id (UserId) import Data.Qualified import Imports import Network.Wai.Utilities ((!>>)) +import Polysemy +import Polysemy.Input import qualified System.Logger.Class as Log import Wire.API.User import qualified Wire.API.User as Public import Wire.API.User.Search import qualified Wire.API.User.Search as Public -getHandleInfo :: UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) +getHandleInfo :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Qualified Handle -> + Handler r (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -58,15 +71,24 @@ getRemoteHandleInfo handle = do . Log.field "domain" (show (tDomain handle)) Federation.getUserHandleInfo handle !>> fedError -getLocalHandleInfo :: Local UserId -> Handle -> (Handler r) (Maybe Public.UserProfile) +getLocalHandleInfo :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + Local UserId -> + Handle -> + Handler r (Maybe Public.UserProfile) getLocalHandleInfo self handle = do lift . Log.info $ Log.msg $ Log.val "getHandleInfo - local lookup" - maybeOwnerId <- lift . wrapClient $ API.lookupHandle handle + maybeOwnerId <- lift . liftSem $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing Just ownerId -> do domain <- viewFederationDomain - ownerProfile <- wrapHttpClientE (API.lookupProfile self (Qualified ownerId domain)) !>> fedError + ownerProfile <- API.lookupProfile self (Qualified ownerId domain) !>> fedError owner <- filterHandleResults self (maybeToList ownerProfile) pure $ listToMaybe owner diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index c303d36ac4..964da9b285 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -26,6 +26,8 @@ import Brig.API.Error (fedError) import Brig.API.Handler import Brig.App import qualified Brig.Data.User as DB +import Brig.Effects.UserHandleStore +import Brig.Effects.UserQuery import qualified Brig.Federation.Client as Federation import qualified Brig.IO.Intra as Intra import qualified Brig.Options as Opts @@ -40,11 +42,14 @@ import Data.Domain (Domain) import Data.Handle (parseHandle) import Data.Id import Data.Predicate +import Data.Qualified import Data.Range import Imports import Network.Wai.Routing import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Response (empty) +import Polysemy +import Polysemy.Input import System.Logger (field, msg) import System.Logger.Class (val, (~~)) import qualified System.Logger.Class as Log @@ -82,7 +87,18 @@ routesInternal = do -- FUTUREWORK: Consider augmenting 'SearchResult' with full user profiles -- for all results. This is tracked in https://wearezeta.atlassian.net/browse/SQCORE-599 -search :: UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) +search :: + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Text -> + Maybe Domain -> + Maybe (Range 1 500 Int32) -> + Handler r (Public.SearchResult Public.Contact) search searcherId searchTerm maybeDomain maybeMaxResults = do federationDomain <- viewFederationDomain let queryDomain = fromMaybe federationDomain maybeDomain @@ -108,7 +124,18 @@ searchRemotely domain searchTerm = do searchPolicy = S.searchPolicy searchResponse } -searchLocally :: UserId -> Text -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) +searchLocally :: + forall r p. + Members + '[ Input (Local ()), + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Text -> + Maybe (Range 1 500 Int32) -> + Handler r (Public.SearchResult Public.Contact) searchLocally searcherId searchTerm maybeMaxResults = do let maxResults = maybe 15 (fromIntegral . fromRange) maybeMaxResults searcherTeamId <- lift $ wrapClient $ DB.lookupUserTeam searcherId @@ -149,7 +176,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do -- For team users, we need to check the visibility flag handleTeamVisibility t <$> wrapHttp (Intra.getTeamSearchVisibility t) - exactHandleSearch :: (Handler r) (Maybe Contact) + exactHandleSearch :: Handler r (Maybe Contact) exactHandleSearch = do lsearcherId <- qualifyLocal searcherId case parseHandle searchTerm of diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 712da1d6b0..efcfc19c95 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -36,49 +36,64 @@ module Brig.User.Auth ) where -import Bilge.IO -import Bilge.RPC import Brig.API.Types import Brig.API.User (changeSingleAccountStatus) import Brig.App -import Brig.Budget import qualified Brig.Code as Code import qualified Brig.Data.Activation as Data import qualified Brig.Data.LoginCode as Data import qualified Brig.Data.User as Data import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data +import Brig.Effects.BudgetStore +import Brig.Effects.Common +import Brig.Effects.CookieStore +import Brig.Effects.GalleyAccess +import Brig.Effects.GundeckAccess +import Brig.Effects.Twilio (Twilio) +import Brig.Effects.UserHandleStore +import Brig.Effects.UserKeyStore (UserKeyStore) +import Brig.Effects.UserQuery (UserQuery) +import Brig.Effects.VerificationCodeStore (VerificationCodeStore) import Brig.Email import qualified Brig.IO.Intra as Intra import qualified Brig.Options as Opt import Brig.Phone +import Brig.Types.Common import Brig.Types.Intra import Brig.Types.User.Auth import Brig.User.Auth.Cookie -import Brig.User.Handle import Brig.User.Phone -import Brig.User.Search.Index import qualified Brig.ZAuth as ZAuth import Cassandra import Control.Error hiding (bool) import Control.Lens (to, view) -import Control.Monad.Catch import Data.ByteString.Conversion (toByteString) +import Data.Either.Combinators import Data.Handle (Handle) import Data.Id import qualified Data.List.NonEmpty as NE import Data.List1 (List1) import qualified Data.List1 as List1 import Data.Misc (PlainTextPassword (..)) +import Data.Qualified import qualified Data.ZAuth.Token as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) +import Polysemy +import Polysemy.Error +import qualified Polysemy.Error as P +import Polysemy.Input +import Polysemy.TinyLog +import qualified Polysemy.TinyLog as P +import qualified Ropes.Twilio as Twilio import System.Logger (field, msg, val, (~~)) import qualified System.Logger.Class as Log import Wire.API.Team.Feature import qualified Wire.API.Team.Feature as Public import Wire.API.User import Wire.API.User.Auth +import Wire.Sem.Concurrency data Access u = Access { accessToken :: !AccessToken, @@ -86,191 +101,236 @@ data Access u = Access } sendLoginCode :: - ( MonadClient m, - MonadReader Env m, - MonadCatch m, - Log.MonadLogger m - ) => + forall r p. + Members + '[ Error Twilio.ErrorResponse, + P.TinyLog, + Twilio, + UserKeyStore, + UserQuery p + ] + r => Phone -> Bool -> Bool -> - ExceptT SendLoginCodeError m PendingLoginCode + ExceptT SendLoginCodeError (AppT r) PendingLoginCode sendLoginCode phone call force = do pk <- maybe (throwE $ SendLoginInvalidPhone phone) (pure . userPhoneKey) - =<< lift (validatePhone phone) - user <- lift $ Data.lookupKey pk + =<< lift (liftSem $ validatePhone phone) + user <- lift . liftSem $ Data.getKey pk case user of Nothing -> throwE $ SendLoginInvalidPhone phone Just u -> do - lift . Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.sendLoginCode") - pw <- lift $ Data.lookupPassword u + lift . liftSem + . P.debug + $ field "user" (toByteString u) . field "action" (Log.val "User.sendLoginCode") + pw <- lift . wrapClient $ Data.lookupPassword u unless (isNothing pw || force) $ throwE SendLoginPasswordExists lift $ do - l <- Data.lookupLocale u - c <- Data.createLoginCode u + defLoc <- Opt.setDefaultUserLocale <$> view settings + l <- liftSem $ Data.lookupLocale defLoc u + c <- wrapClient $ Data.createLoginCode u void . forPhoneKey pk $ \ph -> - if call - then sendLoginCall ph (pendingLoginCode c) l - else sendLoginSms ph (pendingLoginCode c) l + wrapClient $ + if call + then sendLoginCall ph (pendingLoginCode c) l + else sendLoginSms ph (pendingLoginCode c) l pure c lookupLoginCode :: - ( MonadClient m, - Log.MonadLogger m, - MonadReader Env m - ) => + Members + '[ P.TinyLog, + UserKeyStore + ] + r => Phone -> - m (Maybe PendingLoginCode) + AppT r (Maybe PendingLoginCode) lookupLoginCode phone = - Data.lookupKey (userPhoneKey phone) >>= \case + liftSem (Data.getKey (userPhoneKey phone)) >>= \case Nothing -> pure Nothing Just u -> do - Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") - Data.lookupLoginCode u + liftSem $ P.debug $ field "user" (toByteString u) . field "action" (Log.val "User.lookupLoginCode") + wrapClient $ Data.lookupLoginCode u login :: - forall m. - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - Log.MonadLogger m, - MonadClient m, - ZAuth.MonadZAuth m, - MonadIndexIO m, - MonadUnliftIO m - ) => + forall r p. + Members + '[ BudgetStore, + Concurrency 'Unsafe, + CookieStore, + Error Twilio.ErrorResponse, + GalleyAccess, + GundeckAccess, + Input (Local ()), + P.TinyLog, + Twilio, + UserHandleStore, + UserKeyStore, + UserQuery p, + VerificationCodeStore + ] + r => Login -> CookieType -> - ExceptT LoginError m (Access ZAuth.User) + ExceptT LoginError (AppT r) (Access ZAuth.User) login (PasswordLogin li pw label code) typ = do uid <- resolveLoginId li - lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") - checkRetryLimit uid - Data.authenticate uid pw `catchE` \case - AuthInvalidUser -> loginFailed uid - AuthInvalidCredentials -> loginFailed uid + lift . liftSem . P.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") + mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) + liftSemE . semErrToExceptT $ checkRetryLimit uid mLimitFailedLogins + o <- lift . liftSem . runError @AuthError $ Data.authenticate uid pw + whenLeft o $ \case + AuthInvalidUser -> liftSemE . semErrToExceptT $ loginFailed uid mLimitFailedLogins + AuthInvalidCredentials -> liftSemE . semErrToExceptT $ loginFailed uid mLimitFailedLogins AuthSuspended -> throwE LoginSuspended AuthEphemeral -> throwE LoginEphemeral AuthPendingInvitation -> throwE LoginPendingActivation - verifyLoginCode code uid + verifyLoginCode code uid mLimitFailedLogins newAccess @ZAuth.User @ZAuth.Access uid typ label where - verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError m () - verifyLoginCode mbCode uid = + verifyLoginCode :: + Maybe Code.Value -> + UserId -> + Maybe Opt.LimitFailedLogins -> + ExceptT LoginError (AppT r) () + verifyLoginCode mbCode uid mLimitFailedLogins = verifyCode mbCode Login uid `catchE` \case - VerificationCodeNoPendingCode -> loginFailedWith LoginCodeInvalid uid - VerificationCodeRequired -> loginFailedWith LoginCodeRequired uid - VerificationCodeNoEmail -> loginFailed uid + VerificationCodeNoPendingCode -> liftSemE . semErrToExceptT $ loginFailedWith LoginCodeInvalid uid mLimitFailedLogins + VerificationCodeRequired -> liftSemE . semErrToExceptT $ loginFailedWith LoginCodeRequired uid mLimitFailedLogins + VerificationCodeNoEmail -> liftSemE . semErrToExceptT $ loginFailed uid mLimitFailedLogins login (SmsLogin phone code label) typ = do uid <- resolveLoginId (LoginByPhone phone) lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") - checkRetryLimit uid - ok <- lift $ Data.verifyLoginCode uid code - unless ok $ - loginFailed uid + mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) + e <- lift . liftSem . runError $ checkRetryLimit uid mLimitFailedLogins + whenLeft e throwE + ok <- lift . wrapClient $ Data.verifyLoginCode uid code + unless ok $ do + r <- lift . liftSem . runError $ loginFailed uid mLimitFailedLogins + whenLeft r throwE newAccess @ZAuth.User @ZAuth.Access uid typ label verifyCode :: - forall m. - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - Log.MonadLogger m, - MonadClient m - ) => + forall r p. + Members + '[ GalleyAccess, + Input (Local ()), + UserQuery p, + VerificationCodeStore + ] + r => Maybe Code.Value -> VerificationAction -> UserId -> - ExceptT VerificationCodeError m () + ExceptT VerificationCodeError (AppT r) () verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do - mbFeatureEnabled <- Intra.getVerificationCodeEnabled `traverse` mbTeamId + mbFeatureEnabled <- wrapHttpClient $ Intra.getVerificationCodeEnabled `traverse` mbTeamId + -- pure $ + -- maybe + -- (Public.tfwoapsStatus (Public.defTeamFeatureStatus @'Public.TeamFeatureSndFactorPasswordChallenge) == Public.TeamFeatureEnabled) + -- (== TeamFeatureEnabled) + -- mbFeatureEnabled pure $ fromMaybe (Public.wsStatus (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled - isSsoUser <- Data.isSamlUser uid + locale <- Opt.setDefaultUserLocale <$> view settings + isSsoUser <- lift . liftSem $ Data.isSamlUser locale uid when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do key <- Code.mkKey $ Code.ForEmail email - codeValid <- isJust <$> Code.verify key (Code.scopeFromAction action) code + codeValid <- lift . liftSem $ isJust <$> Code.verifyCode key (Code.scopeFromAction action) code unless codeValid $ throwE VerificationCodeNoPendingCode (Nothing, _) -> throwE VerificationCodeRequired (_, Nothing) -> throwE VerificationCodeNoEmail where getEmailAndTeamId :: UserId -> - ExceptT e m (Maybe Email, Maybe TeamId) + ExceptT e (AppT r) (Maybe Email, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- Data.lookupAccount u + locale <- Opt.setDefaultUserLocale <$> view settings + mbAccount <- lift . liftSem $ Data.lookupAccount locale u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) -loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () -loginFailedWith e uid = decrRetryLimit uid >> throwE e +loginFailedWith :: + Member BudgetStore r => + LoginError -> + UserId -> + Maybe Opt.LimitFailedLogins -> + Sem (Error LoginError ': r) () +loginFailedWith e uid mLimitFailedLogins = + decrRetryLimit uid mLimitFailedLogins >> throw e -loginFailed :: (MonadClient m, MonadReader Env m) => UserId -> ExceptT LoginError m () +loginFailed :: + Member BudgetStore r => + UserId -> + Maybe Opt.LimitFailedLogins -> + Sem (Error LoginError ': r) () loginFailed = loginFailedWith LoginFailed -decrRetryLimit :: (MonadClient m, MonadReader Env m) => UserId -> ExceptT LoginError m () +decrRetryLimit :: + Member BudgetStore r => + UserId -> + Maybe Opt.LimitFailedLogins -> + Sem (Error LoginError ': r) () decrRetryLimit = withRetryLimit (\k b -> withBudget k b $ pure ()) -checkRetryLimit :: (MonadClient m, MonadReader Env m) => UserId -> ExceptT LoginError m () +checkRetryLimit :: + Member BudgetStore r => + UserId -> + Maybe Opt.LimitFailedLogins -> + Sem (Error LoginError ': r) () checkRetryLimit = withRetryLimit checkBudget withRetryLimit :: - (MonadClient m, MonadReader Env m) => - (BudgetKey -> Budget -> ExceptT LoginError m (Budgeted ())) -> + Member BudgetStore r => + (BudgetKey -> Budget -> Sem r (Budgeted ())) -> UserId -> - ExceptT LoginError m () -withRetryLimit action uid = do - mLimitFailedLogins <- view (settings . to Opt.setLimitFailedLogins) + Maybe Opt.LimitFailedLogins -> + Sem (Error LoginError ': r) () +withRetryLimit action uid mLimitFailedLogins = do forM_ mLimitFailedLogins $ \opts -> do let bkey = BudgetKey ("login#" <> idToText uid) budget = Budget (Opt.timeoutDiff $ Opt.timeout opts) (fromIntegral $ Opt.retryLimit opts) - bresult <- action bkey budget - case bresult of - BudgetExhausted ttl -> throwE . LoginBlocked . RetryAfter . floor $ ttl + raise @(Error LoginError) (action bkey budget) >>= \case + BudgetExhausted ttl -> throw . LoginBlocked . RetryAfter . floor $ ttl BudgetedValue () _ -> pure () logout :: ( ZAuth.TokenPair u a, - ZAuth.MonadZAuth m, - MonadClient m + Member CookieStore r ) => List1 (ZAuth.Token u) -> ZAuth.Token a -> - ExceptT ZAuth.Failure m () + ExceptT ZAuth.Failure (AppT r) () logout uts at = do - (u, ck) <- validateTokens uts (Just at) - lift $ revokeCookies u [cookieId ck] [] + (u, ck) <- mapExceptT wrapHttpClient $ validateTokens uts (Just at) + lift . liftSem $ revokeCookies u [cookieId ck] [] renewAccess :: - forall m u a. - ( ZAuth.TokenPair u a, - MonadClient m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadReader Env m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + forall u a r p. + ZAuth.TokenPair u a => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => List1 (ZAuth.Token u) -> Maybe (ZAuth.Token a) -> - ExceptT ZAuth.Failure m (Access u) + ExceptT ZAuth.Failure (AppT r) (Access u) renewAccess uts at = do - (uid, ck) <- validateTokens uts at + (uid, ck) <- wrapHttpClientE $ validateTokens uts at lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.renewAccess") catchSuspendInactiveUser uid ZAuth.Expired ck' <- lift $ nextCookie ck @@ -278,33 +338,43 @@ renewAccess uts at = do pure $ Access at' ck' revokeAccess :: - (MonadClient m, Log.MonadLogger m, MonadReader Env m) => + Members + '[ CookieStore, + Input (Local ()), + TinyLog, + UserQuery p + ] + r => UserId -> PlainTextPassword -> [CookieId] -> [CookieLabel] -> - ExceptT AuthError m () + ExceptT AuthError (AppT r) () revokeAccess u pw cc ll = do - lift $ Log.debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") - unlessM (Data.isSamlUser u) $ Data.authenticate u pw - lift $ revokeCookies u cc ll + lift . liftSem $ + debug $ field "user" (toByteString u) . field "action" (Log.val "User.revokeAccess") + locale <- Opt.setDefaultUserLocale <$> view settings + unlessM (lift . liftSem $ Data.isSamlUser locale u) + . mapExceptT liftSem + . semErrToExceptT + $ Data.authenticate u pw + lift . liftSem $ revokeCookies u cc ll -------------------------------------------------------------------------------- -- Internal catchSuspendInactiveUser :: - ( MonadClient m, - MonadIndexIO m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m, - Log.MonadLogger m - ) => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => UserId -> e -> - ExceptT e m () + ExceptT e (AppT r) () catchSuspendInactiveUser uid errval = do mustsuspend <- lift $ mustSuspendInactiveUser uid when mustsuspend $ do @@ -322,22 +392,20 @@ catchSuspendInactiveUser uid errval = do Right () -> pure () newAccess :: - forall u a m. - ( ZAuth.TokenPair u a, - MonadReader Env m, - MonadClient m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + forall u a r p. + ZAuth.TokenPair u a => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + UserQuery p + ] + r => UserId -> CookieType -> Maybe CookieLabel -> - ExceptT LoginError m (Access u) + ExceptT LoginError (AppT r) (Access u) newAccess uid ct cl = do catchSuspendInactiveUser uid LoginSuspended r <- lift $ newCookieLimited uid ct cl @@ -347,9 +415,25 @@ newAccess uid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing pure $ Access t (Just ck) -resolveLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m UserId +resolveLoginId :: + Members + '[ Input (Local ()), + P.Error Twilio.ErrorResponse, + UserHandleStore, + UserKeyStore, + UserQuery p, + Twilio + ] + r => + LoginId -> + ExceptT LoginError (AppT r) UserId resolveLoginId li = do - usr <- validateLoginId li >>= lift . either lookupKey lookupHandle + usr <- + liftSemE (validateLoginId li) + >>= lift + . either + (liftSem . getKey) + (liftSem . lookupHandle) case usr of Nothing -> do pending <- lift $ isPendingActivation li @@ -359,7 +443,10 @@ resolveLoginId li = do else LoginFailed Just uid -> pure uid -validateLoginId :: (MonadClient m, MonadReader Env m) => LoginId -> ExceptT LoginError m (Either UserKey Handle) +validateLoginId :: + Members '[P.Error Twilio.ErrorResponse, Twilio] r => + LoginId -> + ExceptT LoginError (Sem r) (Either UserKey Handle) validateLoginId (LoginByEmail email) = either (const $ throwE LoginFailed) @@ -373,17 +460,24 @@ validateLoginId (LoginByPhone phone) = validateLoginId (LoginByHandle h) = pure (Right h) -isPendingActivation :: (MonadClient m, MonadReader Env m) => LoginId -> m Bool +isPendingActivation :: + forall r p. + Members '[Input (Local ()), UserQuery p] r => + LoginId -> + AppT r Bool isPendingActivation ident = case ident of (LoginByHandle _) -> pure False (LoginByEmail e) -> checkKey (userEmailKey e) (LoginByPhone p) -> checkKey (userPhoneKey p) where checkKey k = do - usr <- (>>= fst) <$> Data.lookupActivationCode k + usr <- (>>= fst) <$> wrapClient (Data.lookupActivationCode k) + locale <- Opt.setDefaultUserLocale <$> view settings case usr of Nothing -> pure False - Just u -> maybe False (checkAccount k) <$> Data.lookupAccount u + Just u -> + maybe False (checkAccount k) + <$> liftSem (Data.lookupAccount locale u) checkAccount k a = let i = userIdentity (accountUser a) statusAdmitsPending = case accountStatus a of @@ -444,73 +538,71 @@ validateToken ut at = do -- | Allow to login as any user without having the credentials. ssoLogin :: - ( MonadClient m, - MonadReader Env m, - ZAuth.MonadZAuth m, - Log.MonadLogger m, - MonadIndexIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadUnliftIO m - ) => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => SsoLogin -> CookieType -> - ExceptT LoginError m (Access ZAuth.User) + ExceptT LoginError (AppT r) (Access ZAuth.User) ssoLogin (SsoLogin uid label) typ = do - Data.reauthenticate uid Nothing `catchE` \case - ReAuthMissingPassword -> pure () - ReAuthCodeVerificationRequired -> pure () - ReAuthCodeVerificationNoPendingCode -> pure () - ReAuthCodeVerificationNoEmail -> pure () - ReAuthError e -> case e of - AuthInvalidUser -> throwE LoginFailed - AuthInvalidCredentials -> pure () - AuthSuspended -> throwE LoginSuspended - AuthEphemeral -> throwE LoginEphemeral - AuthPendingInvitation -> throwE LoginPendingActivation + locale <- Opt.setDefaultUserLocale <$> view settings + lift + ( liftSem (runError @ReAuthError (Data.reauthenticate locale uid Nothing)) + ) + >>= \case + Right _ -> pure () + Left ReAuthMissingPassword -> pure () + Left ReAuthCodeVerificationRequired -> pure () + Left ReAuthCodeVerificationNoPendingCode -> pure () + Left ReAuthCodeVerificationNoEmail -> pure () + Left (ReAuthError e) -> case e of + AuthInvalidUser -> throwE LoginFailed + AuthInvalidCredentials -> pure () + AuthSuspended -> throwE LoginSuspended + AuthEphemeral -> throwE LoginEphemeral + AuthPendingInvitation -> throwE LoginPendingActivation newAccess @ZAuth.User @ZAuth.Access uid typ label -- | Log in as a LegalHold service, getting LegalHoldUser/Access Tokens. legalHoldLogin :: - ( MonadClient m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - Log.MonadLogger m, - ZAuth.MonadZAuth m, - MonadIndexIO m, - MonadUnliftIO m - ) => + Members + '[ Concurrency 'Unsafe, + CookieStore, + GalleyAccess, + GundeckAccess, + Input (Local ()), + UserQuery p + ] + r => LegalHoldLogin -> CookieType -> - ExceptT LegalHoldLoginError m (Access ZAuth.LegalHoldUser) + ExceptT LegalHoldLoginError (AppT r) (Access ZAuth.LegalHoldUser) legalHoldLogin (LegalHoldLogin uid plainTextPassword label) typ = do - Data.reauthenticate uid plainTextPassword !>> LegalHoldReAuthError + locale <- Opt.setDefaultUserLocale <$> view settings + mapExceptT liftSem . semErrToExceptT . mapError LegalHoldReAuthError $ + Data.reauthenticate locale uid plainTextPassword -- legalhold login is only possible if -- the user is a team user -- and the team has legalhold enabled - mteam <- lift $ Intra.getTeamId uid + mteam <- lift . liftSem $ getTeamId uid case mteam of Nothing -> throwE LegalHoldLoginNoBindingTeam - Just tid -> assertLegalHoldEnabled tid + Just tid -> mapExceptT liftSem . semErrToExceptT $ assertLegalHoldEnabled tid -- create access token and cookie newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid typ label !>> LegalHoldLoginError assertLegalHoldEnabled :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - Log.MonadLogger m - ) => + Members '[Error LegalHoldLoginError, GalleyAccess] r => TeamId -> - ExceptT LegalHoldLoginError m () -assertLegalHoldEnabled tid = do - stat <- lift $ Intra.getTeamLegalHoldStatus tid - case wsStatus stat of - FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled + Sem r () +assertLegalHoldEnabled tid = + wsStatus <$> getTeamLegalHoldStatus tid >>= \case + FeatureStatusDisabled -> throw LegalHoldLoginLegalHoldNotEnabled FeatureStatusEnabled -> pure () diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 05f24ff8c7..564d3d4d97 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -42,6 +42,8 @@ module Brig.User.Auth.Cookie where import Brig.App +import Brig.Effects.CookieStore (CookieStore) +import qualified Brig.Effects.CookieStore as E import Brig.Options hiding (user) import Brig.User.Auth.Cookie.Limit import qualified Brig.User.Auth.DB.Cookie as DB @@ -58,6 +60,7 @@ import Data.Time.Clock import Imports import Network.Wai (Response) import Network.Wai.Utilities.Response (addHeader) +import Polysemy import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log import qualified Web.Cookie as WebCookie @@ -99,13 +102,10 @@ newCookie uid typ label = do -- exceeds the configured minimum threshold. nextCookie :: ( ZAuth.UserTokenLike u, - MonadReader Env m, - Log.MonadLogger m, - ZAuth.MonadZAuth m, - MonadClient m + Member CookieStore r ) => Cookie (ZAuth.Token u) -> - m (Maybe (Cookie (ZAuth.Token u))) + AppT r (Maybe (Cookie (ZAuth.Token u))) nextCookie c = do s <- view settings now <- liftIO =<< view currentTime @@ -119,13 +119,13 @@ nextCookie c = do where persist = (PersistentCookie ==) . cookieType getNext = case cookieSucc c of - Nothing -> renewCookie c + Nothing -> wrapHttpClient $ renewCookie c Just ck -> do let uid = ZAuth.userTokenOf (cookieValue c) trackSuperseded uid (cookieId c) - cs <- DB.listCookies uid + cs <- liftSem $ E.getCookies uid case List.find (\x -> cookieId x == ck && persist x) cs of - Nothing -> renewCookie c + Nothing -> wrapHttpClient $ renewCookie c Just c' -> do t <- ZAuth.mkUserToken uid (cookieIdNum ck) (cookieExpires c') pure c' {cookieValue = t} @@ -156,7 +156,7 @@ renewCookie old = do -- 'suspendCookiesOlderThanSecs'. Call this always before 'newCookie', 'nextCookie', -- 'newCookieLimited' if there is a chance that the user should be suspended (we don't do it -- implicitly because of cyclical dependencies). -mustSuspendInactiveUser :: (MonadReader Env m, MonadClient m) => UserId -> m Bool +mustSuspendInactiveUser :: Member CookieStore r => UserId -> AppT r Bool mustSuspendInactiveUser uid = view (settings . to setSuspendInactiveUsers) >>= \case Nothing -> pure False @@ -166,7 +166,7 @@ mustSuspendInactiveUser uid = suspendHere = addUTCTime (-suspendAge) now youngEnough :: Cookie () -> Bool youngEnough = (>= suspendHere) . cookieCreated - ckies <- listCookies uid [] + ckies <- liftSem $ listCookies uid [] let mustSuspend | null ckies = False | any youngEnough ckies = False @@ -202,20 +202,25 @@ lookupCookie t = do where setToken c = c {cookieValue = t} -listCookies :: MonadClient m => UserId -> [CookieLabel] -> m [Cookie ()] -listCookies u [] = DB.listCookies u -listCookies u ll = filter byLabel <$> DB.listCookies u +listCookies :: Member CookieStore r => UserId -> [CookieLabel] -> Sem r [Cookie ()] +listCookies u [] = E.getCookies u +listCookies u ll = filter byLabel <$> E.getCookies u where byLabel c = maybe False (`elem` ll) (cookieLabel c) -revokeAllCookies :: MonadClient m => UserId -> m () +revokeAllCookies :: Member CookieStore r => UserId -> Sem r () revokeAllCookies u = revokeCookies u [] [] -revokeCookies :: MonadClient m => UserId -> [CookieId] -> [CookieLabel] -> m () -revokeCookies u [] [] = DB.deleteAllCookies u +revokeCookies :: + Member CookieStore r => + UserId -> + [CookieId] -> + [CookieLabel] -> + Sem r () +revokeCookies u [] [] = E.deleteAllCookies u revokeCookies u ids labels = do - cc <- filter matching <$> DB.listCookies u - DB.deleteCookies u cc + cc <- filter matching <$> E.getCookies u + E.deleteCookies u cc where matching c = cookieId c `elem` ids @@ -226,27 +231,25 @@ revokeCookies u ids labels = do newCookieLimited :: ( ZAuth.UserTokenLike t, - MonadReader Env m, - MonadClient m, - ZAuth.MonadZAuth m + Member CookieStore r ) => UserId -> CookieType -> Maybe CookieLabel -> - m (Either RetryAfter (Cookie (ZAuth.Token t))) + AppT r (Either RetryAfter (Cookie (ZAuth.Token t))) newCookieLimited u typ label = do - cs <- filter ((typ ==) . cookieType) <$> DB.listCookies u + cs <- liftSem $ filter ((typ ==) . cookieType) <$> E.getCookies u now <- liftIO =<< view currentTime lim <- CookieLimit . setUserCookieLimit <$> view settings thr <- setUserCookieThrottle <$> view settings let evict = map cookieId (limitCookies lim now cs) if null evict - then Right <$> newCookie u typ label + then Right <$> wrapHttpClient (newCookie u typ label) else case throttleCookies now thr cs of Just wait -> pure (Left wait) Nothing -> do - revokeCookies u evict [] - Right <$> newCookie u typ label + liftSem $ revokeCookies u evict [] + Right <$> wrapHttpClient (newCookie u typ label) -------------------------------------------------------------------------------- -- HTTP diff --git a/services/brig/src/Brig/User/Auth/DB/Cookie.hs b/services/brig/src/Brig/User/Auth/DB/Cookie.hs index c0d43ef234..24bc5800a3 100644 --- a/services/brig/src/Brig/User/Auth/DB/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/DB/Cookie.hs @@ -17,6 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +-- FUTUREWORK: Migrate the remaining actions to 'Brig.Effects.CookieStore' module Brig.User.Auth.DB.Cookie where import Brig.User.Auth.DB.Instances () @@ -64,40 +65,3 @@ lookupCookie u t c = "SELECT type, created, label, succ_id \ \FROM user_cookies \ \WHERE user = ? AND expires = ? AND id = ?" - -listCookies :: MonadClient m => UserId -> m [Cookie ()] -listCookies u = - map toCookie <$> retry x1 (query cql (params LocalQuorum (Identity u))) - where - cql :: PrepQuery R (Identity UserId) (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) - cql = - "SELECT id, created, expires, type, label, succ_id \ - \FROM user_cookies \ - \WHERE user = ? \ - \ORDER BY expires ASC" - toCookie :: (CookieId, UTCTime, UTCTime, CookieType, Maybe CookieLabel, Maybe CookieId) -> Cookie () - toCookie (i, ct, et, t, l, sc) = - Cookie - { cookieId = i, - cookieType = t, - cookieCreated = ct, - cookieExpires = et, - cookieLabel = l, - cookieSucc = sc, - cookieValue = () - } - -deleteCookies :: MonadClient m => UserId -> [Cookie a] -> m () -deleteCookies u cs = retry x5 . batch $ do - setType BatchUnLogged - setConsistency LocalQuorum - for_ cs $ \c -> addPrepQuery cql (u, cookieExpires c, cookieId c) - where - cql :: PrepQuery W (UserId, UTCTime, CookieId) () - cql = "DELETE FROM user_cookies WHERE user = ? AND expires = ? AND id = ?" - -deleteAllCookies :: MonadClient m => UserId -> m () -deleteAllCookies u = retry x5 (write cql (params LocalQuorum (Identity u))) - where - cql :: PrepQuery W (Identity UserId) () - cql = "DELETE FROM user_cookies WHERE user = ?" diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index bd9ae04f2f..c4ef255469 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -21,39 +21,50 @@ module Brig.User.EJPD (ejpdRequest) where import Brig.API.Handler -import Brig.API.User (lookupHandle) -import Brig.App (AppT, wrapClient, wrapHttp) +import Brig.App import qualified Brig.Data.Connection as Conn import Brig.Data.User (lookupUser) +import Brig.Effects.UserHandleStore +import Brig.Effects.UserQuery (UserQuery) import qualified Brig.IO.Intra as Intra +import Brig.Options (setDefaultUserLocale) import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error hiding (bool) import Control.Lens (view, (^.)) import Data.Handle (Handle) import Data.Id (UserId) +import Data.Qualified import qualified Data.Set as Set import Imports hiding (head) +import Polysemy import Servant.Swagger.Internal.Orphans () import Wire.API.Connection (Relation, RelationWithHistory (..), relationDropHistory) import qualified Wire.API.Push.Token as PushTok import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (EJPDRequestBody), EJPDResponseBody (EJPDResponseBody), EJPDResponseItem (EJPDResponseItem)) import qualified Wire.API.Team.Member as Team -import Wire.API.User (User, userDisplayName, userEmail, userHandle, userId, userPhone, userTeam) +import Wire.API.User (Locale, User, userDisplayName, userEmail, userHandle, userId, userPhone, userTeam) -ejpdRequest :: Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody +ejpdRequest :: + forall r p. + Members '[UserHandleStore, UserQuery p] r => + Maybe Bool -> + EJPDRequestBody -> + (Handler r) EJPDResponseBody ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where -- find uid given handle go1 :: Bool -> Handle -> (AppT r) (Maybe EJPDResponseItem) go1 includeContacts' handle = do - mbUid <- wrapClient $ lookupHandle handle - mbUsr <- maybe (pure Nothing) (wrapClient . lookupUser NoPendingInvitations) mbUid - maybe (pure Nothing) (fmap Just . go2 includeContacts') mbUsr + loc <- fmap (qTagUnsafe @'QLocal) $ Qualified () <$> viewFederationDomain + locale <- setDefaultUserLocale <$> view settings + mbUid <- liftSem $ lookupHandle handle + mbUsr <- maybe (pure Nothing) (liftSem . lookupUser loc locale NoPendingInvitations) mbUid + maybe (pure Nothing) (fmap Just . go2 loc locale includeContacts') mbUsr -- construct response item given uid - go2 :: Bool -> User -> (AppT r) EJPDResponseItem - go2 includeContacts' target = do + go2 :: Local x -> Locale -> Bool -> User -> (AppT r) EJPDResponseItem + go2 loc locale includeContacts' target = do let uid = userId target ptoks <- @@ -67,8 +78,8 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do contactsFull :: [Maybe (Relation, EJPDResponseItem)] <- forM contacts $ \(uid', relationDropHistory -> rel) -> do - mbUsr <- wrapClient $ lookupUser NoPendingInvitations uid' - maybe (pure Nothing) (fmap (Just . (rel,)) . go2 False) mbUsr + mbUsr <- liftSem $ lookupUser loc locale NoPendingInvitations uid' + maybe (pure Nothing) (fmap (Just . (rel,)) . go2 loc locale False) mbUsr pure . Just . Set.fromList . catMaybes $ contactsFull else do @@ -82,8 +93,8 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do contactsFull :: [Maybe EJPDResponseItem] <- forM members $ \uid' -> do - mbUsr <- wrapClient $ lookupUser NoPendingInvitations uid' - maybe (pure Nothing) (fmap Just . go2 False) mbUsr + mbUsr <- liftSem $ lookupUser loc locale NoPendingInvitations uid' + maybe (pure Nothing) (fmap Just . go2 loc locale False) mbUsr pure . Just . (,Team.toNewListType (memberList ^. Team.teamMemberListType)) . Set.fromList . catMaybes $ contactsFull _ -> do diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 256337cc9e..b419524b87 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -24,78 +24,82 @@ module Brig.User.Handle ) where -import Brig.App -import Brig.CanonicalInterpreter (runBrigToIO) import Brig.Data.Instances () import qualified Brig.Data.User as User +import Brig.Effects.UniqueClaimsStore +import Brig.Effects.UserHandleStore + ( Consistency (..), + UserHandleStore, + deleteHandle, + getHandleWithConsistency, + insertHandle, + ) +import Brig.Effects.UserQuery import Brig.Unique -import Cassandra import Data.Handle (Handle, fromHandle) import Data.Id -import Imports +import Imports hiding (All) +import Polysemy +import Polysemy.Async +import Polysemy.Conc.Effect.Race +import Polysemy.Resource -- | Claim a new handle for an existing 'User'. -claimHandle :: (MonadClient m, MonadReader Env m) => UserId -> Maybe Handle -> Handle -> m Bool +claimHandle :: + forall r p. + Members + '[ Async, + Race, + Resource, + UniqueClaimsStore, + UserHandleStore, + UserQuery p + ] + r => + UserId -> + Maybe Handle -> + Handle -> + Sem r Bool claimHandle uid oldHandle newHandle = isJust <$> do owner <- lookupHandle newHandle case owner of Just uid' | uid /= uid' -> pure Nothing _ -> do - env <- ask let key = "@" <> fromHandle newHandle - withClaim uid key (30 # Minute) $ - runBrigToIO env $ - do - -- Record ownership - wrapClient $ retry x5 $ write handleInsert (params LocalQuorum (newHandle, uid)) - -- Update profile - result <- wrapClient $ User.updateHandle uid newHandle - -- Free old handle (if it changed) - for_ (mfilter (/= newHandle) oldHandle) $ - wrapClient . freeHandle uid - pure result + withClaim uid key (30 # Minute) $ do + -- Record ownership + insertHandle @r newHandle uid + -- Update profile + result <- User.updateHandle uid newHandle + -- Free old handle (if it changed) + for_ (mfilter (/= newHandle) oldHandle) $ + freeHandle uid + pure result -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: MonadClient m => UserId -> Handle -> m () +freeHandle :: + Members '[UniqueClaimsStore, UserHandleStore] r => + UserId -> + Handle -> + Sem r () freeHandle uid h = do mbHandleUid <- lookupHandle h case mbHandleUid of Just handleUid | handleUid == uid -> do - retry x5 $ write handleDelete (params LocalQuorum (Identity h)) + deleteHandle h let key = "@" <> fromHandle h - deleteClaim uid key (30 # Minute) + deleteClaims uid (30 # Minute) key _ -> pure () -- this shouldn't happen, the call side should always check that `h` and `uid` belong to the same account. -- | Lookup the current owner of a 'Handle'. -lookupHandle :: MonadClient m => Handle -> m (Maybe UserId) -lookupHandle = lookupHandleWithPolicy LocalQuorum +lookupHandle :: + Member UserHandleStore r => + Handle -> + Sem r (Maybe UserId) +lookupHandle = getHandleWithConsistency LocalQuorum -- | A weaker version of 'lookupHandle' that trades availability -- (and potentially speed) for the possibility of returning stale data. -glimpseHandle :: MonadClient m => Handle -> m (Maybe UserId) -glimpseHandle = lookupHandleWithPolicy One - -{-# INLINE lookupHandleWithPolicy #-} - --- | Sending an empty 'Handle' here causes C* to throw "Key may not be empty" --- error. --- --- FUTUREWORK: This should ideally be tackled by hiding constructor for 'Handle' --- and only allowing it to be parsed. -lookupHandleWithPolicy :: MonadClient m => Consistency -> Handle -> m (Maybe UserId) -lookupHandleWithPolicy policy h = do - (runIdentity =<<) - <$> retry x1 (query1 handleSelect (params policy (Identity h))) - --------------------------------------------------------------------------------- --- Queries - -handleInsert :: PrepQuery W (Handle, UserId) () -handleInsert = "INSERT INTO user_handle (handle, user) VALUES (?, ?)" - -handleSelect :: PrepQuery R (Identity Handle) (Identity (Maybe UserId)) -handleSelect = "SELECT user FROM user_handle WHERE handle = ?" - -handleDelete :: PrepQuery W (Identity Handle) () -handleDelete = "DELETE FROM user_handle WHERE handle = ?" +glimpseHandle :: Member UserHandleStore r => Handle -> Sem r (Maybe UserId) +glimpseHandle = getHandleWithConsistency One diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index f6b7f3f4d4..94d947a0ae 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -26,6 +26,7 @@ import API.MLS.Util import Bilge import Bilge.Assert import Brig.Data.User (lookupFeatureConferenceCalling, lookupStatus, userExists) +import Brig.Effects.UserQuery.Cassandra import qualified Brig.Options as Opt import Brig.Types.Intra import qualified Cassandra as Cass @@ -42,6 +43,7 @@ import Data.Qualified (Qualified (qDomain, qUnqualified)) import qualified Data.Set as Set import GHC.TypeLits (KnownSymbol) import Imports +import Polysemy import Servant.API (ToHttpApiData (toUrlPiece)) import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty @@ -96,7 +98,7 @@ testSuspendNonExistingUser :: forall m. TestConstraints m => Cass.ClientState -> testSuspendNonExistingUser db brig = do nonExistingUserId <- randomId setAccountStatus brig nonExistingUserId Suspended !!! const 404 === statusCode - isUserCreated <- Cass.runClient db (userExists nonExistingUserId) + isUserCreated <- Cass.runClient db (runM $ userQueryToCassandra @Cass.Client @'[Embed Cass.Client] $ userExists nonExistingUserId) liftIO $ isUserCreated @?= False setAccountStatus :: (MonadIO m, MonadHttp m, HasCallStack, MonadCatch m) => Brig -> UserId -> AccountStatus -> m ResponseLBS diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 6b6674f748..c99cb9c392 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -28,6 +28,8 @@ import qualified API.Team.Util as Team import Bilge hiding (accept, head, timeout) import Bilge.Assert import qualified Brig.Code as Code +import Brig.Effects.Common +import Brig.Effects.VerificationCodeStore.Cassandra import qualified Brig.Types.Intra as Intra import qualified Cassandra as DB import Control.Arrow ((&&&)) @@ -71,6 +73,7 @@ import qualified Network.Wai.Route as Wai import qualified Network.Wai.Utilities.Error as Error import OpenSSL.PEM (writePublicKey) import OpenSSL.RSA (generateRSAKey') +import Polysemy import System.IO.Temp (withSystemTempFile) import Test.Tasty hiding (Timeout) import qualified Test.Tasty.Cannon as WS @@ -1418,7 +1421,12 @@ enabled2ndFaForTeamInternal galley tid = do -- DB Operations lookupCode :: MonadIO m => DB.ClientState -> Code.Gen -> Code.Scope -> m (Maybe Code.Code) -lookupCode db gen = liftIO . DB.runClient db . Code.lookup (Code.genKey gen) +lookupCode db gen = + liftIO + . runFinal + . interpretClientToIO db + . verificationCodeStoreToCassandra @DB.Client + . Code.getPendingCode (Code.genKey gen) -------------------------------------------------------------------------------- -- Utilities diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index f2c41833e2..aedef5941e 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -67,7 +67,7 @@ tests conf fbc fgc p b c ch g n aws db = do API.User.Auth.tests conf p z db b g n, API.User.Connection.tests cl at conf p b c g fbc fgc db, API.User.Handles.tests cl at conf p b c g, - API.User.PasswordReset.tests db cl at conf p b c g, + API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, API.User.RichInfo.tests cl at conf p b c g ] diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 15362e4168..7884790639 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -26,7 +26,6 @@ import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert import qualified Brig.Options as Opt -import qualified Cassandra as DB import Data.Misc (PlainTextPassword (..)) import Imports import Test.Tasty hiding (Timeout) @@ -35,7 +34,6 @@ import Wire.API.User import Wire.API.User.Auth tests :: - DB.ClientState -> ConnectionLimit -> Opt.Timeout -> Opt.Opts -> @@ -44,15 +42,15 @@ tests :: Cannon -> Galley -> TestTree -tests cs _cl _at _conf p b _c _g = +tests _cl _at _conf p b _c _g = testGroup "password-reset" - [ test p "post /password-reset[/complete] - 201[/200]" $ testPasswordReset b cs, - test p "post /password-reset after put /access/self/email - 400" $ testPasswordResetAfterEmailUpdate b cs + [ test p "post /password-reset[/complete] - 201[/200]" $ testPasswordReset b, + test p "post /password-reset after put /access/self/email - 400" $ testPasswordResetAfterEmailUpdate b ] -testPasswordReset :: Brig -> DB.ClientState -> Http () -testPasswordReset brig cs = do +testPasswordReset :: Brig -> Http () +testPasswordReset brig = do u <- randomUser brig let Just email = userEmail u let uid = userId u @@ -60,7 +58,7 @@ testPasswordReset brig cs = do let newpw = PlainTextPassword "newsecret" do initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid newpw + passwordResetData <- preparePasswordReset brig email uid newpw completePasswordReset brig passwordResetData !!! const 200 === statusCode -- try login login brig (defEmailLogin email) PersistentCookie @@ -70,18 +68,18 @@ testPasswordReset brig cs = do -- reset password again to the same new password, get 400 "must be different" do initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid newpw + passwordResetData <- preparePasswordReset brig email uid newpw completePasswordReset brig passwordResetData !!! const 409 === statusCode -testPasswordResetAfterEmailUpdate :: Brig -> DB.ClientState -> Http () -testPasswordResetAfterEmailUpdate brig cs = do +testPasswordResetAfterEmailUpdate :: Brig -> Http () +testPasswordResetAfterEmailUpdate brig = do u <- randomUser brig let uid = userId u let Just email = userEmail u eml <- randomEmail initiateEmailUpdateLogin brig eml (emailLogin email defPassword Nothing) uid !!! const 202 === statusCode initiatePasswordReset brig email !!! const 201 === statusCode - passwordResetData <- preparePasswordReset brig cs email uid (PlainTextPassword "newsecret") + passwordResetData <- preparePasswordReset brig email uid (PlainTextPassword "newsecret") -- activate new email activateEmail brig eml checkEmail brig uid eml diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 22b93dcb20..1c7676c28d 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -22,8 +22,10 @@ module API.User.Util where import Bilge hiding (accept, timeout) import Bilge.Assert import qualified Brig.Code as Code -import Brig.Effects.CodeStore -import Brig.Effects.CodeStore.Cassandra +import Brig.Effects.Common +import Brig.Effects.PasswordResetSupply +import Brig.Effects.PasswordResetSupply.IO +import Brig.Effects.VerificationCodeStore.Cassandra import Brig.Options (Opts) import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import qualified Brig.ZAuth @@ -31,12 +33,13 @@ import qualified Cassandra as DB import qualified Codec.MIME.Type as MIME import Control.Lens (preview, (^?)) import Control.Monad.Catch (MonadCatch) -import Data.Aeson hiding (json) +import Data.Aeson hiding (Key, json) import Data.Aeson.Lens import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as LB +import Data.Code hiding (Value) import Data.Domain import Data.Handle (Handle (Handle)) import Data.Id hiding (client) @@ -203,12 +206,11 @@ initiateEmailUpdateNoSend brig email uid = preparePasswordReset :: (MonadIO m, MonadHttp m) => Brig -> - DB.ClientState -> Email -> UserId -> PlainTextPassword -> m CompletePasswordReset -preparePasswordReset brig cs email uid newpw = do +preparePasswordReset brig email uid newpw = do let qry = queryItem "email" (toByteString' email) r <- get $ brig . path "/i/users/password-reset-code" . qry let lbs = fromMaybe "" $ responseBody r @@ -217,7 +219,7 @@ preparePasswordReset brig cs email uid newpw = do let complete = CompletePasswordReset ident pwcode newpw pure complete where - runSem = liftIO . runFinal @IO . interpretClientToIO cs . codeStoreToCassandra @DB.Client + runSem = liftIO . runM . passwordResetSupplyToIO @'[Embed IO] completePasswordReset :: Brig -> CompletePasswordReset -> (MonadIO m, MonadHttp m) => m ResponseLBS completePasswordReset brig passwordResetData = @@ -553,8 +555,13 @@ setTeamFeatureLockStatus :: setTeamFeatureLockStatus galley tid status = put (galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' status]) !!! const 200 === statusCode -lookupCode :: MonadIO m => DB.ClientState -> Code.Key -> Code.Scope -> m (Maybe Code.Code) -lookupCode db k = liftIO . DB.runClient db . Code.lookup k +lookupCode :: MonadIO m => DB.ClientState -> Key -> Code.Scope -> m (Maybe Code.Code) +lookupCode db k = + liftIO + . runFinal + . interpretClientToIO db + . verificationCodeStoreToCassandra @DB.Client + . Code.getPendingCode k getNonce :: (MonadIO m, MonadHttp m) => diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 6e3529e497..9c1a7f994c 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -86,7 +86,6 @@ library Galley.Effects.CustomBackendStore Galley.Effects.ExternalAccess Galley.Effects.FederatorAccess - Galley.Effects.FireAndForget Galley.Effects.GundeckAccess Galley.Effects.LegalHoldStore Galley.Effects.ListItems diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index dcae8353e8..7912431ec1 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -64,7 +64,6 @@ import qualified Galley.Effects.BrigAccess as E import qualified Galley.Effects.CodeStore as E import qualified Galley.Effects.ConversationStore as E import qualified Galley.Effects.FederatorAccess as E -import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore import qualified Galley.Effects.TeamStore as E @@ -92,6 +91,7 @@ import Wire.API.Federation.Error import Wire.API.Team.LegalHold import Wire.API.Team.Member import qualified Wire.API.User as User +import qualified Wire.Sem.FireAndForget as E data NoChanges = NoChanges diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 46e56f2fe6..8e2ac12af3 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -53,7 +53,6 @@ import Galley.Effects import qualified Galley.Effects.BrigAccess as E import Galley.Effects.ConversationStore (getConversation) import qualified Galley.Effects.ConversationStore as E -import qualified Galley.Effects.FireAndForget as E import qualified Galley.Effects.MemberStore as E import Galley.Effects.ProposalStore (ProposalStore) import Galley.Options @@ -94,6 +93,7 @@ import Wire.API.Message import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named import Wire.API.ServantProto +import qualified Wire.Sem.FireAndForget as E type FederationAPI = "federation" :> FedApi 'Galley diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 71288e7af5..97e91e0219 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -52,7 +52,6 @@ import Galley.App import qualified Galley.Data.Conversation as Data import Galley.Effects import Galley.Effects.BrigAccess -import Galley.Effects.FireAndForget import qualified Galley.Effects.LegalHoldStore as LegalHoldData import Galley.Effects.ProposalStore import qualified Galley.Effects.TeamFeatureStore as TeamFeatures @@ -81,6 +80,7 @@ import qualified Wire.API.Team.LegalHold as Public import Wire.API.Team.LegalHold.External hiding (userId) import Wire.API.Team.Member import Wire.API.User.Client.Prekey +import Wire.Sem.FireAndForget import Wire.Sem.Paging import Wire.Sem.Paging.Cassandra diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 97cd4b2bf4..5476987400 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -74,7 +74,6 @@ import Galley.Cassandra.Team import Galley.Cassandra.TeamFeatures import Galley.Cassandra.TeamNotifications import Galley.Effects -import Galley.Effects.FireAndForget (interpretFireAndForget) import Galley.Effects.WaiRoutes.IO import Galley.Env import Galley.External @@ -106,6 +105,7 @@ import qualified UnliftIO.Exception as UnliftIO import Util.Options import Wire.API.Error import Wire.API.Federation.Error +import Wire.Sem.FireAndForget.IO (interpretFireAndForget) import qualified Wire.Sem.Logger -- Effects needed by the interpretation of other effects diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 3cdcd04dd4..1ec846a1c4 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -71,7 +71,6 @@ import Galley.Effects.ConversationStore import Galley.Effects.CustomBackendStore import Galley.Effects.ExternalAccess import Galley.Effects.FederatorAccess -import Galley.Effects.FireAndForget import Galley.Effects.GundeckAccess import Galley.Effects.LegalHoldStore import Galley.Effects.ListItems @@ -93,6 +92,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Wire.API.Error +import Wire.Sem.FireAndForget import Wire.Sem.Paging.Cassandra -- All the possible high-level effects.