From e7301ea234758e6553102c2014f8d4b096b0e62f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 10:48:35 -0700 Subject: [PATCH 01/18] rpc effect machinery --- .../brig/src/Brig/CanonicalInterpreter.hs | 8 ++++ services/brig/src/Brig/RPC.hs | 10 +++++ services/brig/src/Brig/Sem/RPC.hs | 20 ++++++++++ services/brig/src/Brig/Sem/RPC/IO.hs | 40 +++++++++++++++++++ services/brig/src/Brig/Sem/ServiceRPC.hs | 20 ++++++++++ services/brig/src/Brig/Sem/ServiceRPC/IO.hs | 18 +++++++++ 6 files changed, 116 insertions(+) create mode 100644 services/brig/src/Brig/Sem/RPC.hs create mode 100644 services/brig/src/Brig/Sem/RPC/IO.hs create mode 100644 services/brig/src/Brig/Sem/ServiceRPC.hs create mode 100644 services/brig/src/Brig/Sem/ServiceRPC/IO.hs diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 72ae9ee2cb..5caaf5c201 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -15,6 +15,10 @@ import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) +import Brig.Sem.RPC.IO (interpretRpcToIO) +import Brig.Sem.RPC (RPC) +import Brig.Sem.ServiceRPC +import Brig.Sem.ServiceRPC.IO (interpretServiceRpcToRpc) type BrigCanonicalEffects = '[ BlacklistPhonePrefixStore, @@ -22,6 +26,8 @@ type BrigCanonicalEffects = PasswordResetStore, Now, CodeStore, + ServiceRPC 'Galley, + RPC, Embed Cas.Client, Embed IO, Final IO @@ -32,6 +38,8 @@ runBrigToIO e (AppT ma) = runFinal . embedToFinal . interpretClientToIO (e ^. casClient) + . interpretRpcToIO (e ^. httpManager) (e ^. requestId) + . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) . codeStoreToCassandra @Cas.Client . nowToIOAction (e ^. currentTime) . passwordResetStoreToCodeStore diff --git a/services/brig/src/Brig/RPC.hs b/services/brig/src/Brig/RPC.hs index 5320a81f19..986ea5725f 100644 --- a/services/brig/src/Brig/RPC.hs +++ b/services/brig/src/Brig/RPC.hs @@ -89,6 +89,16 @@ serviceRequest :: m (Response (Maybe BL.ByteString)) serviceRequest nm svc m r = do service <- view svc + serviceRequestImpl nm service m r + +serviceRequestImpl :: + (MonadIO m, MonadMask m, MonadHttp m, HasRequestId m) => + LT.Text -> + Request -> + StdMethod -> + (Request -> Request) -> + m (Response (Maybe BL.ByteString)) +serviceRequestImpl nm service m r = do recovering x3 rpcHandlers $ const $ rpc' nm service (method m . r) diff --git a/services/brig/src/Brig/Sem/RPC.hs b/services/brig/src/Brig/Sem/RPC.hs new file mode 100644 index 0000000000..9adc87ab4c --- /dev/null +++ b/services/brig/src/Brig/Sem/RPC.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Brig.Sem.RPC where + +import Bilge +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as LT +import Imports +import Network.HTTP.Types.Method +import Polysemy + +data RPC m a where + ServiceRequest :: + LT.Text -> + Request -> + StdMethod -> + (Request -> Request) -> + RPC m (Response (Maybe BL.ByteString)) + +makeSem ''RPC diff --git a/services/brig/src/Brig/Sem/RPC/IO.hs b/services/brig/src/Brig/Sem/RPC/IO.hs new file mode 100644 index 0000000000..69245a485a --- /dev/null +++ b/services/brig/src/Brig/Sem/RPC/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Brig.Sem.RPC.IO where + +import Brig.Sem.RPC +import Polysemy +import Imports +import qualified Brig.RPC as RPC +import Bilge (HttpT, MonadHttp, RequestId) +import Control.Monad.Catch +import Bilge.RPC +import Bilge.IO (runHttpT, Manager) + +interpretRpcToIO :: Members '[Final IO] r => Manager -> RequestId -> Sem (RPC ': r) a -> Sem r a +interpretRpcToIO mgr rid = interpret $ \case + ServiceRequest txt f sm g -> + embedFinal @IO $ viaHttpIO mgr rid $ RPC.serviceRequestImpl txt f sm g + + +viaHttpIO :: Manager -> RequestId -> HttpIO a -> IO a +viaHttpIO mgr rid = runHttpT mgr . flip runReaderT rid . runHttpIO + +newtype HttpIO a = HttpIO + { runHttpIO :: ReaderT RequestId (HttpT IO) a + } + deriving newtype + ( Functor, + Applicative, + Monad, + MonadHttp, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask, + MonadUnliftIO + ) + +instance HasRequestId HttpIO where + getRequestId = HttpIO ask + diff --git a/services/brig/src/Brig/Sem/ServiceRPC.hs b/services/brig/src/Brig/Sem/ServiceRPC.hs new file mode 100644 index 0000000000..f83947df9c --- /dev/null +++ b/services/brig/src/Brig/Sem/ServiceRPC.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Brig.Sem.ServiceRPC where + +import Bilge +import qualified Data.ByteString.Lazy as BL +import Imports +import Network.HTTP.Types.Method +import Polysemy + +data Service + = Galley + +data ServiceRPC (service :: Service) m a where + Request :: + StdMethod -> + (Request -> Request) -> + ServiceRPC service m (Response (Maybe BL.ByteString)) + +makeSem ''ServiceRPC diff --git a/services/brig/src/Brig/Sem/ServiceRPC/IO.hs b/services/brig/src/Brig/Sem/ServiceRPC/IO.hs new file mode 100644 index 0000000000..9a181f8f03 --- /dev/null +++ b/services/brig/src/Brig/Sem/ServiceRPC/IO.hs @@ -0,0 +1,18 @@ +module Brig.Sem.ServiceRPC.IO where + +import Brig.Sem.ServiceRPC + +import Brig.Sem.RPC +import Polysemy +import Imports +import Bilge (Request) +import qualified Data.Text.Lazy as LT + + +interpretServiceRpcToRpc + :: forall service r a + . Member RPC r + => LT.Text + -> Request -> Sem (ServiceRPC service ': r) a -> Sem r a +interpretServiceRpcToRpc lt r = interpret $ \case + Request sm f -> serviceRequest lt r sm f From 5454ba2faa319231dfcd1726b9d2eddeffbe4a1f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 11:54:21 -0700 Subject: [PATCH 02/18] wip: galleyprovider effect --- services/brig/src/Brig/API/User.hs | 135 ++++++-------- services/brig/src/Brig/IO/Intra.hs | 38 ++-- services/brig/src/Brig/Sem/GalleyProvider.hs | 170 ++++++++++++++++++ .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 34 ++++ services/brig/src/Brig/Team/Util.hs | 12 +- 5 files changed, 287 insertions(+), 102 deletions(-) create mode 100644 services/brig/src/Brig/Sem/GalleyProvider.hs create mode 100644 services/brig/src/Brig/Sem/GalleyProvider/RPC.hs diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index ba48a0d9a9..9ab3d19175 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -180,6 +180,8 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Sem.GalleyProvider (GalleyProvider) data AllowSCIMUpdates = AllowSCIMUpdates @@ -218,7 +220,10 @@ verifyUniquenessAndCheckBlacklist uk = do unless av $ throwE IdentityErrorUserKeyExists -createUserSpar :: NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult +createUserSpar :: forall r. Members + '[GalleyProvider + ] r + => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do let handle' = newUserSparHandle new new' = newUserFromSpar new @@ -236,7 +241,7 @@ createUserSpar new = do case unRichInfo <$> newUserSparRichInfo new of Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do - wrapHttp $ Intra.createSelfConv uid + liftSem $ GalleyProvider.createSelfConv uid wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -263,7 +268,7 @@ createUserSpar new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ wrapHttp $ Intra.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, defaultRole) unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -273,11 +278,16 @@ createUserSpar new = do field "user" (toByteString uid) . field "team" (toByteString tid) . msg (val "Added via SSO") - Team.TeamName nm <- lift $ wrapHttp $ Intra.getTeamName tid + Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid pure $ CreateUserTeam tid nm -- docs/reference/user/registration.md {#RefRegistration} -createUser :: forall r. Member BlacklistStore r => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult +createUser + :: forall r. + Members '[ BlacklistStore + , GalleyProvider + ] r + => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -330,7 +340,7 @@ createUser new = do Log.info $ field "user" (toByteString uid) . msg (val "Creating user") wrapClient $ Data.insertAccount account Nothing pw False - wrapHttp $ Intra.createSelfConv uid + liftSem $ GalleyProvider.createSelfConv uid wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account @@ -341,7 +351,7 @@ createUser new = do activatedTeam <- lift $ do case (tid, newTeam) of (Just tid', Just nt) -> do - created <- wrapHttp $ Intra.createTeam uid (bnuTeam nt) tid' + created <- liftSem $ GalleyProvider.createTeam uid (bnuTeam nt) tid' let activating = isJust (newUserEmailCode new) pure $ if activating @@ -353,7 +363,7 @@ createUser new = do Just (inv, invInfo) -> do let em = Team.inInviteeEmail inv acceptTeamInvitation account inv invInfo (userEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ wrapHttp $ Intra.getTeamName (Team.inTeam inv) + Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName (Team.inTeam inv) pure (Just $ CreateUserTeam (Team.inTeam inv) nm) Nothing -> pure Nothing @@ -419,7 +429,7 @@ createUser new = do throwE RegisterErrorTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. -- Remove after the next release. - canAdd <- lift $ wrapHttp $ Intra.checkUserCanJoinTeam tid + canAdd <- lift $ liftSem $ GalleyProvider.checkUserCanJoinTeam tid case canAdd of Just e -> throwM $ API.UserNotAllowedToJoinTeam e Nothing -> pure () @@ -438,7 +448,7 @@ createUser new = do throwE RegisterErrorUserKeyExists let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) - added <- lift $ wrapHttp $ Intra.addTeamMember uid (Team.iiTeam ii) minvmeta + added <- lift $ liftSem $ GalleyProvider.addTeamMember uid (Team.iiTeam ii) minvmeta unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -455,7 +465,7 @@ createUser new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ wrapHttp $ Intra.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, defaultRole) unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -465,7 +475,7 @@ createUser new = do field "user" (toByteString uid) . field "team" (toByteString tid) . msg (val "Added via SSO") - Team.TeamName nm <- lift $ wrapHttp $ Intra.getTeamName tid + Team.TeamName nm <- lift $ liftSem $ GalleyProvider.getTeamName tid pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) @@ -870,6 +880,7 @@ mkUserEvent usrs status = -- Activation activate :: + Members '[GalleyProvider] r => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -878,6 +889,7 @@ activate :: activate tgt code usr = activateWithCurrency tgt code usr Nothing activateWithCurrency :: + Members '[GalleyProvider] r => ActivationTarget -> ActivationCode -> -- | The user for whom to activate the key. @@ -903,8 +915,8 @@ activateWithCurrency tgt code usr cur = do pure $ ActivationSuccess ident first where activateTeam uid = do - tid <- wrapHttp $ Intra.getTeamId uid - for_ tid $ \t -> wrapHttp $ Intra.changeTeamStatus t Team.Active cur + tid <- liftSem $ GalleyProvider.getTeamId uid + for_ tid $ \t -> liftSem $ GalleyProvider.changeTeamStatus t Team.Active cur preverify :: ( MonadClient m, @@ -936,7 +948,8 @@ onActivated (PhoneActivated uid phone) = do sendActivationCode :: Members '[ BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => Either Email Phone -> @@ -1012,7 +1025,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of loc' = loc <|> Just (userLocale u) void . forEmailKey ek $ \em -> lift $ do -- Get user's team, if any. - mbTeam <- mapM (fmap Team.tdTeam . wrapHttp . Intra.getTeam) (userTeam u) + mbTeam <- mapM (fmap Team.tdTeam . liftSem . GalleyProvider.getTeam) (userTeam u) -- Depending on whether the user is a team creator, send either -- a team activation email or a regular email. Note that we -- don't have to check if the team is binding because if the @@ -1131,7 +1144,9 @@ 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 :: forall r. Members + '[GalleyProvider + ] r => UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser uid pwd = do account <- lift . wrapClient $ Data.lookupAccount uid case account of @@ -1148,7 +1163,7 @@ deleteSelfUser uid pwd = do case userTeam $ accountUser acc of Nothing -> pure () Just tid -> do - isOwner <- lift $ wrapHttp $ Intra.memberIsTeamOwner tid uid + isOwner <- lift $ liftSem $ GalleyProvider.memberIsTeamOwner tid uid when isOwner $ throwE DeleteUserOwnerDeletingSelf go a = maybe (byIdentity a) (byPassword a) pwd getEmailOrPhone :: UserIdentity -> Maybe (Either Email Phone) @@ -1333,16 +1348,10 @@ userGC u = case userExpire u of pure u lookupProfile :: - ( MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[GalleyProvider] r => Local UserId -> Qualified UserId -> - ExceptT FederationError m (Maybe UserProfile) + ExceptT FederationError (AppT r) (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfilesFromDomain @@ -1355,41 +1364,29 @@ 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 '[GalleyProvider] r => -- | 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] +-- TODO(sandy): PERFORMANCE CHANGE: no longer concurrent lookupProfiles self others = concat - <$> traverseConcurrentlyWithErrors + <$> traverse (lookupProfilesFromDomain self) (bucketQualified others) lookupProfilesFromDomain :: - ( MonadClient m, - MonadReader Env m, - MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[GalleyProvider] r => Local UserId -> Qualified [UserId] -> - ExceptT FederationError m [UserProfile] + ExceptT FederationError (AppT r) [UserProfile] lookupProfilesFromDomain self = foldQualified self (lift . lookupLocalProfiles (Just (tUnqualified self)) . tUnqualified) - lookupRemoteProfiles + (mapExceptT wrapHttp . lookupRemoteProfiles) lookupRemoteProfiles :: ( MonadIO m, @@ -1405,23 +1402,17 @@ 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. + Members '[GalleyProvider] 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 + users <- wrapHttpClient $ Data.lookupUsers NoPendingInvitations others >>= mapM userGC css <- case requestingUser of - Just localReqUser -> toMap <$> Data.lookupConnectionStatus (map userId users) [localReqUser] + Just localReqUser -> toMap <$> wrapHttpClient (Data.lookupConnectionStatus (map userId users) [localReqUser]) Nothing -> pure mempty emailVisibility' <- view (settings . emailVisibility) emailVisibility'' <- case emailVisibility' of @@ -1430,21 +1421,21 @@ lookupLocalProfiles requestingUser others = do Just localReqUser -> EmailVisibleIfOnSameTeam' <$> getSelfInfo localReqUser Nothing -> pure EmailVisibleToSelf' EmailVisibleToSelf -> pure EmailVisibleToSelf' - usersAndStatus <- for users $ \u -> (u,) <$> getLegalHoldStatus' u + usersAndStatus <- liftSem $ for users $ \u -> (u,) <$> getLegalHoldStatus' u pure $ map (toProfile emailVisibility'' css) usersAndStatus where toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - getSelfInfo :: UserId -> m (Maybe (TeamId, TeamMember)) + getSelfInfo :: UserId -> AppT r (Maybe (TeamId, TeamMember)) getSelfInfo 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 <- wrapHttp $ Data.lookupUser NoPendingInvitations selfId case userTeam =<< mUser of Nothing -> pure Nothing - Just tid -> (tid,) <$$> Intra.getTeamMember selfId tid + Just tid -> (tid,) <$$> liftSem (GalleyProvider.getTeamMember selfId tid) toProfile :: EmailVisibility' -> Map UserId Relation -> (User, UserLegalHoldStatus) -> UserProfile toProfile emailVisibility'' css (u, userLegalHold) = @@ -1457,32 +1448,20 @@ lookupLocalProfiles requestingUser others = do in baseProfile {profileEmail = profileEmail'} getLegalHoldStatus :: - ( MonadLogger m, - MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadClient m - ) => + Members '[GalleyProvider] r => UserId -> - m (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (getLegalHoldStatus' . accountUser) =<< lookupAccount uid + AppT r (Maybe UserLegalHoldStatus) +getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) getLegalHoldStatus' :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[GalleyProvider] r => User -> - m UserLegalHoldStatus + Sem r UserLegalHoldStatus getLegalHoldStatus' user = case userTeam user of Nothing -> pure defUserLegalHoldStatus Just tid -> do - teamMember <- Intra.getTeamMember (userId user) tid + teamMember <- GalleyProvider.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember data EmailVisibility' diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index c22c8a178a..65de3c986e 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -26,16 +26,16 @@ module Brig.IO.Intra onClientEvent, -- * Conversations - createSelfConv, + -- createSelfConv, createConnectConv, acceptConnectConv, blockConv, unblockConv, - getConv, + -- getConv, upsertOne2OneConversation, -- * Clients - Brig.IO.Intra.newClient, + -- Brig.IO.Intra.newClient, rmClient, lookupPushToken, @@ -43,22 +43,22 @@ module Brig.IO.Intra rmUser, -- * Teams - addTeamMember, - checkUserCanJoinTeam, - createTeam, - getTeamMember, - getTeamMembers, - memberIsTeamOwner, - getTeam, - getTeamConv, - getTeamName, - getTeamId, - getTeamContacts, - getTeamLegalHoldStatus, - changeTeamStatus, - getTeamSearchVisibility, - getAllFeatureConfigsForUser, - getVerificationCodeEnabled, + -- addTeamMember, + -- checkUserCanJoinTeam, + -- createTeam, + -- getTeamMember, + -- getTeamMembers, + -- memberIsTeamOwner, + -- getTeam, + -- getTeamConv, + -- getTeamName, + -- getTeamId, + -- getTeamContacts, + -- getTeamLegalHoldStatus, + -- changeTeamStatus, + -- getTeamSearchVisibility, + -- getAllFeatureConfigsForUser, + -- getVerificationCodeEnabled, -- * Legalhold guardLegalhold, diff --git a/services/brig/src/Brig/Sem/GalleyProvider.hs b/services/brig/src/Brig/Sem/GalleyProvider.hs new file mode 100644 index 0000000000..90e13839ef --- /dev/null +++ b/services/brig/src/Brig/Sem/GalleyProvider.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Brig.Sem.GalleyProvider where + +import Polysemy +import Brig.API.Types +import qualified Data.Currency as Currency +import Data.Id +import Data.Json.Util (UTCTimeMillis) +import Data.Qualified +import qualified Galley.Types.Teams.Intra as Team +import Imports +import qualified Network.Wai.Utilities.Error as Wai +import Wire.API.Conversation +import Wire.API.Team +import qualified Wire.API.Team.Conversation as Conv +import Wire.API.Team.Feature +import qualified Wire.API.Team.Member as Team +import Wire.API.Team.Role +import Wire.API.Team.SearchVisibility +import Wire.API.User + + +data GalleyProvider m a where + CreateSelfConv :: + UserId -> + GalleyProvider m () + + + CreateLocalConnectConv :: + Local UserId -> + Local UserId -> + Maybe Text -> + Maybe ConnId -> + GalleyProvider m ConvId + + + AcceptLocalConnectConv :: + Local UserId -> + Maybe ConnId -> + ConvId -> + GalleyProvider m Conversation + + + BlockLocalConv :: + Local UserId -> + Maybe ConnId -> + ConvId -> + GalleyProvider m () + + + UnblockLocalConv :: + Local UserId -> + Maybe ConnId -> + ConvId -> + GalleyProvider m Conversation + + + GetConv :: + UserId -> + ConvId -> + GalleyProvider m (Maybe Conversation) + + + GetTeamConv :: + UserId -> + TeamId -> + ConvId -> + GalleyProvider m (Maybe Conv.TeamConversation) + + + RmUser :: + UserId -> + [Asset] -> + GalleyProvider m () + + + NewClient :: + UserId -> + ClientId -> + GalleyProvider m () + + + RmClient :: + UserId -> + ClientId -> + GalleyProvider m () + + + CheckUserCanJoinTeam :: + TeamId -> + GalleyProvider m (Maybe Wai.Error) + + + AddTeamMember :: + UserId -> + TeamId -> + (Maybe (UserId, UTCTimeMillis), Role) -> + GalleyProvider m Bool + + + CreateTeam :: + UserId -> + BindingNewTeam -> + TeamId -> + GalleyProvider m CreateUserTeam + + + GetTeamMember :: + UserId -> + TeamId -> + GalleyProvider m (Maybe Team.TeamMember) + + GetTeamMembers :: + TeamId -> + GalleyProvider m Team.TeamMemberList + + + GetTeamContacts :: + UserId -> + GalleyProvider m (Maybe Team.TeamMemberList) + + + GetTeamId :: + UserId -> + GalleyProvider m (Maybe TeamId) + + + GetTeam :: + TeamId -> + GalleyProvider m Team.TeamData + + + GetTeamName :: + TeamId -> + GalleyProvider m Team.TeamName + + + GetTeamLegalHoldStatus :: + TeamId -> + GalleyProvider m (WithStatus LegalholdConfig) + + + GetTeamSearchVisibility :: + TeamId -> + GalleyProvider m TeamSearchVisibility + + + ChangeTeamStatus :: + TeamId -> + Team.TeamStatus -> + Maybe Currency.Alpha -> + GalleyProvider m () + + + MemberIsTeamOwner :: + TeamId -> + UserId -> + GalleyProvider m Bool + + GetAllFeatureConfigsForUser :: + Maybe UserId -> + GalleyProvider m AllFeatureConfigs + + GetVerificationCodeEnabled :: + TeamId -> + GalleyProvider m Bool + +makeSem ''GalleyProvider + diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs new file mode 100644 index 0000000000..393f430dd8 --- /dev/null +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Brig.Sem.GalleyProvider.RPC where + +import Brig.Sem.GalleyProvider +import Brig.Sem.RPC +import Polysemy +import Imports + + +interpretGalleyProviderToRPC :: Member RPC r => Sem (GalleyProvider ': r) a -> Sem r a +interpretGalleyProviderToRPC = interpret undefined + -- CreateSelfConv uid -> undefined + -- CreateLocalConnectConv qwt qwt' m_txt m_ci -> undefined + -- AcceptLocalConnectConv qwt m_ci uid -> undefined + -- BlockLocalConv qwt m_ci uid -> undefined + -- UnblockLocalConv qwt m_ci uid -> undefined + -- GetConv uid id' -> undefined + -- GetTeamConv uid id' id2 -> undefined + -- RmUser uid ass -> undefined + -- NewClient uid ci -> undefined + -- RmClient uid ci -> undefined + -- CheckUserCanJoinTeam uid -> undefined + -- AddTeamMember uid id' x0 -> undefined + -- CreateTeam uid bnt id' -> undefined + -- GetTeamMember uid id' -> undefined + -- GetTeamMembers uid -> undefined + -- GetTeamContacts uid -> undefined + -- GetTeamId uid -> undefined + -- GetTeam uid -> undefined + -- GetTeamName uid -> undefined + -- GetTeamLegalHoldStatus uid -> undefined + -- GetTeamSearchVisibility uid -> undefined + -- ChangeTeamStatus uid ts m_al -> undefined diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index c5a442df12..07eb31cdd6 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -19,7 +19,6 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App -import qualified Brig.IO.Intra as Intra import Control.Error import Control.Lens import Data.Id @@ -28,10 +27,13 @@ import Galley.Types.Teams import Imports import Wire.API.Team.Member import Wire.API.Team.Permission +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Polysemy (Member) +import Brig.Sem.GalleyProvider (GalleyProvider) -ensurePermissions :: UserId -> TeamId -> [Perm] -> ExceptT Error (AppT r) () +ensurePermissions :: Member GalleyProvider r => UserId -> TeamId -> [Perm] -> ExceptT Error (AppT r) () ensurePermissions u t perms = do - m <- lift $ wrapHttp $ Intra.getTeamMember u t + m <- lift $ liftSem $ GalleyProvider.getTeamMember u t unless (check m) $ throwStd insufficientTeamPermissions where @@ -42,9 +44,9 @@ ensurePermissions u t perms = do -- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`). -- -- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'. -ensurePermissionToAddUser :: UserId -> TeamId -> Permissions -> ExceptT Error (AppT r) () +ensurePermissionToAddUser :: Member GalleyProvider r => UserId -> TeamId -> Permissions -> ExceptT Error (AppT r) () ensurePermissionToAddUser u t inviteePerms = do - minviter <- lift $ wrapHttp $ Intra.getTeamMember u t + minviter <- lift $ liftSem $ GalleyProvider.getTeamMember u t unless (check minviter) $ throwStd insufficientTeamPermissions where From 1f8997d908b84846e9653f42455d40377f4f4119 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 12:36:36 -0700 Subject: [PATCH 03/18] propagate effects --- services/brig/src/Brig/API/Client.hs | 19 ++- services/brig/src/Brig/API/Connection.hs | 19 ++- services/brig/src/Brig/API/Public.hs | 86 +++++++--- services/brig/src/Brig/Provider/API.hs | 187 ++++++++++------------ services/brig/src/Brig/Team/API.hs | 69 +++++--- services/brig/src/Brig/User/API/Auth.hs | 42 +++-- services/brig/src/Brig/User/API/Handle.hs | 15 +- services/brig/src/Brig/User/API/Search.hs | 15 +- services/brig/src/Brig/User/Auth.hs | 96 ++++------- services/brig/src/Brig/User/EJPD.hs | 9 +- 10 files changed, 310 insertions(+), 247 deletions(-) diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 691bc36060..62edea9fa2 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -92,6 +92,9 @@ import qualified Wire.API.User as Code import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Polysemy (Members) +import Brig.Sem.GalleyProvider (GalleyProvider) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) lookupLocalClient uid = wrapClient . Data.lookupClient uid @@ -129,6 +132,7 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap ( lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk addClient :: + Members '[GalleyProvider] r => UserId -> Maybe ConnId -> Maybe IP -> @@ -139,6 +143,8 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. addClientWithReAuthPolicy :: + forall r. + Members '[GalleyProvider] r => Data.ReAuthPolicy -> UserId -> Maybe ConnId -> @@ -147,7 +153,7 @@ addClientWithReAuthPolicy :: 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) + verifyCode (newClientVerificationCode new) (userId . accountUser $ acc) loc <- maybe (pure Nothing) locationOf ip maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) @@ -166,7 +172,7 @@ addClientWithReAuthPolicy policy u con ip new = do let usr = accountUser acc lift $ do for_ old $ execDelete u con - wrapHttp $ Intra.newClient u (clientId clt) + liftSem $ GalleyProvider.newClient u (clientId clt) Intra.onClientEvent u con (ClientAdded u clt) when (clientType clt == LegalHoldClientType) $ wrapHttpClient $ Intra.onUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ @@ -178,16 +184,9 @@ addClientWithReAuthPolicy policy u con ip new = do clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) verifyCode :: - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - HasRequestId m, - Log.MonadLogger m, - MonadClient m - ) => Maybe Code.Value -> UserId -> - ExceptT ClientError m () + ExceptT ClientError (AppT r) () verifyCode 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 diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index c455e8c1de..7b4da65074 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -58,20 +58,24 @@ import Wire.API.Conversation import Wire.API.Error import qualified Wire.API.Error.Brig as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Polysemy (Members) +import Brig.Sem.GalleyProvider (GalleyProvider) ensureIsActivated :: Local UserId -> MaybeT (AppT r) () ensureIsActivated lusr = do active <- lift . wrapClient $ Data.isActivated (tUnqualified lusr) guard active -ensureNotSameTeam :: Local UserId -> Local UserId -> (ConnectionM r) () +ensureNotSameTeam :: Members '[GalleyProvider] r => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do - selfTeam <- lift $ wrapHttp $ Intra.getTeamId (tUnqualified self) - targetTeam <- lift $ wrapHttp $ Intra.getTeamId (tUnqualified target) + selfTeam <- lift $ liftSem $ GalleyProvider.getTeamId (tUnqualified self) + targetTeam <- lift $ liftSem $ GalleyProvider.getTeamId (tUnqualified target) when (isJust selfTeam && selfTeam == targetTeam) $ throwE ConnectSameBindingTeamUsers createConnection :: + Members '[GalleyProvider] r => Local UserId -> ConnId -> Qualified UserId -> @@ -91,6 +95,7 @@ createConnection self con target = do target createConnectionToLocalUser :: + Members '[GalleyProvider] r => Local UserId -> ConnId -> Local UserId -> @@ -178,15 +183,17 @@ 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 '[GalleyProvider] 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 () diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 00b29d92d6..61f21773b7 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -46,7 +46,6 @@ import qualified Brig.Data.User as Data import qualified Brig.Data.UserKey as UserKey import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) -import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider import Brig.Sem.CodeStore (CodeStore) @@ -136,6 +135,8 @@ 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 qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Sem.GalleyProvider (GalleyProvider) -- User API ----------------------------------------------------------- @@ -188,7 +189,8 @@ servantSitemap :: forall r. Members '[ BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => ServerT BrigAPI (Handler r) @@ -302,7 +304,8 @@ sitemap :: '[ CodeStore, PasswordResetStore, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => Routes Doc.ApiBuilder (Handler r) () @@ -432,7 +435,8 @@ apiDocs :: '[ CodeStore, PasswordResetStore, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => Routes Doc.ApiBuilder (Handler r) () @@ -542,7 +546,9 @@ 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 '[ GalleyProvider + ] 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) $ @@ -625,7 +631,10 @@ newNonce _ = do pure nonce -- | docs/reference/user/registration.md {#RefRegistration} -createUser :: Member BlacklistStore r => Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) +createUser :: Members '[BlacklistStore, + GalleyProvider + ] r + => Public.NewUserPublic -> (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 @@ -699,18 +708,24 @@ getSelf self = lift (API.lookupSelfProfile self) >>= ifNothing (errorToWai @'E.UserNotFound) -getUserUnqualifiedH :: UserId -> UserId -> (Handler r) (Maybe Public.UserProfile) +getUserUnqualifiedH :: + Members '[ GalleyProvider + ] 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 '[ GalleyProvider + ] 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 '[ GalleyProvider + ] 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 @@ -726,7 +741,9 @@ 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. + Members '[ GalleyProvider + ] r => UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] listUsersByIdsOrHandles self q = do lself <- qualifyLocal self foundUsers <- case q of @@ -746,7 +763,7 @@ listUsersByIdsOrHandles self q = do 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) @@ -812,7 +829,9 @@ checkHandles _ (Public.CheckHandles hs num) = do -- 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 '[ GalleyProvider + ] r => UserId -> Handle -> (Handler r) (Maybe Public.UserHandleInfo) getHandleInfoUnqualifiedH self handle = do domain <- viewFederationDomain Public.UserHandleInfo . Public.profileQualifiedId @@ -854,7 +873,7 @@ completePasswordResetH (_ ::: req) = do sendActivationCodeH :: Members '[ BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, GalleyProvider ] r => JsonRequest Public.SendActivationCode -> @@ -867,7 +886,7 @@ sendActivationCodeH req = sendActivationCode :: Members '[ BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, GalleyProvider ] r => Public.SendActivationCode -> @@ -892,13 +911,17 @@ customerExtensionCheckBlockedDomains email = do when (domain `elem` blockedDomains) $ throwM $ customerExtensionBlockedDomain domain -createConnectionUnqualified :: UserId -> ConnId -> Public.ConnectionRequest -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) +createConnectionUnqualified :: + Members '[ GalleyProvider + ] 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 '[ GalleyProvider + ] 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 @@ -974,7 +997,9 @@ getConnection self other = do lift . wrapClient $ Data.lookupConnection lself other deleteSelfUser :: - UserId -> + + Members '[ GalleyProvider + ] r => UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) deleteSelfUser u body = @@ -986,7 +1011,9 @@ verifyDeleteUserH (r ::: _) = do API.verifyDeleteUser body !>> deleteUserError pure (setStatus status200 empty) -updateUserEmail :: Member BlacklistStore r => UserId -> UserId -> Public.EmailUpdate -> (Handler r) () +updateUserEmail :: forall r. Members '[BlacklistStore, + GalleyProvider ] + 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 @@ -1004,7 +1031,7 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do where check = runMaybeT $ do teamId <- hoistMaybe maybeTeamId - teamMember <- MaybeT $ lift $ wrapHttp $ Intra.getTeamMember zuserId teamId + teamMember <- MaybeT $ lift $ liftSem $ GalleyProvider.getTeamMember zuserId teamId pure $ teamMember `hasPermission` ChangeTeamMemberProfiles -- activation @@ -1023,17 +1050,23 @@ respFromActivationRespWithStatus = \case ActivationRespSuccessNoIdent -> empty -- docs/reference/user/activation.md {#RefActivationSubmit} -activateKeyH :: JSON ::: JsonRequest Public.Activate -> (Handler r) Response +activateKeyH :: + Members '[ GalleyProvider + ] r => JSON ::: JsonRequest Public.Activate -> (Handler r) Response activateKeyH (_ ::: req) = do activationRequest <- parseJsonBody req respFromActivationRespWithStatus <$> activate activationRequest -activateH :: Public.ActivationKey ::: Public.ActivationCode -> (Handler r) Response +activateH :: + Members '[ GalleyProvider + ] r => Public.ActivationKey ::: Public.ActivationCode -> (Handler r) Response activateH (k ::: c) = do let activationRequest = Public.Activate (Public.ActivateKey k) c False respFromActivationRespWithStatus <$> activate activationRequest -activate :: Public.Activate -> (Handler r) ActivationRespWithStatus +activate :: + Members '[ GalleyProvider + ] r => Public.Activate -> (Handler r) ActivationRespWithStatus activate (Public.Activate tgt code dryrun) | dryrun = do wrapClientE (API.preverify tgt code) !>> actError @@ -1047,7 +1080,10 @@ activate (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. + Members '[ GalleyProvider + ] r => Public.SendVerificationCode -> (Handler r) () sendVerificationCode req = do let email = Public.svcEmail req let action = Public.svcAction req @@ -1082,7 +1118,7 @@ sendVerificationCode req = do getFeatureStatus :: Maybe UserAccount -> (Handler r) Bool getFeatureStatus mbAccount = do - mbStatusEnabled <- lift $ wrapHttp $ Intra.getVerificationCodeEnabled `traverse` (Public.userTeam <$> accountUser =<< mbAccount) + mbStatusEnabled <- lift $ liftSem $ GalleyProvider.getVerificationCodeEnabled `traverse` (Public.userTeam <$> accountUser =<< mbAccount) pure $ fromMaybe False mbStatusEnabled -- Deprecated diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 061cdf4011..ee326d03d2 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -37,7 +37,6 @@ import qualified Brig.Code as Code import qualified Brig.Data.Client as User import qualified Brig.Data.User as User import Brig.Email (mkEmailKey) -import qualified Brig.IO.Intra as RPC import qualified Brig.InternalEvent.Types as Internal import Brig.Options (Settings (..)) import qualified Brig.Options as Opt @@ -120,8 +119,11 @@ 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) +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Sem.GalleyProvider (GalleyProvider) +import Polysemy (Members) -routesPublic :: Routes Doc.ApiBuilder (Handler r) () +routesPublic :: Members '[GalleyProvider] r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Public API (Unauthenticated) -------------------------------------------- @@ -152,7 +154,7 @@ routesPublic = do -- Provider API ------------------------------------------------------------ - delete "/provider" (continue $ wrapHttpClientE <$> deleteAccountH) $ + delete "/provider" (continue deleteAccountH) $ zauth ZAuthProvider .&> zauthProviderId .&. jsonRequest @Public.DeleteProvider @@ -320,7 +322,7 @@ routesPublic = do .&> zauth ZAuthBot .&> capture "uid" -routesInternal :: Routes a (Handler r) () +routesInternal :: Members '[GalleyProvider] r => Routes a (Handler r) () routesInternal = do get "/i/provider/activation-code" (continue getActivationCodeH) $ accept "application" "json" @@ -329,9 +331,9 @@ routesInternal = do -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccountH :: JsonRequest Public.NewProvider -> (Handler r) Response +newAccountH :: Members '[GalleyProvider] r => JsonRequest Public.NewProvider -> (Handler r) Response newAccountH req = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing setStatus status201 . json <$> (newAccount =<< parseJsonBody req) newAccount :: Public.NewProvider -> (Handler r) Public.NewProviderResponse @@ -366,9 +368,9 @@ newAccount new = do lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response +activateAccountKeyH :: Members '[GalleyProvider] r => Code.Key ::: Code.Value -> (Handler r) Response activateAccountKeyH (key ::: val) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing maybe (setStatus status204 empty) json <$> activateAccountKey key val activateAccountKey :: Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) @@ -393,9 +395,9 @@ activateAccountKey key val = do lift $ sendApprovalConfirmMail name email pure . Just $ Public.ProviderActivationResponse email -getActivationCodeH :: Public.Email -> (Handler r) Response +getActivationCodeH :: Members '[GalleyProvider] r => Public.Email -> (Handler r) Response getActivationCodeH e = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> getActivationCode e getActivationCode :: Public.Email -> (Handler r) FoundActivationCode @@ -414,9 +416,9 @@ instance ToJSON FoundActivationCode where toJSON $ Code.KeyValuePair (Code.codeKey vcode) (Code.codeValue vcode) -approveAccountKeyH :: Code.Key ::: Code.Value -> (Handler r) Response +approveAccountKeyH :: Members '[GalleyProvider] r => Code.Key ::: Code.Value -> (Handler r) Response approveAccountKeyH (key ::: val) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ approveAccountKey key val approveAccountKey :: Code.Key -> Code.Value -> (Handler r) () @@ -429,9 +431,9 @@ approveAccountKey key val = do lift $ sendApprovalConfirmMail name email _ -> throwStd (errorToWai @'InvalidCode) -loginH :: JsonRequest Public.ProviderLogin -> (Handler r) Response +loginH :: Members '[GalleyProvider] r => JsonRequest Public.ProviderLogin -> (Handler r) Response loginH req = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing tok <- login =<< parseJsonBody req setProviderCookie tok empty @@ -443,9 +445,9 @@ login l = do throwStd (errorToWai @'BadCredentials) ZAuth.newProviderToken pid -beginPasswordResetH :: JsonRequest Public.PasswordReset -> (Handler r) Response +beginPasswordResetH :: Members '[GalleyProvider] r => JsonRequest Public.PasswordReset -> (Handler r) Response beginPasswordResetH req = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing setStatus status201 empty <$ (beginPasswordReset =<< parseJsonBody req) beginPasswordReset :: Public.PasswordReset -> (Handler r) () @@ -465,9 +467,9 @@ beginPasswordReset (Public.PasswordReset target) = do tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) -completePasswordResetH :: JsonRequest Public.CompletePasswordReset -> (Handler r) Response +completePasswordResetH :: Members '[GalleyProvider] r => JsonRequest Public.CompletePasswordReset -> (Handler r) Response completePasswordResetH req = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ (completePasswordReset =<< parseJsonBody req) completePasswordReset :: Public.CompletePasswordReset -> (Handler r) () @@ -486,9 +488,9 @@ completePasswordReset (Public.CompletePasswordReset key val newpwd) = do -------------------------------------------------------------------------------- -- Provider API -getAccountH :: ProviderId -> (Handler r) Response +getAccountH :: Members '[GalleyProvider] r => ProviderId -> (Handler r) Response getAccountH pid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing getAccount pid <&> \case Just p -> json p Nothing -> setStatus status404 empty @@ -496,9 +498,9 @@ getAccountH pid = do getAccount :: ProviderId -> (Handler r) (Maybe Public.Provider) getAccount = wrapClientE . DB.lookupAccount -updateAccountProfileH :: ProviderId ::: JsonRequest Public.UpdateProvider -> (Handler r) Response +updateAccountProfileH :: Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.UpdateProvider -> (Handler r) Response updateAccountProfileH (pid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ (updateAccountProfile pid =<< parseJsonBody req) updateAccountProfile :: ProviderId -> Public.UpdateProvider -> (Handler r) () @@ -511,9 +513,9 @@ updateAccountProfile pid upd = do (updateProviderUrl upd) (updateProviderDescr upd) -updateAccountEmailH :: ProviderId ::: JsonRequest Public.EmailUpdate -> (Handler r) Response +updateAccountEmailH :: Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.EmailUpdate -> (Handler r) Response updateAccountEmailH (pid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing setStatus status202 empty <$ (updateAccountEmail pid =<< parseJsonBody req) updateAccountEmail :: ProviderId -> Public.EmailUpdate -> (Handler r) () @@ -534,9 +536,9 @@ updateAccountEmail pid (Public.EmailUpdate new) = do tryInsertVerificationCode code $ verificationCodeThrottledError . VerificationCodeThrottled lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True -updateAccountPasswordH :: ProviderId ::: JsonRequest Public.PasswordChange -> (Handler r) Response +updateAccountPasswordH :: Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.PasswordChange -> (Handler r) Response updateAccountPasswordH (pid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ (updateAccountPassword pid =<< parseJsonBody req) updateAccountPassword :: ProviderId -> Public.PasswordChange -> (Handler r) () @@ -548,9 +550,9 @@ updateAccountPassword pid upd = do throwStd newPasswordMustDiffer wrapClientE $ DB.updateAccountPassword pid (cpNewPassword upd) -addServiceH :: ProviderId ::: JsonRequest Public.NewService -> (Handler r) Response +addServiceH :: Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.NewService -> (Handler r) Response addServiceH (pid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing setStatus status201 . json <$> (addService pid =<< parseJsonBody req) addService :: ProviderId -> Public.NewService -> (Handler r) Public.NewServiceResponse @@ -569,26 +571,26 @@ addService pid new = do let rstoken = maybe (Just token) (const Nothing) (newServiceToken new) pure $ Public.NewServiceResponse sid rstoken -listServicesH :: ProviderId -> (Handler r) Response +listServicesH :: Members '[GalleyProvider] r => ProviderId -> (Handler r) Response listServicesH pid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> listServices pid listServices :: ProviderId -> (Handler r) [Public.Service] listServices = wrapClientE . DB.listServices -getServiceH :: ProviderId ::: ServiceId -> (Handler r) Response +getServiceH :: Members '[GalleyProvider] r => ProviderId ::: ServiceId -> (Handler r) Response getServiceH (pid ::: sid) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> getService pid sid getService :: ProviderId -> ServiceId -> (Handler r) Public.Service getService pid sid = wrapClientE (DB.lookupService pid sid) >>= maybeServiceNotFound -updateServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateService -> (Handler r) Response +updateServiceH :: Members '[GalleyProvider] r => ProviderId ::: ServiceId ::: JsonRequest Public.UpdateService -> (Handler r) Response updateServiceH (pid ::: sid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ (updateService pid sid =<< parseJsonBody req) updateService :: ProviderId -> ServiceId -> Public.UpdateService -> (Handler r) () @@ -619,9 +621,9 @@ updateService pid sid upd = do tagsChange (serviceEnabled svc) -updateServiceConnH :: ProviderId ::: ServiceId ::: JsonRequest Public.UpdateServiceConn -> (Handler r) Response +updateServiceConnH :: Members '[GalleyProvider] r => ProviderId ::: ServiceId ::: JsonRequest Public.UpdateServiceConn -> (Handler r) Response updateServiceConnH (pid ::: sid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing empty <$ (updateServiceConn pid sid =<< parseJsonBody req) updateServiceConn :: ProviderId -> ServiceId -> Public.UpdateServiceConn -> (Handler r) () @@ -660,14 +662,14 @@ updateServiceConn pid sid upd = do -- TODO: Send informational email to provider. --- | The endpoint that is called to delete a service. +-- | Members '[GalleyProvider] r => The endpoint that is called to delete a service. -- -- Since deleting a service can be costly, it just marks the service as -- disabled and then creates an event that will, when processed, actually -- delete the service. See 'finishDeleteService'. -deleteServiceH :: ProviderId ::: ServiceId ::: JsonRequest Public.DeleteService -> (Handler r) Response +deleteServiceH :: Members '[GalleyProvider] r => ProviderId ::: ServiceId ::: JsonRequest Public.DeleteService -> (Handler r) Response deleteServiceH (pid ::: sid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing setStatus status202 empty <$ (deleteService pid sid =<< parseJsonBody req) -- | The endpoint that is called to delete a service. @@ -713,18 +715,11 @@ finishDeleteService pid sid = do kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid deleteAccountH :: - ( MonadReader Env m, - MonadMask m, - MonadHttp m, - MonadClient m, - HasRequestId m, - MonadLogger m - ) => - ProviderId ::: JsonRequest Public.DeleteProvider -> - ExceptT Error m Response + Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.DeleteProvider -> + ExceptT Error (AppT r) Response deleteAccountH (pid ::: req) = do guardSecondFactorDisabled Nothing - empty <$ (deleteAccount pid =<< parseJsonBody req) + empty <$ (mapExceptT wrapHttpClient $ deleteAccount pid =<< parseJsonBody req) deleteAccount :: ( MonadReader Env m, @@ -755,35 +750,35 @@ deleteAccount pid del = do -------------------------------------------------------------------------------- -- User API -getProviderProfileH :: ProviderId -> (Handler r) Response +getProviderProfileH :: Members '[GalleyProvider] r => ProviderId -> (Handler r) Response getProviderProfileH pid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> getProviderProfile pid getProviderProfile :: ProviderId -> (Handler r) Public.ProviderProfile getProviderProfile pid = wrapClientE (DB.lookupAccountProfile pid) >>= maybeProviderNotFound -listServiceProfilesH :: ProviderId -> (Handler r) Response +listServiceProfilesH :: Members '[GalleyProvider] r => ProviderId -> (Handler r) Response listServiceProfilesH pid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> listServiceProfiles pid listServiceProfiles :: ProviderId -> (Handler r) [Public.ServiceProfile] listServiceProfiles = wrapClientE . DB.listServiceProfiles -getServiceProfileH :: ProviderId ::: ServiceId -> (Handler r) Response +getServiceProfileH :: Members '[GalleyProvider] r => ProviderId ::: ServiceId -> (Handler r) Response getServiceProfileH (pid ::: sid) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> getServiceProfile pid sid getServiceProfile :: ProviderId -> ServiceId -> (Handler r) Public.ServiceProfile getServiceProfile pid sid = wrapClientE (DB.lookupServiceProfile pid sid) >>= maybeServiceNotFound -searchServiceProfilesH :: Maybe (Public.QueryAnyTags 1 3) ::: Maybe Text ::: Range 10 100 Int32 -> (Handler r) Response +searchServiceProfilesH :: Members '[GalleyProvider] r => Maybe (Public.QueryAnyTags 1 3) ::: Maybe Text ::: Range 10 100 Int32 -> (Handler r) Response searchServiceProfilesH (qt ::: start ::: size) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> searchServiceProfiles qt start size -- TODO: in order to actually make it possible for clients to implement @@ -800,10 +795,10 @@ searchServiceProfiles Nothing Nothing _ = do throwStd $ badRequest "At least `tags` or `start` must be provided." searchTeamServiceProfilesH :: - UserId ::: TeamId ::: Maybe (Range 1 128 Text) ::: Bool ::: Range 10 100 Int32 -> + Members '[GalleyProvider] r => UserId ::: TeamId ::: Maybe (Range 1 128 Text) ::: Bool ::: Range 10 100 Int32 -> (Handler r) Response searchTeamServiceProfilesH (uid ::: tid ::: prefix ::: filterDisabled ::: size) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just uid) + guardSecondFactorDisabled (Just uid) json <$> searchTeamServiceProfiles uid tid prefix filterDisabled size -- NB: unlike 'searchServiceProfiles', we don't filter by service provider here @@ -824,9 +819,9 @@ searchTeamServiceProfiles uid tid prefix filterDisabled size = do -- Get search results wrapClientE $ DB.paginateServiceWhitelist tid prefix filterDisabled (fromRange size) -getServiceTagListH :: () -> (Handler r) Response +getServiceTagListH :: Members '[GalleyProvider] r => () -> (Handler r) Response getServiceTagListH () = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> getServiceTagList () getServiceTagList :: () -> Monad m => m Public.ServiceTagList @@ -834,9 +829,9 @@ getServiceTagList () = pure (Public.ServiceTagList allTags) where allTags = [(minBound :: Public.ServiceTag) ..] -updateServiceWhitelistH :: UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> (Handler r) Response +updateServiceWhitelistH :: Members '[GalleyProvider] r => UserId ::: ConnId ::: TeamId ::: JsonRequest Public.UpdateServiceWhitelist -> (Handler r) Response updateServiceWhitelistH (uid ::: con ::: tid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just uid) + guardSecondFactorDisabled (Just uid) resp <- updateServiceWhitelist uid con tid =<< parseJsonBody req let status = case resp of UpdateServiceWhitelistRespChanged -> status200 @@ -847,7 +842,7 @@ data UpdateServiceWhitelistResp = UpdateServiceWhitelistRespChanged | UpdateServiceWhitelistRespUnchanged -updateServiceWhitelist :: UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp +updateServiceWhitelist :: Members '[GalleyProvider] r => UserId -> ConnId -> TeamId -> Public.UpdateServiceWhitelist -> (Handler r) UpdateServiceWhitelistResp updateServiceWhitelist uid con tid upd = do let pid = updateServiceWhitelistProvider upd sid = updateServiceWhitelistService upd @@ -880,18 +875,18 @@ updateServiceWhitelist uid con tid upd = do wrapClientE $ DB.deleteServiceWhitelist (Just tid) pid sid pure UpdateServiceWhitelistRespChanged -addBotH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> (Handler r) Response +addBotH :: Members '[GalleyProvider] r => UserId ::: ConnId ::: ConvId ::: JsonRequest Public.AddBot -> (Handler r) Response addBotH (zuid ::: zcon ::: cid ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just zuid) + guardSecondFactorDisabled (Just zuid) setStatus status201 . json <$> (addBot zuid zcon cid =<< parseJsonBody req) -addBot :: UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse +addBot :: Members '[GalleyProvider] r => UserId -> ConnId -> ConvId -> Public.AddBot -> (Handler r) Public.AddBotResponse addBot zuid zcon cid add = do zusr <- lift (wrapClient $ User.lookupUser NoPendingInvitations zuid) >>= maybeInvalidUser let pid = addBotProvider add let sid = addBotService add -- Get the conversation and check preconditions - cnv <- lift (wrapHttp $ RPC.getConv zuid cid) >>= maybeConvNotFound + cnv <- lift (liftSem $ GalleyProvider.getConv zuid cid) >>= maybeConvNotFound let mems = cnvMembers cnv unless (cnvType cnv == RegularConv) $ throwStd invalidConv @@ -959,15 +954,15 @@ addBot zuid zcon cid add = do Public.rsAddBotEvent = ev } -removeBotH :: UserId ::: ConnId ::: ConvId ::: BotId -> (Handler r) Response +removeBotH :: Members '[GalleyProvider] r => UserId ::: ConnId ::: ConvId ::: BotId -> (Handler r) Response removeBotH (zusr ::: zcon ::: cid ::: bid) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just zusr) + 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 '[GalleyProvider] 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 + cnv <- lift (liftSem $ GalleyProvider.getConv zusr cid) >>= maybeConvNotFound let mems = cnvMembers cnv unless (cnvType cnv == RegularConv) $ throwStd invalidConv @@ -982,9 +977,9 @@ removeBot zusr zcon cid bid = do -------------------------------------------------------------------------------- -- Bot API -botGetSelfH :: BotId -> (Handler r) Response +botGetSelfH :: Members '[GalleyProvider] r => BotId -> (Handler r) Response botGetSelfH bot = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bot)) + guardSecondFactorDisabled (Just (botUserId bot)) json <$> botGetSelf bot botGetSelf :: BotId -> (Handler r) Public.UserProfile @@ -992,18 +987,18 @@ botGetSelf bot = do p <- lift $ wrapClient $ User.lookupUser NoPendingInvitations (botUserId bot) maybe (throwStd (errorToWai @'UserNotFound)) (pure . (`Public.publicProfile` UserLegalHoldNoConsent)) p -botGetClientH :: BotId -> (Handler r) Response +botGetClientH :: Members '[GalleyProvider] r => BotId -> (Handler r) Response botGetClientH bot = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bot)) + guardSecondFactorDisabled (Just (botUserId bot)) maybe (throwStd (errorToWai @'ClientNotFound)) (pure . json) =<< lift (botGetClient bot) botGetClient :: BotId -> (AppT r) (Maybe Public.Client) botGetClient bot = listToMaybe <$> wrapClient (User.lookupClients (botUserId bot)) -botListPrekeysH :: BotId -> (Handler r) Response +botListPrekeysH :: Members '[GalleyProvider] r => BotId -> (Handler r) Response botListPrekeysH bot = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bot)) + guardSecondFactorDisabled (Just (botUserId bot)) json <$> botListPrekeys bot botListPrekeys :: BotId -> (Handler r) [Public.PrekeyId] @@ -1013,9 +1008,9 @@ botListPrekeys bot = do Nothing -> pure [] Just ci -> lift (wrapClient $ User.lookupPrekeyIds (botUserId bot) ci) -botUpdatePrekeysH :: BotId ::: JsonRequest Public.UpdateBotPrekeys -> (Handler r) Response +botUpdatePrekeysH :: Members '[GalleyProvider] r => BotId ::: JsonRequest Public.UpdateBotPrekeys -> (Handler r) Response botUpdatePrekeysH (bot ::: req) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bot)) + guardSecondFactorDisabled (Just (botUserId bot)) empty <$ (botUpdatePrekeys bot =<< parseJsonBody req) botUpdatePrekeys :: BotId -> Public.UpdateBotPrekeys -> (Handler r) () @@ -1027,9 +1022,9 @@ botUpdatePrekeys bot upd = do let pks = updateBotPrekeyList upd wrapClientE (User.updatePrekeys (botUserId bot) (clientId c) pks) !>> clientDataError -botClaimUsersPrekeysH :: JsonRequest Public.UserClients -> (Handler r) Response +botClaimUsersPrekeysH :: Members '[GalleyProvider] r => JsonRequest Public.UserClients -> (Handler r) Response botClaimUsersPrekeysH req = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing + guardSecondFactorDisabled Nothing json <$> (botClaimUsersPrekeys =<< parseJsonBody req) botClaimUsersPrekeys :: Public.UserClients -> (Handler r) Public.UserClientPrekeyMap @@ -1039,9 +1034,9 @@ botClaimUsersPrekeys body = do throwStd (errorToWai @'TooManyClients) Client.claimLocalMultiPrekeyBundles UnprotectedBot body !>> clientError -botListUserProfilesH :: List UserId -> (Handler r) Response +botListUserProfilesH :: Members '[GalleyProvider] r => List UserId -> (Handler r) Response botListUserProfilesH uids = do - mapExceptT wrapHttp $ guardSecondFactorDisabled Nothing -- should we check all user ids? + guardSecondFactorDisabled Nothing -- should we check all user ids? json <$> botListUserProfiles uids botListUserProfiles :: List UserId -> (Handler r) [Public.BotUserView] @@ -1049,9 +1044,9 @@ botListUserProfiles uids = do us <- lift . wrapClient $ User.lookupUsers NoPendingInvitations (fromList uids) pure (map mkBotUserView us) -botGetUserClientsH :: UserId -> (Handler r) Response +botGetUserClientsH :: Members '[GalleyProvider] r => UserId -> (Handler r) Response botGetUserClientsH uid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just uid) + guardSecondFactorDisabled (Just uid) json <$> lift (botGetUserClients uid) botGetUserClients :: UserId -> (AppT r) [Public.PubClient] @@ -1060,14 +1055,14 @@ botGetUserClients uid = where pubClient c = Public.PubClient (clientId c) (clientClass c) -botDeleteSelfH :: BotId ::: ConvId -> (Handler r) Response +botDeleteSelfH :: Members '[GalleyProvider] r => BotId ::: ConvId -> (Handler r) Response botDeleteSelfH (bid ::: cid) = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bid)) + guardSecondFactorDisabled (Just (botUserId bid)) empty <$ botDeleteSelf bid cid -botDeleteSelf :: BotId -> ConvId -> (Handler r) () +botDeleteSelf :: Members '[GalleyProvider] r => BotId -> ConvId -> (Handler r) () botDeleteSelf bid cid = do - mapExceptT wrapHttp $ guardSecondFactorDisabled (Just (botUserId bid)) + guardSecondFactorDisabled (Just (botUserId bid)) bot <- lift . wrapClient $ User.lookupUser NoPendingInvitations (botUserId bid) _ <- maybeInvalidBot (userService =<< bot) _ <- lift $ wrapHttpClient $ deleteBot (botUserId bid) Nothing bid cid @@ -1079,17 +1074,11 @@ botDeleteSelf bid cid = do -- | If second factor auth is enabled, make sure that end-points that don't support it, but should, are blocked completely. -- (This is a workaround until we have 2FA for those end-points as well.) guardSecondFactorDisabled :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[GalleyProvider] r => Maybe UserId -> - ExceptT Error m () + ExceptT Error (AppT r) () guardSecondFactorDisabled mbUserId = do - enabled <- lift $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> RPC.getAllFeatureConfigsForUser mbUserId + enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> GalleyProvider.getAllFeatureConfigsForUser mbUserId when enabled $ throwStd accessDenied minRsaKeySize :: Int diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index a8fefecf98..cff0d3ad75 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,7 +32,6 @@ import qualified Brig.Data.UserKey as Data import Brig.Effects.BlacklistStore (BlacklistStore) import qualified Brig.Effects.BlacklistStore as BlacklistStore import qualified Brig.Email as Email -import qualified Brig.IO.Intra as Intra import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import qualified Brig.Phone as Phone import qualified Brig.Team.DB as DB @@ -60,7 +59,7 @@ 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) +import Polysemy (Member, Members) import System.Logger (Msg) import qualified System.Logger.Class as Log import Util.Logging (logFunction, logTeam) @@ -77,8 +76,13 @@ 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 qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Sem.GalleyProvider (GalleyProvider) -routesPublic :: Member BlacklistStore r => Routes Doc.ApiBuilder (Handler r) () +routesPublic + :: Members '[BlacklistStore + , GalleyProvider + ] r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do post "/teams/:tid/invitations" (continue createInvitationPublicH) $ accept "application" "json" @@ -188,7 +192,11 @@ routesPublic = do Doc.response 200 "Invitation successful." Doc.end Doc.response 403 "No permission (not admin or owner of this team)." Doc.end -routesInternal :: Member BlacklistStore r => Routes a (Handler r) () +routesInternal :: + Members '[BlacklistStore + , GalleyProvider + ] r + => Routes a (Handler r) () routesInternal = do get "/i/teams/invitations/by-email" (continue getInvitationByEmailH) $ accept "application" "json" @@ -215,10 +223,10 @@ routesInternal = do accept "application" "json" .&. jsonRequest @NewUserScimInvitation -teamSizePublicH :: JSON ::: UserId ::: TeamId -> (Handler r) Response +teamSizePublicH :: Members '[GalleyProvider] r => JSON ::: UserId ::: TeamId -> (Handler r) Response teamSizePublicH (_ ::: uid ::: tid) = json <$> teamSizePublic uid tid -teamSizePublic :: UserId -> TeamId -> (Handler r) TeamSize +teamSizePublic :: Members '[GalleyProvider] r => UserId -> TeamId -> (Handler r) TeamSize teamSizePublic uid tid = do ensurePermissions uid tid [AddTeamMember] -- limit this to team admins to reduce risk of involuntary DOS attacks teamSize tid @@ -244,7 +252,11 @@ 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 + , GalleyProvider + ] r + => JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> (Handler r) Response createInvitationPublicH (_ ::: uid ::: tid ::: req) = do body <- parseJsonBody req newInv <- createInvitationPublic uid tid body @@ -260,7 +272,11 @@ data CreateInvitationInviter = CreateInvitationInviter } deriving (Eq, Show) -createInvitationPublic :: Member BlacklistStore r => UserId -> TeamId -> Public.InvitationRequest -> Handler r Public.Invitation +createInvitationPublic :: + Members '[BlacklistStore + , GalleyProvider + ] r + => UserId -> TeamId -> Public.InvitationRequest -> Handler r Public.Invitation createInvitationPublic uid tid body = do let inviteeRole = fromMaybe defaultRole . irRole $ body inviter <- do @@ -375,33 +391,33 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do timeout (newInv, code) <$ sendInvitationMail inviteeEmail tid fromEmail code locale -deleteInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response +deleteInvitationH :: Members '[GalleyProvider] r => JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response deleteInvitationH (_ ::: uid ::: tid ::: iid) = do empty <$ deleteInvitation uid tid iid -deleteInvitation :: UserId -> TeamId -> InvitationId -> (Handler r) () +deleteInvitation :: Members '[GalleyProvider] r => UserId -> TeamId -> InvitationId -> (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] lift $ wrapClient $ DB.deleteInvitation tid iid -listInvitationsH :: JSON ::: UserId ::: TeamId ::: Maybe InvitationId ::: Range 1 500 Int32 -> (Handler r) Response +listInvitationsH :: Members '[GalleyProvider] r => JSON ::: UserId ::: TeamId ::: Maybe InvitationId ::: Range 1 500 Int32 -> (Handler r) Response listInvitationsH (_ ::: uid ::: tid ::: start ::: size) = do json <$> listInvitations uid tid start size -listInvitations :: UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> (Handler r) Public.InvitationList +listInvitations :: Members '[GalleyProvider] r => UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> (Handler r) Public.InvitationList listInvitations uid tid start size = do ensurePermissions uid tid [AddTeamMember] rs <- lift $ wrapClient $ DB.lookupInvitations tid start size pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) -getInvitationH :: JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response +getInvitationH :: Members '[GalleyProvider] r => JSON ::: UserId ::: TeamId ::: InvitationId -> (Handler r) Response getInvitationH (_ ::: uid ::: tid ::: iid) = do inv <- getInvitation uid tid iid pure $ case inv of Just i -> json i Nothing -> setStatus status404 empty -getInvitation :: UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) +getInvitation :: Members '[GalleyProvider] r => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] lift $ wrapClient $ DB.lookupInvitation tid iid @@ -435,34 +451,41 @@ getInvitationByEmail email = do inv <- lift $ wrapClient $ DB.lookupInvitationByEmail email maybe (throwStd (notFound "Invitation not found")) pure inv -suspendTeamH :: JSON ::: TeamId -> (Handler r) Response +suspendTeamH :: Members '[GalleyProvider] r => JSON ::: TeamId -> (Handler r) Response suspendTeamH (_ ::: tid) = do empty <$ suspendTeam tid -suspendTeam :: TeamId -> (Handler r) () +suspendTeam :: Members '[GalleyProvider] r => TeamId -> (Handler r) () suspendTeam tid = do changeTeamAccountStatuses tid Suspended lift $ wrapClient $ DB.deleteInvitations tid - lift $ wrapHttp $ Intra.changeTeamStatus tid Team.Suspended Nothing + lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Suspended Nothing -unsuspendTeamH :: JSON ::: TeamId -> (Handler r) Response +unsuspendTeamH :: + Members '[GalleyProvider] r => + JSON ::: TeamId -> (Handler r) Response unsuspendTeamH (_ ::: tid) = do empty <$ unsuspendTeam tid -unsuspendTeam :: TeamId -> (Handler r) () +unsuspendTeam :: + Members '[GalleyProvider] r => + TeamId -> (Handler r) () unsuspendTeam tid = do changeTeamAccountStatuses tid Active - lift $ wrapHttp $ Intra.changeTeamStatus tid Team.Active Nothing + lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Active Nothing ------------------------------------------------------------------------------- -- Internal -changeTeamAccountStatuses :: TeamId -> AccountStatus -> (Handler r) () +changeTeamAccountStatuses + :: + Members '[GalleyProvider] r => + TeamId -> AccountStatus -> (Handler r) () changeTeamAccountStatuses tid s = do - team <- Team.tdTeam <$> lift (wrapHttp $ Intra.getTeam tid) + team <- Team.tdTeam <$> lift (liftSem $ GalleyProvider.getTeam tid) unless (team ^. teamBinding == Binding) $ throwStd noBindingTeam - uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> wrapHttp (Intra.getTeamMembers tid)) + uids <- toList1 =<< lift (fmap (view Teams.userId) . view teamMembers <$> liftSem (GalleyProvider.getTeamMembers tid)) wrapHttpClientE (API.changeAccountStatus uids s) !>> accountStatusError where toList1 (x : xs) = pure $ List1.list1 x xs diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index a528297b1b..474c8e6004 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -58,15 +58,18 @@ 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 (Member, Members) 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.Swagger as Doc (pendingLoginError) +import Brig.Sem.GalleyProvider (GalleyProvider) routesPublic :: - Member BlacklistStore r => + Members '[ BlacklistStore + , GalleyProvider + ] r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Note: this endpoint should always remain available at its unversioned @@ -193,7 +196,9 @@ routesPublic = do Doc.body (Doc.ref Public.modelRemoveCookies) Doc.end Doc.errorResponse (errorToWai @'E.BadCredentials) -routesInternal :: Routes a (Handler r) () +routesInternal :: + Members '[GalleyProvider] 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) $ @@ -233,31 +238,40 @@ getLoginCode phone = do code <- lift $ wrapClient $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) pure code -reAuthUserH :: UserId ::: JsonRequest ReAuthUser -> (Handler r) Response +reAuthUserH :: + Members '[GalleyProvider] r => + UserId ::: JsonRequest ReAuthUser -> (Handler r) Response reAuthUserH (uid ::: req) = do reAuthUser uid =<< parseJsonBody req pure empty -reAuthUser :: UserId -> ReAuthUser -> (Handler r) () +reAuthUser + :: + Members '[GalleyProvider] r => + UserId -> ReAuthUser -> (Handler r) () reAuthUser uid body = do wrapClientE (User.reauthenticate 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 '[GalleyProvider] 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 '[GalleyProvider] 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 + Auth.login l typ !>> loginError ssoLoginH :: JsonRequest SsoLogin ::: Bool ::: JSON -> (Handler r) Response ssoLoginH (req ::: persist ::: _) = do @@ -268,14 +282,18 @@ 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 +legalHoldLoginH :: + Members '[GalleyProvider] 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 '[GalleyProvider] 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 (_ ::: ut ::: at) = empty <$ logout ut at diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index db71c04406..3f2d171e8c 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -41,8 +41,13 @@ import Wire.API.User import qualified Wire.API.User as Public import Wire.API.User.Search import qualified Wire.API.User.Search as Public +import Polysemy +import Brig.Sem.GalleyProvider (GalleyProvider) -getHandleInfo :: UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) +getHandleInfo + :: + Members '[GalleyProvider] r => + UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -58,7 +63,11 @@ getRemoteHandleInfo handle = do . Log.field "domain" (show (tDomain handle)) Federation.getUserHandleInfo handle !>> fedError -getLocalHandleInfo :: Local UserId -> Handle -> (Handler r) (Maybe Public.UserProfile) +getLocalHandleInfo + :: + Members '[GalleyProvider] 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 @@ -66,7 +75,7 @@ getLocalHandleInfo self handle = do 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..657771a3bc 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -27,7 +27,6 @@ import Brig.API.Handler import Brig.App import qualified Brig.Data.User as DB import qualified Brig.Federation.Client as Federation -import qualified Brig.IO.Intra as Intra import qualified Brig.Options as Opts import Brig.Team.Util (ensurePermissions) import Brig.Types.Search as Search @@ -54,6 +53,9 @@ import qualified Wire.API.Team.Permission as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility (..)) import Wire.API.User.Search import qualified Wire.API.User.Search as Public +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Sem.GalleyProvider (GalleyProvider) +import Polysemy routesInternal :: Routes a (Handler r) () routesInternal = do @@ -82,7 +84,9 @@ 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 '[GalleyProvider] 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 +112,9 @@ 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. + Members '[GalleyProvider] 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 @@ -147,7 +153,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do then pure (Search.TeamOnly t) else do -- For team users, we need to check the visibility flag - handleTeamVisibility t <$> wrapHttp (Intra.getTeamSearchVisibility t) + handleTeamVisibility t <$> liftSem (GalleyProvider.getTeamSearchVisibility t) exactHandleSearch :: (Handler r) (Maybe Contact) exactHandleSearch = do @@ -159,6 +165,7 @@ searchLocally searcherId searchTerm maybeMaxResults = do <$$> HandleAPI.getLocalHandleInfo lsearcherId handle teamUserSearch :: + Members '[GalleyProvider] r => UserId -> TeamId -> Maybe Text -> diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index d85d778670..3f2dba30dc 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -49,7 +49,6 @@ import qualified Brig.Data.User as Data import Brig.Data.UserKey import qualified Brig.Data.UserKey as Data import Brig.Email -import qualified Brig.IO.Intra as Intra import qualified Brig.Options as Opt import Brig.Phone import Brig.Types.Intra @@ -79,6 +78,9 @@ import Wire.API.Team.Feature import qualified Wire.API.Team.Feature as Public import Wire.API.User import Wire.API.User.Auth +import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Polysemy +import Brig.Sem.GalleyProvider (GalleyProvider) data Access u = Access { accessToken :: !AccessToken, @@ -133,81 +135,66 @@ lookupLoginCode phone = 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. + Members '[GalleyProvider] 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 + uid <- wrapHttpClientE $ resolveLoginId li lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") - checkRetryLimit uid - Data.authenticate uid pw `catchE` \case + wrapHttpClientE $ checkRetryLimit uid + wrapHttpClientE $ Data.authenticate uid pw `catchE` \case AuthInvalidUser -> loginFailed uid AuthInvalidCredentials -> loginFailed uid AuthSuspended -> throwE LoginSuspended AuthEphemeral -> throwE LoginEphemeral AuthPendingInvitation -> throwE LoginPendingActivation verifyLoginCode code uid - newAccess @ZAuth.User @ZAuth.Access uid typ label + wrapHttpClientE $ newAccess @ZAuth.User @ZAuth.Access uid typ label where - verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError m () + verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) () verifyLoginCode mbCode uid = verifyCode mbCode Login uid `catchE` \case - VerificationCodeNoPendingCode -> loginFailedWith LoginCodeInvalid uid - VerificationCodeRequired -> loginFailedWith LoginCodeRequired uid - VerificationCodeNoEmail -> loginFailed uid + VerificationCodeNoPendingCode -> wrapHttpClientE $ loginFailedWith LoginCodeInvalid uid + VerificationCodeRequired -> wrapHttpClientE $ loginFailedWith LoginCodeRequired uid + VerificationCodeNoEmail -> wrapHttpClientE $ loginFailed uid login (SmsLogin phone code label) typ = do - uid <- resolveLoginId (LoginByPhone phone) + uid <- wrapHttpClientE $ resolveLoginId (LoginByPhone phone) lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") - checkRetryLimit uid - ok <- lift $ Data.verifyLoginCode uid code + wrapHttpClientE $ checkRetryLimit uid + ok <- wrapHttpClientE $ Data.verifyLoginCode uid code unless ok $ - loginFailed uid - newAccess @ZAuth.User @ZAuth.Access uid typ label + wrapHttpClientE $ loginFailed uid + wrapHttpClientE $ 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. + Members '[GalleyProvider] 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 <- liftSem $ GalleyProvider.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe (Public.wsStatus (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled when featureEnabled $ 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 <- isJust <$> wrapHttpClientE (Code.verify 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 + mbAccount <- wrapHttpClientE $ Data.lookupAccount u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -472,44 +459,29 @@ ssoLogin (SsoLogin uid label) typ = do -- | 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 '[GalleyProvider] 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 + wrapHttpClientE (Data.reauthenticate uid plainTextPassword) !>> LegalHoldReAuthError -- 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 $ GalleyProvider.getTeamId uid case mteam of Nothing -> throwE LegalHoldLoginNoBindingTeam Just tid -> assertLegalHoldEnabled tid -- create access token and cookie - newAccess @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess uid typ label + wrapHttpClientE (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 '[GalleyProvider] r => TeamId -> - ExceptT LegalHoldLoginError m () + ExceptT LegalHoldLoginError (AppT r) () assertLegalHoldEnabled tid = do - stat <- lift $ Intra.getTeamLegalHoldStatus tid + stat <- lift $ liftSem $ GalleyProvider.getTeamLegalHoldStatus tid case wsStatus stat of FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled FeatureStatusEnabled -> pure () diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index bd9ae04f2f..a43c043ca9 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -22,7 +22,7 @@ module Brig.User.EJPD (ejpdRequest) where import Brig.API.Handler import Brig.API.User (lookupHandle) -import Brig.App (AppT, wrapClient, wrapHttp) +import Brig.App (AppT, wrapClient, wrapHttp, liftSem) import qualified Brig.Data.Connection as Conn import Brig.Data.User (lookupUser) import qualified Brig.IO.Intra as Intra @@ -39,8 +39,11 @@ 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 qualified Brig.Sem.GalleyProvider as GalleyProvider +import Polysemy (Member) +import Brig.Sem.GalleyProvider (GalleyProvider) -ejpdRequest :: Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody +ejpdRequest :: forall r. Member GalleyProvider r => Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody ejpdRequest includeContacts (EJPDRequestBody handles) = do ExceptT $ Right . EJPDResponseBody . catMaybes <$> forM handles (go1 (fromMaybe False includeContacts)) where @@ -77,7 +80,7 @@ ejpdRequest includeContacts (EJPDRequestBody handles) = do mbTeamContacts <- case (includeContacts', userTeam target) of (True, Just tid) -> do - memberList <- wrapHttp $ Intra.getTeamMembers tid + memberList <- liftSem $ GalleyProvider.getTeamMembers tid let members = (view Team.userId <$> (memberList ^. Team.teamMembers)) \\ [uid] contactsFull :: [Maybe EJPDResponseItem] <- From 194640fe4f23e73702ac5e234437364dc588adbc Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 12:45:57 -0700 Subject: [PATCH 04/18] everything compiles --- services/brig/src/Brig/API.hs | 4 +- services/brig/src/Brig/API/Federation.hs | 66 +++++++------------ services/brig/src/Brig/API/Internal.hs | 35 +++++++--- .../brig/src/Brig/CanonicalInterpreter.hs | 8 +-- .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 5 +- 5 files changed, 60 insertions(+), 58 deletions(-) diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 61483fc0bb..1453818f56 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -30,13 +30,15 @@ import Brig.Sem.PasswordResetStore (PasswordResetStore) import qualified Data.Swagger.Build.Api as Doc import Network.Wai.Routing (Routes) import Polysemy +import Brig.Sem.GalleyProvider (GalleyProvider) sitemap :: Members '[ CodeStore, PasswordResetStore, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => Routes Doc.ApiBuilder (Handler r) () diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 716400e411..e583cb8a36 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 @@ -35,11 +33,8 @@ import qualified Brig.Data.User as Data 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) @@ -53,7 +48,6 @@ import Imports import Network.Wai.Utilities.Error ((!>>)) 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 @@ -69,18 +63,22 @@ import Wire.API.User.Client (PubClient, UserClientPrekeyMap) import Wire.API.User.Client.Prekey import Wire.API.User.Search import Wire.API.UserMap (UserMap) +import Brig.Sem.GalleyProvider (GalleyProvider) +import Polysemy (Members) type FederationAPI = "federation" :> BrigApi -federationSitemap :: ServerT FederationAPI (Handler r) +federationSitemap :: + Members '[ GalleyProvider + ] 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" (\d h -> getUserByHandle d h) + :<|> Named @"get-users-by-ids" (\d us -> getUsersByIds d us) :<|> 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" (\d sr -> searchUsers d sr) :<|> Named @"get-user-clients" getUserClients :<|> Named @"get-mls-clients" getMLSClients :<|> Named @"send-connection-action" sendConnectionAction @@ -100,16 +98,11 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do else pure NewConnectionResponseUserNotActivated getUserByHandle :: - ( HasRequestId m, - Log.MonadLogger m, - MonadClient m, - MonadHttp m, - MonadMask m, - MonadReader Env m - ) => - Domain -> + + Members '[ GalleyProvider + ] r => Domain -> Handle -> - ExceptT Error m (Maybe UserProfile) + ExceptT Error (AppT r) (Maybe UserProfile) getUserByHandle domain handle = do searchPolicy <- lookupSearchPolicy domain @@ -121,7 +114,7 @@ getUserByHandle domain handle = do if not performHandleLookup then pure Nothing else lift $ do - maybeOwnerId <- API.lookupHandle handle + maybeOwnerId <- wrapClient $ API.lookupHandle handle case maybeOwnerId of Nothing -> pure Nothing @@ -129,16 +122,10 @@ getUserByHandle domain handle = do listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] getUsersByIds :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - Domain -> + Members '[ GalleyProvider + ] r => Domain -> [UserId] -> - ExceptT Error m [UserProfile] + ExceptT Error (AppT r) [UserProfile] getUsersByIds _ uids = lift (API.lookupLocalProfiles Nothing uids) @@ -164,18 +151,11 @@ 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. + Members '[GalleyProvider] r => Domain -> SearchRequest -> - ExceptT Error m SearchResponse + ExceptT Error (AppT r) SearchResponse searchUsers domain (SearchRequest searchTerm) = do searchPolicy <- lift $ lookupSearchPolicy domain @@ -189,22 +169,22 @@ 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) (wrapHttpClientE . API.lookupHandle) maybeHandle case maybeOwnerId of Nothing -> pure [] Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index c2e871490f..4386c5caae 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -96,14 +96,20 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo +import Brig.Sem.GalleyProvider (GalleyProvider) --------------------------------------------------------------------------- -- Sitemap (servant) -servantSitemap :: Members '[BlacklistStore] r => ServerT BrigIRoutes.API (Handler r) +servantSitemap + :: Members '[BlacklistStore, + GalleyProvider] r + => ServerT BrigIRoutes.API (Handler r) servantSitemap = ejpdAPI :<|> accountAPI :<|> mlsAPI :<|> getVerificationCode :<|> teamsAPI :<|> userAPI -ejpdAPI :: ServerT BrigIRoutes.EJPD_API (Handler r) +ejpdAPI :: + Members '[ GalleyProvider + ] r => ServerT BrigIRoutes.EJPD_API (Handler r) ejpdAPI = Brig.User.EJPD.ejpdRequest :<|> Named @"get-account-conference-calling-config" getAccountConferenceCallingConfig @@ -125,7 +131,10 @@ mlsAPI = :<|> getMLSClients :<|> mapKeyPackageRefsInternal -accountAPI :: Member BlacklistStore r => ServerT BrigIRoutes.AccountAPI (Handler r) +accountAPI :: Members '[ + BlacklistStore, + GalleyProvider + ] r => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar @@ -214,7 +223,8 @@ sitemap :: '[ CodeStore, PasswordResetStore, BlacklistStore, - BlacklistPhonePrefixStore + BlacklistPhonePrefixStore, + GalleyProvider ] r => Routes a (Handler r) () @@ -380,12 +390,16 @@ sitemap = do -- Handlers -- | Add a client without authentication checks -addClientInternalH :: UserId ::: Maybe Bool ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> (Handler r) Response +addClientInternalH :: + Members '[ GalleyProvider + ] 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 '[ GalleyProvider + ] r => UserId -> Maybe Bool -> NewClient -> Maybe ConnId -> (Handler r) Client addClientInternal usr mSkipReAuth new connId = do let policy | mSkipReAuth == Just True = \_ _ -> False @@ -420,7 +434,10 @@ internalListFullClients :: UserSet -> (AppT r) UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> wrapClient (Data.lookupClientsBulk (Set.toList usrs)) -createUserNoVerify :: Member BlacklistStore r => NewUser -> (Handler r) (Either RegisterError SelfProfile) +createUserNoVerify :: Members '[ + BlacklistStore, + GalleyProvider + ] r => NewUser -> (Handler r) (Either RegisterError SelfProfile) createUserNoVerify uData = lift . runExceptT $ do result <- API.createUser uData let acc = createdAccount result @@ -434,7 +451,9 @@ 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 '[ GalleyProvider + ] r => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) createUserNoVerifySpar uData = lift . runExceptT $ do result <- API.createUserSpar uData diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 5caaf5c201..c129b19ae3 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -17,8 +17,8 @@ import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Brig.Sem.RPC.IO (interpretRpcToIO) import Brig.Sem.RPC (RPC) -import Brig.Sem.ServiceRPC -import Brig.Sem.ServiceRPC.IO (interpretServiceRpcToRpc) +import Brig.Sem.GalleyProvider (GalleyProvider) +import Brig.Sem.GalleyProvider.RPC (interpretGalleyProviderToRPC) type BrigCanonicalEffects = '[ BlacklistPhonePrefixStore, @@ -26,7 +26,7 @@ type BrigCanonicalEffects = PasswordResetStore, Now, CodeStore, - ServiceRPC 'Galley, + GalleyProvider, RPC, Embed Cas.Client, Embed IO, @@ -39,7 +39,7 @@ runBrigToIO e (AppT ma) = . embedToFinal . interpretClientToIO (e ^. casClient) . interpretRpcToIO (e ^. httpManager) (e ^. requestId) - . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) + . interpretGalleyProviderToRPC (e ^. galley) . codeStoreToCassandra @Cas.Client . nowToIOAction (e ^. currentTime) . passwordResetStoreToCodeStore diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs index 393f430dd8..79230530cd 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -6,10 +6,11 @@ import Brig.Sem.GalleyProvider import Brig.Sem.RPC import Polysemy import Imports +import Bilge (Request) -interpretGalleyProviderToRPC :: Member RPC r => Sem (GalleyProvider ': r) a -> Sem r a -interpretGalleyProviderToRPC = interpret undefined +interpretGalleyProviderToRPC :: Member RPC r => Request -> Sem (GalleyProvider ': r) a -> Sem r a +interpretGalleyProviderToRPC req = interpret undefined -- CreateSelfConv uid -> undefined -- CreateLocalConnectConv qwt qwt' m_txt m_ci -> undefined -- AcceptLocalConnectConv qwt m_ci uid -> undefined From e71e94168c511e38c284e7907572483589c120f5 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 12:51:20 -0700 Subject: [PATCH 05/18] make format --- services/brig/src/Brig/API.hs | 2 +- services/brig/src/Brig/API/Client.hs | 6 +- services/brig/src/Brig/API/Connection.hs | 14 +- services/brig/src/Brig/API/Federation.hs | 26 ++- services/brig/src/Brig/API/Internal.hs | 70 +++++--- services/brig/src/Brig/API/Public.hs | 156 +++++++++++++----- services/brig/src/Brig/API/User.hs | 45 +++-- .../brig/src/Brig/CanonicalInterpreter.hs | 8 +- services/brig/src/Brig/Provider/API.hs | 12 +- services/brig/src/Brig/Sem/GalleyProvider.hs | 49 +----- .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 5 +- services/brig/src/Brig/Sem/RPC/IO.hs | 18 +- services/brig/src/Brig/Sem/ServiceRPC/IO.hs | 22 +-- services/brig/src/Brig/Team/API.hs | 62 ++++--- services/brig/src/Brig/Team/Util.hs | 6 +- services/brig/src/Brig/User/API/Auth.hs | 33 ++-- services/brig/src/Brig/User/API/Handle.hs | 19 ++- services/brig/src/Brig/User/API/Search.hs | 20 ++- services/brig/src/Brig/User/Auth.hs | 19 ++- services/brig/src/Brig/User/EJPD.hs | 8 +- 20 files changed, 358 insertions(+), 242 deletions(-) diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 1453818f56..522831235d 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -26,11 +26,11 @@ import qualified Brig.API.Public as Public import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Sem.CodeStore +import Brig.Sem.GalleyProvider (GalleyProvider) import Brig.Sem.PasswordResetStore (PasswordResetStore) import qualified Data.Swagger.Build.Api as Doc import Network.Wai.Routing (Routes) import Polysemy -import Brig.Sem.GalleyProvider (GalleyProvider) sitemap :: Members diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 62edea9fa2..f3c89fa3fc 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -57,6 +57,8 @@ import qualified Brig.Federation.Client as Federation import Brig.IO.Intra (guardLegalhold) import qualified Brig.IO.Intra as Intra import qualified Brig.Options as Opt +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import Brig.Types.User.Event @@ -80,6 +82,7 @@ import Data.Qualified import qualified Data.Set as Set import Imports import Network.Wai.Utilities +import Polysemy (Members) import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO.Async (Concurrently (Concurrently, runConcurrently)) @@ -92,9 +95,6 @@ import qualified Wire.API.User as Code import Wire.API.User.Client import Wire.API.User.Client.Prekey import Wire.API.UserMap (QualifiedUserMap (QualifiedUserMap, qualifiedUserMap), UserMap (userMap)) -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Polysemy (Members) -import Brig.Sem.GalleyProvider (GalleyProvider) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) lookupLocalClient uid = wrapClient . Data.lookupClient uid diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 7b4da65074..ca2977f766 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -40,6 +40,8 @@ import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Types.Connection import Brig.Types.User.Event import Control.Error @@ -51,6 +53,7 @@ import Data.Qualified import Data.Range import qualified Data.UUID.V4 as UUID import Imports +import Polysemy (Members) import qualified System.Logger.Class as Log import System.Logger.Message import Wire.API.Connection hiding (relationWithHistory) @@ -58,9 +61,6 @@ import Wire.API.Conversation import Wire.API.Error import qualified Wire.API.Error.Brig as E import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..)) -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Polysemy (Members) -import Brig.Sem.GalleyProvider (GalleyProvider) ensureIsActivated :: Local UserId -> MaybeT (AppT r) () ensureIsActivated lusr = do @@ -183,9 +183,11 @@ 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 - :: Members '[GalleyProvider] r - => UserId -> UserId -> ExceptT ConnectionError (AppT r) () +checkLegalholdPolicyConflict :: + Members '[GalleyProvider] 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 diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index e583cb8a36..63d09b6a06 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -31,6 +31,7 @@ import Brig.App import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data import Brig.IO.Intra (notify) +import Brig.Sem.GalleyProvider (GalleyProvider) import Brig.Types.User.Event import Brig.User.API.Handle import qualified Brig.User.Search.SearchIndex as Q @@ -46,6 +47,7 @@ import Data.Range import qualified Gundeck.Types.Push as Push import Imports import Network.Wai.Utilities.Error ((!>>)) +import Polysemy (Members) import Servant (ServerT) import Servant.API import UnliftIO.Async (pooledForConcurrentlyN_) @@ -63,14 +65,15 @@ import Wire.API.User.Client (PubClient, UserClientPrekeyMap) import Wire.API.User.Client.Prekey import Wire.API.User.Search import Wire.API.UserMap (UserMap) -import Brig.Sem.GalleyProvider (GalleyProvider) -import Polysemy (Members) type FederationAPI = "federation" :> BrigApi federationSitemap :: - Members '[ GalleyProvider - ] r => ServerT FederationAPI (Handler r) + Members + '[ GalleyProvider + ] + r => + ServerT FederationAPI (Handler r) federationSitemap = Named @"api-version" (\_ _ -> pure versionInfo) :<|> Named @"get-user-by-handle" (\d h -> getUserByHandle d h) @@ -98,9 +101,11 @@ sendConnectionAction originDomain NewConnectionRequest {..} = do else pure NewConnectionResponseUserNotActivated getUserByHandle :: - - Members '[ GalleyProvider - ] r => Domain -> + Members + '[ GalleyProvider + ] + r => + Domain -> Handle -> ExceptT Error (AppT r) (Maybe UserProfile) getUserByHandle domain handle = do @@ -122,8 +127,11 @@ getUserByHandle domain handle = do listToMaybe <$> API.lookupLocalProfiles Nothing [ownerId] getUsersByIds :: - Members '[ GalleyProvider - ] r => Domain -> + Members + '[ GalleyProvider + ] + r => + Domain -> [UserId] -> ExceptT Error (AppT r) [UserProfile] getUsersByIds _ uids = diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 4386c5caae..78a36272e4 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -45,6 +45,7 @@ import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider import Brig.Sem.CodeStore (CodeStore) +import Brig.Sem.GalleyProvider (GalleyProvider) import Brig.Sem.PasswordResetStore (PasswordResetStore) import qualified Brig.Team.API as Team import Brig.Team.DB (lookupInvitationByEmail) @@ -96,20 +97,25 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo -import Brig.Sem.GalleyProvider (GalleyProvider) --------------------------------------------------------------------------- -- Sitemap (servant) -servantSitemap - :: Members '[BlacklistStore, - GalleyProvider] r - => ServerT BrigIRoutes.API (Handler r) +servantSitemap :: + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + ServerT BrigIRoutes.API (Handler r) servantSitemap = ejpdAPI :<|> accountAPI :<|> mlsAPI :<|> getVerificationCode :<|> teamsAPI :<|> userAPI ejpdAPI :: - Members '[ GalleyProvider - ] r => ServerT BrigIRoutes.EJPD_API (Handler r) + Members + '[ GalleyProvider + ] + r => + ServerT BrigIRoutes.EJPD_API (Handler r) ejpdAPI = Brig.User.EJPD.ejpdRequest :<|> Named @"get-account-conference-calling-config" getAccountConferenceCallingConfig @@ -131,10 +137,13 @@ mlsAPI = :<|> getMLSClients :<|> mapKeyPackageRefsInternal -accountAPI :: Members '[ - BlacklistStore, - GalleyProvider - ] r => ServerT BrigIRoutes.AccountAPI (Handler r) +accountAPI :: + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar @@ -391,15 +400,26 @@ sitemap = do -- | Add a client without authentication checks addClientInternalH :: - Members '[ GalleyProvider - ] r => UserId ::: Maybe Bool ::: JsonRequest NewClient ::: Maybe ConnId ::: JSON -> (Handler r) Response + Members + '[ GalleyProvider + ] + 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 :: - Members '[ GalleyProvider - ] r => UserId -> Maybe Bool -> NewClient -> Maybe ConnId -> (Handler r) Client + Members + '[ GalleyProvider + ] + r => + UserId -> + Maybe Bool -> + NewClient -> + Maybe ConnId -> + (Handler r) Client addClientInternal usr mSkipReAuth new connId = do let policy | mSkipReAuth == Just True = \_ _ -> False @@ -434,10 +454,14 @@ internalListFullClients :: UserSet -> (AppT r) UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> wrapClient (Data.lookupClientsBulk (Set.toList usrs)) -createUserNoVerify :: Members '[ - BlacklistStore, - GalleyProvider - ] r => NewUser -> (Handler r) (Either RegisterError SelfProfile) +createUserNoVerify :: + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + NewUser -> + (Handler r) (Either RegisterError SelfProfile) createUserNoVerify uData = lift . runExceptT $ do result <- API.createUser uData let acc = createdAccount result @@ -452,8 +476,12 @@ createUserNoVerify uData = lift . runExceptT $ do pure . SelfProfile $ usr createUserNoVerifySpar :: - Members '[ GalleyProvider - ] r => NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) + Members + '[ GalleyProvider + ] + r => + NewUserSpar -> + (Handler r) (Either CreateUserSparError SelfProfile) createUserNoVerifySpar uData = lift . runExceptT $ do result <- API.createUserSpar uData diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 61f21773b7..94b99058ac 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -49,6 +49,8 @@ import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider import Brig.Sem.CodeStore (CodeStore) +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Sem.PasswordResetStore (PasswordResetStore) import qualified Brig.Team.API as Team import qualified Brig.Team.Email as Team @@ -135,8 +137,6 @@ 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 qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.GalleyProvider (GalleyProvider) -- User API ----------------------------------------------------------- @@ -547,8 +547,15 @@ getMultiUserPrekeyBundleH zusr qualUserClients = do API.claimMultiPrekeyBundles (ProtectedUser zusr) qualUserClients !>> clientError addClient :: - Members '[ GalleyProvider - ] r => UserId -> ConnId -> Maybe IpAddr -> Public.NewClient -> (Handler r) NewClientResponse + Members + '[ GalleyProvider + ] + 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) $ @@ -631,10 +638,14 @@ newNonce _ = do pure nonce -- | docs/reference/user/registration.md {#RefRegistration} -createUser :: Members '[BlacklistStore, - GalleyProvider - ] r - => Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) +createUser :: + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + Public.NewUserPublic -> + (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 @@ -709,23 +720,39 @@ getSelf self = >>= ifNothing (errorToWai @'E.UserNotFound) getUserUnqualifiedH :: - Members '[ GalleyProvider - ] r => UserId -> UserId -> (Handler r) (Maybe Public.UserProfile) + Members + '[ GalleyProvider + ] + r => + UserId -> + UserId -> + (Handler r) (Maybe Public.UserProfile) getUserUnqualifiedH self uid = do domain <- viewFederationDomain getUser self (Qualified uid domain) getUser :: - Members '[ GalleyProvider - ] r => UserId -> Qualified UserId -> (Handler r) (Maybe Public.UserProfile) + Members + '[ GalleyProvider + ] + r => + UserId -> + Qualified UserId -> + (Handler r) (Maybe Public.UserProfile) getUser self qualifiedUserId = do lself <- qualifyLocal self API.lookupProfile lself qualifiedUserId !>> fedError -- FUTUREWORK: Make servant understand that at least one of these is required listUsersByUnqualifiedIdsOrHandles :: - Members '[ GalleyProvider - ] r => UserId -> Maybe (CommaSeparatedList UserId) -> Maybe (Range 1 4 (CommaSeparatedList Handle)) -> (Handler r) [Public.UserProfile] + Members + '[ GalleyProvider + ] + 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 @@ -741,9 +768,15 @@ 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 :: forall r. - Members '[ GalleyProvider - ] r => UserId -> Public.ListUsersQuery -> (Handler r) [Public.UserProfile] +listUsersByIdsOrHandles :: + forall r. + Members + '[ GalleyProvider + ] + r => + UserId -> + Public.ListUsersQuery -> + (Handler r) [Public.UserProfile] listUsersByIdsOrHandles self q = do lself <- qualifyLocal self foundUsers <- case q of @@ -830,8 +863,13 @@ checkHandles _ (Public.CheckHandles hs num) = do -- 'Handle.getHandleInfo') returns UserProfile to reduce traffic between backends -- in a federated scenario. getHandleInfoUnqualifiedH :: - Members '[ GalleyProvider - ] r => UserId -> Handle -> (Handler r) (Maybe Public.UserHandleInfo) + Members + '[ GalleyProvider + ] + r => + UserId -> + Handle -> + (Handler r) (Maybe Public.UserHandleInfo) getHandleInfoUnqualifiedH self handle = do domain <- viewFederationDomain Public.UserHandleInfo . Public.profileQualifiedId @@ -873,7 +911,8 @@ completePasswordResetH (_ ::: req) = do sendActivationCodeH :: Members '[ BlacklistStore, - BlacklistPhonePrefixStore, GalleyProvider + BlacklistPhonePrefixStore, + GalleyProvider ] r => JsonRequest Public.SendActivationCode -> @@ -886,7 +925,8 @@ sendActivationCodeH req = sendActivationCode :: Members '[ BlacklistStore, - BlacklistPhonePrefixStore, GalleyProvider + BlacklistPhonePrefixStore, + GalleyProvider ] r => Public.SendActivationCode -> @@ -912,16 +952,28 @@ customerExtensionCheckBlockedDomains email = do throwM $ customerExtensionBlockedDomain domain createConnectionUnqualified :: - Members '[ GalleyProvider - ] r => UserId -> ConnId -> Public.ConnectionRequest -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) + Members + '[ GalleyProvider + ] + 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 :: - Members '[ GalleyProvider - ] r => UserId -> ConnId -> Qualified UserId -> (Handler r) (Public.ResponseForExistedCreated Public.UserConnection) + Members + '[ GalleyProvider + ] + 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 @@ -997,9 +1049,11 @@ getConnection self other = do lift . wrapClient $ Data.lookupConnection lself other deleteSelfUser :: - - Members '[ GalleyProvider - ] r => UserId -> + Members + '[ GalleyProvider + ] + r => + UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) deleteSelfUser u body = @@ -1011,9 +1065,17 @@ verifyDeleteUserH (r ::: _) = do API.verifyDeleteUser body !>> deleteUserError pure (setStatus status200 empty) -updateUserEmail :: forall r. Members '[BlacklistStore, - GalleyProvider ] - r => UserId -> UserId -> Public.EmailUpdate -> (Handler r) () +updateUserEmail :: + forall r. + Members + '[ BlacklistStore, + GalleyProvider + ] + 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 @@ -1051,22 +1113,34 @@ respFromActivationRespWithStatus = \case -- docs/reference/user/activation.md {#RefActivationSubmit} activateKeyH :: - Members '[ GalleyProvider - ] r => JSON ::: JsonRequest Public.Activate -> (Handler r) Response + Members + '[ GalleyProvider + ] + r => + JSON ::: JsonRequest Public.Activate -> + (Handler r) Response activateKeyH (_ ::: req) = do activationRequest <- parseJsonBody req respFromActivationRespWithStatus <$> activate activationRequest activateH :: - Members '[ GalleyProvider - ] r => Public.ActivationKey ::: Public.ActivationCode -> (Handler r) Response + Members + '[ GalleyProvider + ] + r => + Public.ActivationKey ::: Public.ActivationCode -> + (Handler r) Response activateH (k ::: c) = do let activationRequest = Public.Activate (Public.ActivateKey k) c False respFromActivationRespWithStatus <$> activate activationRequest activate :: - Members '[ GalleyProvider - ] r => Public.Activate -> (Handler r) ActivationRespWithStatus + Members + '[ GalleyProvider + ] + r => + Public.Activate -> + (Handler r) ActivationRespWithStatus activate (Public.Activate tgt code dryrun) | dryrun = do wrapClientE (API.preverify tgt code) !>> actError @@ -1082,8 +1156,12 @@ activate (Public.Activate tgt code dryrun) sendVerificationCode :: forall r. - Members '[ GalleyProvider - ] r => Public.SendVerificationCode -> (Handler r) () + Members + '[ GalleyProvider + ] + r => + Public.SendVerificationCode -> + (Handler r) () sendVerificationCode req = do let email = Public.svcEmail req let action = Public.svcAction req diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 9ab3d19175..2633f66d34 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -120,6 +120,8 @@ import Brig.Password import qualified Brig.Queue as Queue import Brig.Sem.CodeStore (CodeStore) import qualified Brig.Sem.CodeStore as E +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Sem.PasswordResetStore (PasswordResetStore) import qualified Brig.Sem.PasswordResetStore as E import qualified Brig.Team.DB as Team @@ -180,8 +182,6 @@ import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password import Wire.API.User.RichInfo -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.GalleyProvider (GalleyProvider) data AllowSCIMUpdates = AllowSCIMUpdates @@ -220,10 +220,14 @@ verifyUniquenessAndCheckBlacklist uk = do unless av $ throwE IdentityErrorUserKeyExists -createUserSpar :: forall r. Members - '[GalleyProvider - ] r - => NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult +createUserSpar :: + forall r. + Members + '[ GalleyProvider + ] + r => + NewUserSpar -> + ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do let handle' = newUserSparHandle new new' = newUserFromSpar new @@ -282,12 +286,15 @@ createUserSpar new = do pure $ CreateUserTeam tid nm -- docs/reference/user/registration.md {#RefRegistration} -createUser - :: forall r. - Members '[ BlacklistStore - , GalleyProvider - ] r - => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult +createUser :: + forall r. + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + NewUser -> + ExceptT RegisterError (AppT r) CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -1144,9 +1151,15 @@ 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 :: forall r. Members - '[GalleyProvider - ] r => UserId -> Maybe PlainTextPassword -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) +deleteSelfUser :: + forall r. + Members + '[ GalleyProvider + ] + r => + UserId -> + Maybe PlainTextPassword -> + ExceptT DeleteUserError (AppT r) (Maybe Timeout) deleteSelfUser uid pwd = do account <- lift . wrapClient $ Data.lookupAccount uid case account of @@ -1403,7 +1416,7 @@ lookupRemoteProfiles (qUntagged -> Qualified uids domain) = -- pure function and writing tests for that. lookupLocalProfiles :: forall r. - Members '[GalleyProvider] r => + Members '[GalleyProvider] r => -- | This is present only when an authenticated user is requesting access. Maybe UserId -> -- | The users ('others') for which to obtain the profiles. diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index c129b19ae3..e3fce1e667 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -7,18 +7,18 @@ import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) import Brig.Sem.CodeStore (CodeStore) import Brig.Sem.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) +import Brig.Sem.GalleyProvider (GalleyProvider) +import Brig.Sem.GalleyProvider.RPC (interpretGalleyProviderToRPC) import Brig.Sem.PasswordResetStore (PasswordResetStore) import Brig.Sem.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) +import Brig.Sem.RPC (RPC) +import Brig.Sem.RPC.IO (interpretRpcToIO) import qualified Cassandra as Cas import Control.Lens ((^.)) import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) -import Brig.Sem.RPC.IO (interpretRpcToIO) -import Brig.Sem.RPC (RPC) -import Brig.Sem.GalleyProvider (GalleyProvider) -import Brig.Sem.GalleyProvider.RPC (interpretGalleyProviderToRPC) type BrigCanonicalEffects = '[ BlacklistPhonePrefixStore, diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index ee326d03d2..238c8c07ac 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -46,6 +46,8 @@ import qualified Brig.Provider.DB as DB import Brig.Provider.Email import qualified Brig.Provider.RPC as RPC import qualified Brig.Queue as Queue +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Team.Util import Brig.Types.Intra (AccountStatus (..), UserAccount (..)) import Brig.Types.User @@ -90,6 +92,7 @@ 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 (Members) import qualified Ssl.Util as SSL import System.Logger.Class (MonadLogger) import UnliftIO.Async (pooledMapConcurrentlyN_) @@ -119,9 +122,6 @@ 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) -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.GalleyProvider (GalleyProvider) -import Polysemy (Members) routesPublic :: Members '[GalleyProvider] r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do @@ -715,7 +715,8 @@ finishDeleteService pid sid = do kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid deleteAccountH :: - Members '[GalleyProvider] r => ProviderId ::: JsonRequest Public.DeleteProvider -> + Members '[GalleyProvider] r => + ProviderId ::: JsonRequest Public.DeleteProvider -> ExceptT Error (AppT r) Response deleteAccountH (pid ::: req) = do guardSecondFactorDisabled Nothing @@ -795,7 +796,8 @@ searchServiceProfiles Nothing Nothing _ = do throwStd $ badRequest "At least `tags` or `start` must be provided." searchTeamServiceProfilesH :: - Members '[GalleyProvider] r => UserId ::: TeamId ::: Maybe (Range 1 128 Text) ::: Bool ::: Range 10 100 Int32 -> + Members '[GalleyProvider] r => + UserId ::: TeamId ::: Maybe (Range 1 128 Text) ::: Bool ::: Range 10 100 Int32 -> (Handler r) Response searchTeamServiceProfilesH (uid ::: tid ::: prefix ::: filterDisabled ::: size) = do guardSecondFactorDisabled (Just uid) diff --git a/services/brig/src/Brig/Sem/GalleyProvider.hs b/services/brig/src/Brig/Sem/GalleyProvider.hs index 90e13839ef..6bdcd720c9 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider.hs @@ -2,7 +2,6 @@ module Brig.Sem.GalleyProvider where -import Polysemy import Brig.API.Types import qualified Data.Currency as Currency import Data.Id @@ -11,6 +10,7 @@ import Data.Qualified import qualified Galley.Types.Teams.Intra as Team import Imports import qualified Network.Wai.Utilities.Error as Wai +import Polysemy import Wire.API.Conversation import Wire.API.Team import qualified Wire.API.Team.Conversation as Conv @@ -20,151 +20,104 @@ import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.User - data GalleyProvider m a where CreateSelfConv :: UserId -> GalleyProvider m () - - CreateLocalConnectConv :: Local UserId -> Local UserId -> Maybe Text -> Maybe ConnId -> GalleyProvider m ConvId - - AcceptLocalConnectConv :: Local UserId -> Maybe ConnId -> ConvId -> GalleyProvider m Conversation - - BlockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> GalleyProvider m () - - UnblockLocalConv :: Local UserId -> Maybe ConnId -> ConvId -> GalleyProvider m Conversation - - GetConv :: UserId -> ConvId -> GalleyProvider m (Maybe Conversation) - - GetTeamConv :: UserId -> TeamId -> ConvId -> GalleyProvider m (Maybe Conv.TeamConversation) - - RmUser :: UserId -> [Asset] -> GalleyProvider m () - - NewClient :: UserId -> ClientId -> GalleyProvider m () - - RmClient :: UserId -> ClientId -> GalleyProvider m () - - CheckUserCanJoinTeam :: TeamId -> GalleyProvider m (Maybe Wai.Error) - - AddTeamMember :: UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Role) -> GalleyProvider m Bool - - CreateTeam :: UserId -> BindingNewTeam -> TeamId -> GalleyProvider m CreateUserTeam - - GetTeamMember :: UserId -> TeamId -> GalleyProvider m (Maybe Team.TeamMember) - GetTeamMembers :: TeamId -> GalleyProvider m Team.TeamMemberList - - GetTeamContacts :: UserId -> GalleyProvider m (Maybe Team.TeamMemberList) - - GetTeamId :: UserId -> GalleyProvider m (Maybe TeamId) - - GetTeam :: TeamId -> GalleyProvider m Team.TeamData - - GetTeamName :: TeamId -> GalleyProvider m Team.TeamName - - GetTeamLegalHoldStatus :: TeamId -> GalleyProvider m (WithStatus LegalholdConfig) - - GetTeamSearchVisibility :: TeamId -> GalleyProvider m TeamSearchVisibility - - ChangeTeamStatus :: TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> GalleyProvider m () - - MemberIsTeamOwner :: TeamId -> UserId -> GalleyProvider m Bool - GetAllFeatureConfigsForUser :: Maybe UserId -> GalleyProvider m AllFeatureConfigs - GetVerificationCodeEnabled :: TeamId -> GalleyProvider m Bool makeSem ''GalleyProvider - diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs index 79230530cd..036c614fc4 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -2,12 +2,11 @@ module Brig.Sem.GalleyProvider.RPC where +import Bilge (Request) import Brig.Sem.GalleyProvider import Brig.Sem.RPC -import Polysemy import Imports -import Bilge (Request) - +import Polysemy interpretGalleyProviderToRPC :: Member RPC r => Request -> Sem (GalleyProvider ': r) a -> Sem r a interpretGalleyProviderToRPC req = interpret undefined diff --git a/services/brig/src/Brig/Sem/RPC/IO.hs b/services/brig/src/Brig/Sem/RPC/IO.hs index 69245a485a..caacc0d77a 100644 --- a/services/brig/src/Brig/Sem/RPC/IO.hs +++ b/services/brig/src/Brig/Sem/RPC/IO.hs @@ -2,23 +2,22 @@ module Brig.Sem.RPC.IO where -import Brig.Sem.RPC -import Polysemy -import Imports -import qualified Brig.RPC as RPC import Bilge (HttpT, MonadHttp, RequestId) -import Control.Monad.Catch +import Bilge.IO (Manager, runHttpT) import Bilge.RPC -import Bilge.IO (runHttpT, Manager) +import qualified Brig.RPC as RPC +import Brig.Sem.RPC +import Control.Monad.Catch +import Imports +import Polysemy interpretRpcToIO :: Members '[Final IO] r => Manager -> RequestId -> Sem (RPC ': r) a -> Sem r a interpretRpcToIO mgr rid = interpret $ \case ServiceRequest txt f sm g -> - embedFinal @IO $ viaHttpIO mgr rid $ RPC.serviceRequestImpl txt f sm g - + embedFinal @IO $ viaHttpIO mgr rid $ RPC.serviceRequestImpl txt f sm g viaHttpIO :: Manager -> RequestId -> HttpIO a -> IO a -viaHttpIO mgr rid = runHttpT mgr . flip runReaderT rid . runHttpIO +viaHttpIO mgr rid = runHttpT mgr . flip runReaderT rid . runHttpIO newtype HttpIO a = HttpIO { runHttpIO :: ReaderT RequestId (HttpT IO) a @@ -37,4 +36,3 @@ newtype HttpIO a = HttpIO instance HasRequestId HttpIO where getRequestId = HttpIO ask - diff --git a/services/brig/src/Brig/Sem/ServiceRPC/IO.hs b/services/brig/src/Brig/Sem/ServiceRPC/IO.hs index 9a181f8f03..449bee9b23 100644 --- a/services/brig/src/Brig/Sem/ServiceRPC/IO.hs +++ b/services/brig/src/Brig/Sem/ServiceRPC/IO.hs @@ -1,18 +1,18 @@ module Brig.Sem.ServiceRPC.IO where -import Brig.Sem.ServiceRPC - -import Brig.Sem.RPC -import Polysemy -import Imports import Bilge (Request) +import Brig.Sem.RPC +import Brig.Sem.ServiceRPC import qualified Data.Text.Lazy as LT +import Imports +import Polysemy - -interpretServiceRpcToRpc - :: forall service r a - . Member RPC r - => LT.Text - -> Request -> Sem (ServiceRPC service ': r) a -> Sem r a +interpretServiceRpcToRpc :: + forall service r a. + Member RPC r => + LT.Text -> + Request -> + Sem (ServiceRPC service ': r) a -> + Sem r a interpretServiceRpcToRpc lt r = interpret $ \case Request sm f -> serviceRequest lt r sm f diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index cff0d3ad75..f2a340ccc5 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -34,6 +34,8 @@ import qualified Brig.Effects.BlacklistStore as BlacklistStore import qualified Brig.Email as Email import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import qualified Brig.Phone as Phone +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import qualified Brig.Team.DB as DB import Brig.Team.Email import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) @@ -76,13 +78,14 @@ 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 qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.GalleyProvider (GalleyProvider) -routesPublic - :: Members '[BlacklistStore - , GalleyProvider - ] r => Routes Doc.ApiBuilder (Handler r) () +routesPublic :: + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + Routes Doc.ApiBuilder (Handler r) () routesPublic = do post "/teams/:tid/invitations" (continue createInvitationPublicH) $ accept "application" "json" @@ -193,10 +196,12 @@ routesPublic = do Doc.response 403 "No permission (not admin or owner of this team)." Doc.end routesInternal :: - Members '[BlacklistStore - , GalleyProvider - ] r - => Routes a (Handler r) () + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + Routes a (Handler r) () routesInternal = do get "/i/teams/invitations/by-email" (continue getInvitationByEmailH) $ accept "application" "json" @@ -253,10 +258,13 @@ instance ToJSON FoundInvitationCode where toJSON (FoundInvitationCode c) = object ["code" .= c] createInvitationPublicH :: - Members '[BlacklistStore - , GalleyProvider - ] r - => JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> (Handler r) Response + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + JSON ::: UserId ::: TeamId ::: JsonRequest Public.InvitationRequest -> + (Handler r) Response createInvitationPublicH (_ ::: uid ::: tid ::: req) = do body <- parseJsonBody req newInv <- createInvitationPublic uid tid body @@ -273,10 +281,15 @@ data CreateInvitationInviter = CreateInvitationInviter deriving (Eq, Show) createInvitationPublic :: - Members '[BlacklistStore - , GalleyProvider - ] r - => UserId -> TeamId -> Public.InvitationRequest -> Handler r Public.Invitation + Members + '[ BlacklistStore, + GalleyProvider + ] + r => + UserId -> + TeamId -> + Public.InvitationRequest -> + Handler r Public.Invitation createInvitationPublic uid tid body = do let inviteeRole = fromMaybe defaultRole . irRole $ body inviter <- do @@ -463,13 +476,15 @@ suspendTeam tid = do unsuspendTeamH :: Members '[GalleyProvider] r => - JSON ::: TeamId -> (Handler r) Response + JSON ::: TeamId -> + (Handler r) Response unsuspendTeamH (_ ::: tid) = do empty <$ unsuspendTeam tid unsuspendTeam :: Members '[GalleyProvider] r => - TeamId -> (Handler r) () + TeamId -> + (Handler r) () unsuspendTeam tid = do changeTeamAccountStatuses tid Active lift $ liftSem $ GalleyProvider.changeTeamStatus tid Team.Active Nothing @@ -477,10 +492,11 @@ unsuspendTeam tid = do ------------------------------------------------------------------------------- -- Internal -changeTeamAccountStatuses - :: +changeTeamAccountStatuses :: Members '[GalleyProvider] r => - TeamId -> AccountStatus -> (Handler r) () + TeamId -> + AccountStatus -> + (Handler r) () changeTeamAccountStatuses tid s = do team <- Team.tdTeam <$> lift (liftSem $ GalleyProvider.getTeam tid) unless (team ^. teamBinding == Binding) $ diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 07eb31cdd6..e768b4013f 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -19,17 +19,17 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Control.Error import Control.Lens import Data.Id import qualified Data.Set as Set import Galley.Types.Teams import Imports +import Polysemy (Member) import Wire.API.Team.Member import Wire.API.Team.Permission -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Polysemy (Member) -import Brig.Sem.GalleyProvider (GalleyProvider) ensurePermissions :: Member GalleyProvider r => UserId -> TeamId -> [Perm] -> ExceptT Error (AppT r) () ensurePermissions u t perms = do diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 474c8e6004..ff75fc24f9 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -28,6 +28,7 @@ import qualified Brig.API.User as User import Brig.App import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Phone +import Brig.Sem.GalleyProvider (GalleyProvider) import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction, reAuthPassword) import Brig.Types.User.Auth import qualified Brig.User.Auth as Auth @@ -64,12 +65,13 @@ import qualified Wire.API.Error.Brig as E import qualified Wire.API.User as Public import Wire.API.User.Auth as Public import Wire.Swagger as Doc (pendingLoginError) -import Brig.Sem.GalleyProvider (GalleyProvider) routesPublic :: - Members '[ BlacklistStore - , GalleyProvider - ] r => + Members + '[ BlacklistStore, + GalleyProvider + ] + r => Routes Doc.ApiBuilder (Handler r) () routesPublic = do -- Note: this endpoint should always remain available at its unversioned @@ -240,15 +242,17 @@ getLoginCode phone = do reAuthUserH :: Members '[GalleyProvider] r => - UserId ::: JsonRequest ReAuthUser -> (Handler r) Response + UserId ::: JsonRequest ReAuthUser -> + (Handler r) Response reAuthUserH (uid ::: req) = do reAuthUser uid =<< parseJsonBody req pure empty -reAuthUser - :: +reAuthUser :: Members '[GalleyProvider] r => - UserId -> ReAuthUser -> (Handler r) () + UserId -> + ReAuthUser -> + (Handler r) () reAuthUser uid body = do wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError case reAuthCodeAction body of @@ -262,13 +266,16 @@ reAuthUser uid body = do loginH :: Members '[GalleyProvider] r => - JsonRequest Public.Login ::: Bool ::: JSON -> (Handler r) Response + JsonRequest Public.Login ::: Bool ::: JSON -> + (Handler r) Response loginH (req ::: persist ::: _) = do lift . tokenResponse =<< flip login persist =<< parseJsonBody req login :: Members '[GalleyProvider] r => - Public.Login -> Bool -> (Handler r) (Auth.Access ZAuth.User) + Public.Login -> + Bool -> + (Handler r) (Auth.Access ZAuth.User) login l persist = do let typ = if persist then PersistentCookie else SessionCookie Auth.login l typ !>> loginError @@ -284,13 +291,15 @@ ssoLogin l persist = do legalHoldLoginH :: Members '[GalleyProvider] r => - JsonRequest LegalHoldLogin ::: JSON -> (Handler r) Response + JsonRequest LegalHoldLogin ::: JSON -> + (Handler r) Response legalHoldLoginH (req ::: _) = do lift . tokenResponse =<< legalHoldLogin =<< parseJsonBody req legalHoldLogin :: Members '[GalleyProvider] r => - LegalHoldLogin -> (Handler r) (Auth.Access ZAuth.LegalHoldUser) + LegalHoldLogin -> + (Handler r) (Auth.Access ZAuth.LegalHoldUser) legalHoldLogin l = do let typ = PersistentCookie -- Session cookie isn't a supported use case here Auth.legalHoldLogin l typ !>> legalHoldLoginError diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 3f2d171e8c..2f0edf550a 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -30,24 +30,25 @@ import Brig.App import qualified Brig.Data.User as Data import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) +import Brig.Sem.GalleyProvider (GalleyProvider) import Control.Lens (view) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) import Data.Qualified import Imports import Network.Wai.Utilities ((!>>)) +import Polysemy 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 -import Polysemy -import Brig.Sem.GalleyProvider (GalleyProvider) -getHandleInfo - :: +getHandleInfo :: Members '[GalleyProvider] r => - UserId -> Qualified Handle -> (Handler r) (Maybe Public.UserProfile) + UserId -> + Qualified Handle -> + (Handler r) (Maybe Public.UserProfile) getHandleInfo self handle = do lself <- qualifyLocal self foldQualified @@ -63,11 +64,11 @@ getRemoteHandleInfo handle = do . Log.field "domain" (show (tDomain handle)) Federation.getUserHandleInfo handle !>> fedError -getLocalHandleInfo - :: +getLocalHandleInfo :: Members '[GalleyProvider] r => - Local UserId - -> Handle -> (Handler r) (Maybe Public.UserProfile) + 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 diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 657771a3bc..e6948a37b5 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -28,6 +28,8 @@ import Brig.App import qualified Brig.Data.User as DB import qualified Brig.Federation.Client as Federation import qualified Brig.Options as Opts +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Team.Util (ensurePermissions) import Brig.Types.Search as Search import qualified Brig.User.API.Handle as HandleAPI @@ -44,6 +46,7 @@ import Imports import Network.Wai.Routing import Network.Wai.Utilities ((!>>)) import Network.Wai.Utilities.Response (empty) +import Polysemy import System.Logger (field, msg) import System.Logger.Class (val, (~~)) import qualified System.Logger.Class as Log @@ -53,9 +56,6 @@ import qualified Wire.API.Team.Permission as Public import Wire.API.Team.SearchVisibility (TeamSearchVisibility (..)) import Wire.API.User.Search import qualified Wire.API.User.Search as Public -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.GalleyProvider (GalleyProvider) -import Polysemy routesInternal :: Routes a (Handler r) () routesInternal = do @@ -86,7 +86,11 @@ routesInternal = do -- for all results. This is tracked in https://wearezeta.atlassian.net/browse/SQCORE-599 search :: Members '[GalleyProvider] r => - UserId -> Text -> Maybe Domain -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) + 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 @@ -112,9 +116,13 @@ searchRemotely domain searchTerm = do searchPolicy = S.searchPolicy searchResponse } -searchLocally :: forall r. +searchLocally :: + forall r. Members '[GalleyProvider] r => - UserId -> Text -> Maybe (Range 1 500 Int32) -> (Handler r) (Public.SearchResult Public.Contact) + 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 diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 3f2dba30dc..c62989318e 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -51,6 +51,8 @@ import qualified Brig.Data.UserKey as Data import Brig.Email import qualified Brig.Options as Opt import Brig.Phone +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Types.Intra import Brig.Types.User.Auth import Brig.User.Auth.Cookie @@ -72,15 +74,13 @@ import Data.Misc (PlainTextPassword (..)) import qualified Data.ZAuth.Token as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) +import Polysemy 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 qualified Brig.Sem.GalleyProvider as GalleyProvider -import Polysemy -import Brig.Sem.GalleyProvider (GalleyProvider) data Access u = Access { accessToken :: !AccessToken, @@ -144,12 +144,13 @@ login (PasswordLogin li pw label code) typ = do uid <- wrapHttpClientE $ resolveLoginId li lift . Log.debug $ field "user" (toByteString uid) . field "action" (Log.val "User.login") wrapHttpClientE $ checkRetryLimit uid - wrapHttpClientE $ Data.authenticate uid pw `catchE` \case - AuthInvalidUser -> loginFailed uid - AuthInvalidCredentials -> loginFailed uid - AuthSuspended -> throwE LoginSuspended - AuthEphemeral -> throwE LoginEphemeral - AuthPendingInvitation -> throwE LoginPendingActivation + wrapHttpClientE $ + Data.authenticate uid pw `catchE` \case + AuthInvalidUser -> loginFailed uid + AuthInvalidCredentials -> loginFailed uid + AuthSuspended -> throwE LoginSuspended + AuthEphemeral -> throwE LoginEphemeral + AuthPendingInvitation -> throwE LoginPendingActivation verifyLoginCode code uid wrapHttpClientE $ newAccess @ZAuth.User @ZAuth.Access uid typ label where diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index a43c043ca9..4f2537d66a 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -22,10 +22,12 @@ module Brig.User.EJPD (ejpdRequest) where import Brig.API.Handler import Brig.API.User (lookupHandle) -import Brig.App (AppT, wrapClient, wrapHttp, liftSem) +import Brig.App (AppT, liftSem, wrapClient, wrapHttp) import qualified Brig.Data.Connection as Conn import Brig.Data.User (lookupUser) import qualified Brig.IO.Intra as Intra +import Brig.Sem.GalleyProvider (GalleyProvider) +import qualified Brig.Sem.GalleyProvider as GalleyProvider import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error hiding (bool) import Control.Lens (view, (^.)) @@ -33,15 +35,13 @@ import Data.Handle (Handle) import Data.Id (UserId) import qualified Data.Set as Set import Imports hiding (head) +import Polysemy (Member) 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 qualified Brig.Sem.GalleyProvider as GalleyProvider -import Polysemy (Member) -import Brig.Sem.GalleyProvider (GalleyProvider) ejpdRequest :: forall r. Member GalleyProvider r => Maybe Bool -> EJPDRequestBody -> (Handler r) EJPDResponseBody ejpdRequest includeContacts (EJPDRequestBody handles) = do From e6eb18f80abb7f918d4273d3a156b7a692966a46 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 13:06:44 -0700 Subject: [PATCH 06/18] move RPC calls into interpreter --- services/brig/src/Brig/IO/Intra.hs | 425 +-------------- services/brig/src/Brig/Sem/GalleyProvider.hs | 9 - .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 498 +++++++++++++++++- 3 files changed, 473 insertions(+), 459 deletions(-) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 65de3c986e..d1fb08493c 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -95,13 +95,11 @@ 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) import qualified Data.Conduit.List as C -import qualified Data.Currency as Currency import Data.Domain import Data.Either.Combinators (whenLeft) import Data.Id -import Data.Json.Util (UTCTimeMillis, (#)) +import Data.Json.Util ((#)) import Data.List.Split (chunksOf) import Data.List1 (List1, list1, singleton) import Data.Proxy @@ -110,15 +108,12 @@ 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 import Galley.Types.Teams.Intra (GuardLegalholdPolicyConflicts (GuardLegalholdPolicyConflicts)) -import qualified Galley.Types.Teams.Intra as Team import Gundeck.Types.Push.V2 import qualified Gundeck.Types.Push.V2 as Push import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status -import qualified Network.Wai.Utilities.Error as Wai import System.Logger.Class as Log hiding (name, (.=)) import qualified System.Logger.Extended as ExLog import Wire.API.Connection @@ -127,14 +122,8 @@ 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 import Wire.API.Team.LegalHold (LegalholdProtectee) -import qualified Wire.API.Team.Member as Member import qualified Wire.API.Team.Member as Team -import Wire.API.Team.Role -import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Client @@ -697,28 +686,6 @@ toApsData _ = Nothing ------------------------------------------------------------------------------- -- Conversation Management --- | Calls 'Galley.API.createSelfConversationH'. -createSelfConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - m () -createSelfConv u = do - debug $ - remote "galley" - . msg (val "Creating self conversation") - void $ galleyRequest POST req - where - req = - path "/conversations/self" - . zUser u - . expect2xx - -- | Calls 'Galley.API.Create.createConnectConversation'. createLocalConnectConv :: ( MonadReader Env m, @@ -883,33 +850,6 @@ unblockConv luid conn = (unblockLocalConv luid conn . tUnqualified) (const (throwM federationNotImplemented)) --- | Calls 'Galley.API.getConversationH'. -getConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - ConvId -> - m (Maybe Conversation) -getConv usr cnv = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . msg (val "Getting conversation") - rs <- galleyRequest GET req - case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["conversations", toByteString' cnv] - . zUser usr - . expect [status200, status404] - upsertOne2OneConversation :: ( MonadReader Env m, MonadIO m, @@ -930,34 +870,6 @@ upsertOne2OneConversation urequest = do . header "Content-Type" "application/json" . lbytes (encode urequest) --- | Calls 'Galley.API.getTeamConversationH'. -getTeamConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - TeamId -> - ConvId -> - m (Maybe Conv.TeamConversation) -getTeamConv usr tid cnv = do - debug $ - remote "galley" - . field "conv" (toByteString cnv) - . msg (val "Getting team conversation") - rs <- galleyRequest GET req - case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["teams", toByteString' tid, "conversations", toByteString' cnv] - . zUser usr - . expect [status200, status404] - ------------------------------------------------------------------------------- -- User management @@ -997,27 +909,6 @@ rmUser usr asts = do ------------------------------------------------------------------------------- -- Client management --- | Calls 'Galley.API.addClientH'. -newClient :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - ClientId -> - m () -newClient u c = do - debug $ - remote "galley" - . field "user" (toByteString u) - . field "client" (toByteString c) - . msg (val "new client") - let p = paths ["i", "clients", toByteString' c] - void $ galleyRequest POST (p . zUser u . expect2xx) - -- | Calls 'Galley.API.rmClientH', as well as gundeck. rmClient :: ( MonadReader Env m, @@ -1084,159 +975,6 @@ lookupPushToken uid = do ------------------------------------------------------------------------------- -- Team Management --- | Calls 'Galley.API.canUserJoinTeamH'. -checkUserCanJoinTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - m (Maybe Wai.Error) -checkUserCanJoinTeam tid = do - debug $ - remote "galley" - . msg (val "Check if can add member to team") - rs <- galleyRequest GET req - pure $ case Bilge.statusCode rs of - 200 -> Nothing - _ -> case decodeBody "galley" rs of - Just (e :: Wai.Error) -> pure e - Nothing -> error ("Invalid response from galley: " <> show rs) - where - req = - paths ["i", "teams", toByteString' tid, "members", "check"] - . header "Content-Type" "application/json" - --- | Calls 'Galley.API.uncheckedAddTeamMemberH'. -addTeamMember :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - TeamId -> - (Maybe (UserId, UTCTimeMillis), Role) -> - m Bool -addTeamMember u tid (minvmeta, role) = do - debug $ - remote "galley" - . msg (val "Adding member to team") - rs <- galleyRequest POST req - pure $ case Bilge.statusCode rs of - 200 -> True - _ -> False - where - prm = Team.rolePermissions role - bdy = Member.mkNewTeamMember u prm minvmeta - req = - paths ["i", "teams", toByteString' tid, "members"] - . header "Content-Type" "application/json" - . zUser u - . expect [status200, status403] - . lbytes (encode bdy) - --- | Calls 'Galley.API.createBindingTeamH'. -createTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - BindingNewTeam -> - TeamId -> - m CreateUserTeam -createTeam u t@(BindingNewTeam bt) teamid = do - debug $ - remote "galley" - . msg (val "Creating Team") - r <- galleyRequest PUT $ req teamid - tid <- - maybe (error "invalid team id") pure $ - fromByteString $ - getHeader' "Location" r - pure (CreateUserTeam tid $ fromRange (bt ^. newTeamName)) - where - req tid = - paths ["i", "teams", toByteString' tid] - . header "Content-Type" "application/json" - . zUser u - . expect2xx - . lbytes (encode t) - --- | Calls 'Galley.API.uncheckedGetTeamMemberH'. -getTeamMember :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - UserId -> - TeamId -> - m (Maybe Team.TeamMember) -getTeamMember u tid = do - debug $ - remote "galley" - . msg (val "Get team member") - rs <- galleyRequest GET req - case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["i", "teams", toByteString' tid, "members", toByteString' u] - . zUser u - . expect [status200, status404] - --- | Calls 'Galley.API.uncheckedGetTeamMembersH'. --- --- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which --- means that only the first 2000 members of a team (according to some arbitrary order) will --- be suspended, and the rest will remain active. -getTeamMembers :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - TeamId -> - m Team.TeamMemberList -getTeamMembers tid = do - debug $ remote "galley" . msg (val "Get team members") - galleyRequest GET req >>= decodeBody "galley" - where - req = - paths ["i", "teams", toByteString' tid, "members"] - . expect2xx - -memberIsTeamOwner :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - TeamId -> - UserId -> - m Bool -memberIsTeamOwner tid uid = do - r <- - galleyRequest GET $ - paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] - pure $ responseStatus r /= status403 - -- | Only works on 'BindingTeam's! The list of members returned is potentially truncated. -- -- Calls 'Galley.API.getBindingTeamMembersH'. @@ -1261,167 +999,6 @@ getTeamContacts u = do paths ["i", "users", toByteString' u, "team", "members"] . expect [status200, status404] --- | Calls 'Galley.API.getBindingTeamIdH'. -getTeamId :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - UserId -> - m (Maybe TeamId) -getTeamId u = do - debug $ remote "galley" . msg (val "Get team from user") - rs <- galleyRequest GET req - case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs - _ -> pure Nothing - where - req = - paths ["i", "users", toByteString' u, "team"] - . expect [status200, status404] - --- | Calls 'Galley.API.getTeamInternalH'. -getTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - m Team.TeamData -getTeam tid = do - debug $ remote "galley" . msg (val "Get team info") - galleyRequest GET req >>= decodeBody "galley" - where - req = - paths ["i", "teams", toByteString' tid] - . expect2xx - --- | Calls 'Galley.API.getTeamInternalH'. -getTeamName :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - m Team.TeamName -getTeamName tid = do - debug $ remote "galley" . msg (val "Get team info") - galleyRequest GET req >>= decodeBody "galley" - where - req = - paths ["i", "teams", toByteString' tid, "name"] - . expect2xx - --- | Calls 'Galley.API.getTeamFeatureStatusH'. -getTeamLegalHoldStatus :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - m (WithStatus LegalholdConfig) -getTeamLegalHoldStatus tid = do - debug $ remote "galley" . msg (val "Get legalhold settings") - galleyRequest GET req >>= decodeBody "galley" - where - req = - paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] - . expect2xx - --- | Calls 'Galley.API.getSearchVisibilityInternalH'. -getTeamSearchVisibility :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - TeamId -> - m TeamSearchVisibility -getTeamSearchVisibility tid = - coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do - debug $ remote "galley" . msg (val "Get search visibility settings") - galleyRequest GET req >>= decodeBody "galley" - where - req = - paths ["i", "teams", toByteString' tid, "search-visibility"] - . expect2xx - -getVerificationCodeEnabled :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - m Bool -getVerificationCodeEnabled tid = do - debug $ remote "galley" . msg (val "Get snd factor password challenge settings") - response <- galleyRequest GET req - status <- wsStatus <$> decodeBody @(WithStatus SndFactorPasswordChallengeConfig) "galley" response - case status of - FeatureStatusEnabled -> pure True - FeatureStatusDisabled -> pure False - where - req = - paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] - . expect2xx - -getAllFeatureConfigsForUser :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => - Maybe UserId -> - m AllFeatureConfigs -getAllFeatureConfigsForUser mbUserId = - responseJsonUnsafe - <$> galleyRequest - GET - ( paths ["i", "feature-configs"] - . maybe id (queryItem "user_id" . toByteString') mbUserId - ) - --- | Calls 'Galley.API.updateTeamStatusH'. -changeTeamStatus :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => - TeamId -> - Team.TeamStatus -> - Maybe Currency.Alpha -> - m () -changeTeamStatus tid s cur = do - debug $ remote "galley" . msg (val "Change Team status") - void $ galleyRequest PUT req - where - req = - paths ["i", "teams", toByteString' tid, "status"] - . header "Content-Type" "application/json" - . expect2xx - . lbytes (encode $ Team.TeamStatusUpdate s cur) - guardLegalhold :: ( MonadReader Env m, MonadIO m, diff --git a/services/brig/src/Brig/Sem/GalleyProvider.hs b/services/brig/src/Brig/Sem/GalleyProvider.hs index 6bdcd720c9..a55d4fff50 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider.hs @@ -18,7 +18,6 @@ import Wire.API.Team.Feature import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility -import Wire.API.User data GalleyProvider m a where CreateSelfConv :: @@ -54,18 +53,10 @@ data GalleyProvider m a where TeamId -> ConvId -> GalleyProvider m (Maybe Conv.TeamConversation) - RmUser :: - UserId -> - [Asset] -> - GalleyProvider m () NewClient :: UserId -> ClientId -> GalleyProvider m () - RmClient :: - UserId -> - ClientId -> - GalleyProvider m () CheckUserCanJoinTeam :: TeamId -> GalleyProvider m (Maybe Wai.Error) diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs index 036c614fc4..90f98f89de 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -2,33 +2,479 @@ module Brig.Sem.GalleyProvider.RPC where -import Bilge (Request) -import Brig.Sem.GalleyProvider -import Brig.Sem.RPC + +import Bilge hiding (head, options, requestId) +import Bilge.RPC +import Brig.API.Types +import Brig.App +import Brig.RPC +import Control.Lens ((^.)) +import Control.Monad.Catch +import Data.Aeson hiding (json) +import Data.ByteString.Conversion +import Data.Coerce (coerce) +import qualified Data.Currency as Currency +import Data.Id +import Data.Json.Util (UTCTimeMillis) +import Data.Range +import qualified Galley.Types.Teams as Team +import qualified Galley.Types.Teams.Intra as Team import Imports +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import qualified Network.Wai.Utilities.Error as Wai +import System.Logger.Class as Log hiding (name, (.=)) +import Wire.API.Conversation hiding (Member) +import Wire.API.Team +import qualified Wire.API.Team.Conversation as Conv +import Wire.API.Team.Feature +import qualified Wire.API.Team.Member as Member +import qualified Wire.API.Team.Member as Team +import Wire.API.Team.Role +import Wire.API.Team.SearchVisibility +import Brig.Sem.GalleyProvider (GalleyProvider(..)) +import Brig.Sem.RPC import Polysemy interpretGalleyProviderToRPC :: Member RPC r => Request -> Sem (GalleyProvider ': r) a -> Sem r a -interpretGalleyProviderToRPC req = interpret undefined - -- CreateSelfConv uid -> undefined - -- CreateLocalConnectConv qwt qwt' m_txt m_ci -> undefined - -- AcceptLocalConnectConv qwt m_ci uid -> undefined - -- BlockLocalConv qwt m_ci uid -> undefined - -- UnblockLocalConv qwt m_ci uid -> undefined - -- GetConv uid id' -> undefined - -- GetTeamConv uid id' id2 -> undefined - -- RmUser uid ass -> undefined - -- NewClient uid ci -> undefined - -- RmClient uid ci -> undefined - -- CheckUserCanJoinTeam uid -> undefined - -- AddTeamMember uid id' x0 -> undefined - -- CreateTeam uid bnt id' -> undefined - -- GetTeamMember uid id' -> undefined - -- GetTeamMembers uid -> undefined - -- GetTeamContacts uid -> undefined - -- GetTeamId uid -> undefined - -- GetTeam uid -> undefined - -- GetTeamName uid -> undefined - -- GetTeamLegalHoldStatus uid -> undefined - -- GetTeamSearchVisibility uid -> undefined - -- ChangeTeamStatus uid ts m_al -> undefined +interpretGalleyProviderToRPC req = interpret $ \case + CreateSelfConv id' -> runIt $ createSelfConv id' + CreateLocalConnectConv qwt qwt' m_txt m_ci -> undefined -- createLocalConnectConv qwt qwt' m_txt m_ci + AcceptLocalConnectConv qwt m_ci id' -> undefined -- acceptLocalConnectConv qwt m_ci id' + BlockLocalConv qwt m_ci id' -> undefined -- blockLocalConv qwt m_ci id' + UnblockLocalConv qwt m_ci id' -> undefined -- unblockLocalConv qwt m_ci id' + GetConv id' id'' -> runIt $ getConv id' id'' + GetTeamConv id' id'' id'2 -> runIt $ getTeamConv id' id'' id'2 + NewClient id' ci -> runIt $ newClient id' ci + CheckUserCanJoinTeam id' -> runIt $ checkUserCanJoinTeam id' + AddTeamMember id' id'' x0 -> runIt $ addTeamMember id' id'' x0 + CreateTeam id' bnt id'' -> runIt $ createTeam id' bnt id'' + GetTeamMember id' id'' -> runIt $ getTeamMember id' id'' + GetTeamMembers id' -> runIt $ getTeamMembers id' + GetTeamContacts id' -> undefined -- getTeamContacts id' + GetTeamId id' -> runIt $ getTeamId id' + GetTeam id' -> runIt $ getTeam id' + GetTeamName id' -> runIt $ getTeamName id' + GetTeamLegalHoldStatus id' -> runIt $ getTeamLegalHoldStatus id' + GetTeamSearchVisibility id' -> runIt $ getTeamSearchVisibility id' + ChangeTeamStatus id' ts m_al -> runIt $ changeTeamStatus id' ts m_al + MemberIsTeamOwner id' id'' -> runIt $ memberIsTeamOwner id' id'' + GetAllFeatureConfigsForUser m_id' -> runIt $ getAllFeatureConfigsForUser m_id' + GetVerificationCodeEnabled id' -> runIt $ getVerificationCodeEnabled id' + +runIt :: HttpClientIO a -> Sem r a +runIt = undefined + +-- runIt = undefined + +-- | Calls 'Galley.API.createSelfConversationH'. +createSelfConv :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + m () +createSelfConv u = do + debug $ + remote "galley" + . msg (val "Creating self conversation") + void $ galleyRequest POST req + where + req = + path "/conversations/self" + . zUser u + . expect2xx + +-- | Calls 'Galley.API.getConversationH'. +getConv :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + ConvId -> + m (Maybe Conversation) +getConv usr cnv = do + debug $ + remote "galley" + . field "conv" (toByteString cnv) + . msg (val "Getting conversation") + rs <- galleyRequest GET req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBody "galley" rs + _ -> pure Nothing + where + req = + paths ["conversations", toByteString' cnv] + . zUser usr + . expect [status200, status404] + +-- | Calls 'Galley.API.getTeamConversationH'. +getTeamConv :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + TeamId -> + ConvId -> + m (Maybe Conv.TeamConversation) +getTeamConv usr tid cnv = do + debug $ + remote "galley" + . field "conv" (toByteString cnv) + . msg (val "Getting team conversation") + rs <- galleyRequest GET req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBody "galley" rs + _ -> pure Nothing + where + req = + paths ["teams", toByteString' tid, "conversations", toByteString' cnv] + . zUser usr + . expect [status200, status404] + +-- | Calls 'Galley.API.addClientH'. +newClient :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + ClientId -> + m () +newClient u c = do + debug $ + remote "galley" + . field "user" (toByteString u) + . field "client" (toByteString c) + . msg (val "new client") + let p = paths ["i", "clients", toByteString' c] + void $ galleyRequest POST (p . zUser u . expect2xx) + +-- | Calls 'Galley.API.canUserJoinTeamH'. +checkUserCanJoinTeam :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + m (Maybe Wai.Error) +checkUserCanJoinTeam tid = do + debug $ + remote "galley" + . msg (val "Check if can add member to team") + rs <- galleyRequest GET req + pure $ case Bilge.statusCode rs of + 200 -> Nothing + _ -> case decodeBody "galley" rs of + Just (e :: Wai.Error) -> pure e + Nothing -> error ("Invalid response from galley: " <> show rs) + where + req = + paths ["i", "teams", toByteString' tid, "members", "check"] + . header "Content-Type" "application/json" + +-- | Calls 'Galley.API.uncheckedAddTeamMemberH'. +addTeamMember :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + TeamId -> + (Maybe (UserId, UTCTimeMillis), Role) -> + m Bool +addTeamMember u tid (minvmeta, role) = do + debug $ + remote "galley" + . msg (val "Adding member to team") + rs <- galleyRequest POST req + pure $ case Bilge.statusCode rs of + 200 -> True + _ -> False + where + prm = Team.rolePermissions role + bdy = Member.mkNewTeamMember u prm minvmeta + req = + paths ["i", "teams", toByteString' tid, "members"] + . header "Content-Type" "application/json" + . zUser u + . expect [status200, status403] + . lbytes (encode bdy) + +-- | Calls 'Galley.API.createBindingTeamH'. +createTeam :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + BindingNewTeam -> + TeamId -> + m CreateUserTeam +createTeam u t@(BindingNewTeam bt) teamid = do + debug $ + remote "galley" + . msg (val "Creating Team") + r <- galleyRequest PUT $ req teamid + tid <- + maybe (error "invalid team id") pure $ + fromByteString $ + getHeader' "Location" r + pure (CreateUserTeam tid $ fromRange (bt ^. newTeamName)) + where + req tid = + paths ["i", "teams", toByteString' tid] + . header "Content-Type" "application/json" + . zUser u + . expect2xx + . lbytes (encode t) + +-- | Calls 'Galley.API.uncheckedGetTeamMemberH'. +getTeamMember :: + ( MonadLogger m, + MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + UserId -> + TeamId -> + m (Maybe Team.TeamMember) +getTeamMember u tid = do + debug $ + remote "galley" + . msg (val "Get team member") + rs <- galleyRequest GET req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBody "galley" rs + _ -> pure Nothing + where + req = + paths ["i", "teams", toByteString' tid, "members", toByteString' u] + . zUser u + . expect [status200, status404] + +-- | Calls 'Galley.API.uncheckedGetTeamMembersH'. +-- +-- | TODO: is now truncated. this is (only) used for team suspension / unsuspension, which +-- means that only the first 2000 members of a team (according to some arbitrary order) will +-- be suspended, and the rest will remain active. +getTeamMembers :: + ( MonadLogger m, + MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + TeamId -> + m Team.TeamMemberList +getTeamMembers tid = do + debug $ remote "galley" . msg (val "Get team members") + galleyRequest GET req >>= decodeBody "galley" + where + req = + paths ["i", "teams", toByteString' tid, "members"] + . expect2xx + +memberIsTeamOwner :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + TeamId -> + UserId -> + m Bool +memberIsTeamOwner tid uid = do + r <- + galleyRequest GET $ + paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] + pure $ responseStatus r /= status403 + +-- | Calls 'Galley.API.getBindingTeamIdH'. +getTeamId :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + UserId -> + m (Maybe TeamId) +getTeamId u = do + debug $ remote "galley" . msg (val "Get team from user") + rs <- galleyRequest GET req + case Bilge.statusCode rs of + 200 -> Just <$> decodeBody "galley" rs + _ -> pure Nothing + where + req = + paths ["i", "users", toByteString' u, "team"] + . expect [status200, status404] + +-- | Calls 'Galley.API.getTeamInternalH'. +getTeam :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + m Team.TeamData +getTeam tid = do + debug $ remote "galley" . msg (val "Get team info") + galleyRequest GET req >>= decodeBody "galley" + where + req = + paths ["i", "teams", toByteString' tid] + . expect2xx + +-- | Calls 'Galley.API.getTeamInternalH'. +getTeamName :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + m Team.TeamName +getTeamName tid = do + debug $ remote "galley" . msg (val "Get team info") + galleyRequest GET req >>= decodeBody "galley" + where + req = + paths ["i", "teams", toByteString' tid, "name"] + . expect2xx + +-- | Calls 'Galley.API.getTeamFeatureStatusH'. +getTeamLegalHoldStatus :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + m (WithStatus LegalholdConfig) +getTeamLegalHoldStatus tid = do + debug $ remote "galley" . msg (val "Get legalhold settings") + galleyRequest GET req >>= decodeBody "galley" + where + req = + paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] + . expect2xx + +-- | Calls 'Galley.API.getSearchVisibilityInternalH'. +getTeamSearchVisibility :: + ( MonadLogger m, + MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + TeamId -> + m TeamSearchVisibility +getTeamSearchVisibility tid = + coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do + debug $ remote "galley" . msg (val "Get search visibility settings") + galleyRequest GET req >>= decodeBody "galley" + where + req = + paths ["i", "teams", toByteString' tid, "search-visibility"] + . expect2xx + +getVerificationCodeEnabled :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + m Bool +getVerificationCodeEnabled tid = do + debug $ remote "galley" . msg (val "Get snd factor password challenge settings") + response <- galleyRequest GET req + status <- wsStatus <$> decodeBody @(WithStatus SndFactorPasswordChallengeConfig) "galley" response + case status of + FeatureStatusEnabled -> pure True + FeatureStatusDisabled -> pure False + where + req = + paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] + . expect2xx + +getAllFeatureConfigsForUser :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m + ) => + Maybe UserId -> + m AllFeatureConfigs +getAllFeatureConfigsForUser mbUserId = + responseJsonUnsafe + <$> galleyRequest + GET + ( paths ["i", "feature-configs"] + . maybe id (queryItem "user_id" . toByteString') mbUserId + ) + +-- | Calls 'Galley.API.updateTeamStatusH'. +changeTeamStatus :: + ( MonadReader Env m, + MonadIO m, + MonadMask m, + MonadHttp m, + HasRequestId m, + MonadLogger m + ) => + TeamId -> + Team.TeamStatus -> + Maybe Currency.Alpha -> + m () +changeTeamStatus tid s cur = do + debug $ remote "galley" . msg (val "Change Team status") + void $ galleyRequest PUT req + where + req = + paths ["i", "teams", toByteString' tid, "status"] + . header "Content-Type" "application/json" + . expect2xx + . lbytes (encode $ Team.TeamStatusUpdate s cur) From b3bb313398e138382347a9b8ad5d330be9c8c543 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 14:29:51 -0700 Subject: [PATCH 07/18] everything compiles! --- .../brig/src/Brig/CanonicalInterpreter.hs | 22 +- services/brig/src/Brig/IO/Intra.hs | 20 - services/brig/src/Brig/Sem/GalleyProvider.hs | 25 -- .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 363 ++++++++---------- 4 files changed, 187 insertions(+), 243 deletions(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index e3fce1e667..d4dbe3b0e0 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -19,6 +19,13 @@ import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) +import Brig.Sem.ServiceRPC (ServiceRPC, Service(Galley)) +import Brig.Sem.ServiceRPC.IO (interpretServiceRpcToRpc) +import Polysemy.Error (runError, mapError, Error) +import Brig.RPC (ParseException) +import Control.Monad.Catch (throwM) +import Wire.Sem.Logger.TinyLog (loggerToTinyLog) +import Polysemy.TinyLog (TinyLog) type BrigCanonicalEffects = '[ BlacklistPhonePrefixStore, @@ -27,19 +34,28 @@ type BrigCanonicalEffects = Now, CodeStore, GalleyProvider, + ServiceRPC 'Galley, RPC, Embed Cas.Client, + Error ParseException, + Error SomeException, + TinyLog, Embed IO, Final IO ] runBrigToIO :: Env -> AppT BrigCanonicalEffects a -> IO a -runBrigToIO e (AppT ma) = - runFinal +runBrigToIO e (AppT ma) = do + (either throwM pure =<<) + . runFinal . embedToFinal + . loggerToTinyLog (e ^. applog) + . runError @SomeException + . mapError @ParseException SomeException . interpretClientToIO (e ^. casClient) . interpretRpcToIO (e ^. httpManager) (e ^. requestId) - . interpretGalleyProviderToRPC (e ^. galley) + . interpretServiceRpcToRpc @'Galley "galley" (e ^. galley) + . interpretGalleyProviderToRPC . codeStoreToCassandra @Cas.Client . nowToIOAction (e ^. currentTime) . passwordResetStoreToCodeStore diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index d1fb08493c..92f10e33f3 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -26,12 +26,10 @@ module Brig.IO.Intra onClientEvent, -- * Conversations - -- createSelfConv, createConnectConv, acceptConnectConv, blockConv, unblockConv, - -- getConv, upsertOne2OneConversation, -- * Clients @@ -42,24 +40,6 @@ module Brig.IO.Intra -- * Account Deletion rmUser, - -- * Teams - -- addTeamMember, - -- checkUserCanJoinTeam, - -- createTeam, - -- getTeamMember, - -- getTeamMembers, - -- memberIsTeamOwner, - -- getTeam, - -- getTeamConv, - -- getTeamName, - -- getTeamId, - -- getTeamContacts, - -- getTeamLegalHoldStatus, - -- changeTeamStatus, - -- getTeamSearchVisibility, - -- getAllFeatureConfigsForUser, - -- getVerificationCodeEnabled, - -- * Legalhold guardLegalhold, diff --git a/services/brig/src/Brig/Sem/GalleyProvider.hs b/services/brig/src/Brig/Sem/GalleyProvider.hs index a55d4fff50..b62f9b87bb 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider.hs @@ -6,7 +6,6 @@ import Brig.API.Types import qualified Data.Currency as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) -import Data.Qualified import qualified Galley.Types.Teams.Intra as Team import Imports import qualified Network.Wai.Utilities.Error as Wai @@ -23,27 +22,6 @@ data GalleyProvider m a where CreateSelfConv :: UserId -> GalleyProvider m () - CreateLocalConnectConv :: - Local UserId -> - Local UserId -> - Maybe Text -> - Maybe ConnId -> - GalleyProvider m ConvId - AcceptLocalConnectConv :: - Local UserId -> - Maybe ConnId -> - ConvId -> - GalleyProvider m Conversation - BlockLocalConv :: - Local UserId -> - Maybe ConnId -> - ConvId -> - GalleyProvider m () - UnblockLocalConv :: - Local UserId -> - Maybe ConnId -> - ConvId -> - GalleyProvider m Conversation GetConv :: UserId -> ConvId -> @@ -77,9 +55,6 @@ data GalleyProvider m a where GetTeamMembers :: TeamId -> GalleyProvider m Team.TeamMemberList - GetTeamContacts :: - UserId -> - GalleyProvider m (Maybe Team.TeamMemberList) GetTeamId :: UserId -> GalleyProvider m (Maybe TeamId) diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs index 90f98f89de..8ebbd56174 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -4,12 +4,10 @@ module Brig.Sem.GalleyProvider.RPC where import Bilge hiding (head, options, requestId) -import Bilge.RPC import Brig.API.Types import Brig.App import Brig.RPC import Control.Lens ((^.)) -import Control.Monad.Catch import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.Coerce (coerce) @@ -23,7 +21,6 @@ import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai -import System.Logger.Class as Log hiding (name, (.=)) import Wire.API.Conversation hiding (Member) import Wire.API.Team import qualified Wire.API.Team.Conversation as Conv @@ -33,34 +30,40 @@ import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Brig.Sem.GalleyProvider (GalleyProvider(..)) -import Brig.Sem.RPC import Polysemy +import System.Logger (Msg, val, msg, field) +import Wire.Sem.Logger +import Brig.Sem.ServiceRPC (ServiceRPC, Service(Galley)) +import qualified Brig.Sem.ServiceRPC as ServiceRPC +import qualified Data.ByteString.Lazy as BL +import Polysemy.Error +import Control.Error (hush) -interpretGalleyProviderToRPC :: Member RPC r => Request -> Sem (GalleyProvider ': r) a -> Sem r a -interpretGalleyProviderToRPC req = interpret $ \case - CreateSelfConv id' -> runIt $ createSelfConv id' - CreateLocalConnectConv qwt qwt' m_txt m_ci -> undefined -- createLocalConnectConv qwt qwt' m_txt m_ci - AcceptLocalConnectConv qwt m_ci id' -> undefined -- acceptLocalConnectConv qwt m_ci id' - BlockLocalConv qwt m_ci id' -> undefined -- blockLocalConv qwt m_ci id' - UnblockLocalConv qwt m_ci id' -> undefined -- unblockLocalConv qwt m_ci id' - GetConv id' id'' -> runIt $ getConv id' id'' - GetTeamConv id' id'' id'2 -> runIt $ getTeamConv id' id'' id'2 - NewClient id' ci -> runIt $ newClient id' ci - CheckUserCanJoinTeam id' -> runIt $ checkUserCanJoinTeam id' - AddTeamMember id' id'' x0 -> runIt $ addTeamMember id' id'' x0 - CreateTeam id' bnt id'' -> runIt $ createTeam id' bnt id'' - GetTeamMember id' id'' -> runIt $ getTeamMember id' id'' - GetTeamMembers id' -> runIt $ getTeamMembers id' - GetTeamContacts id' -> undefined -- getTeamContacts id' - GetTeamId id' -> runIt $ getTeamId id' - GetTeam id' -> runIt $ getTeam id' - GetTeamName id' -> runIt $ getTeamName id' - GetTeamLegalHoldStatus id' -> runIt $ getTeamLegalHoldStatus id' - GetTeamSearchVisibility id' -> runIt $ getTeamSearchVisibility id' - ChangeTeamStatus id' ts m_al -> runIt $ changeTeamStatus id' ts m_al - MemberIsTeamOwner id' id'' -> runIt $ memberIsTeamOwner id' id'' - GetAllFeatureConfigsForUser m_id' -> runIt $ getAllFeatureConfigsForUser m_id' - GetVerificationCodeEnabled id' -> runIt $ getVerificationCodeEnabled id' +interpretGalleyProviderToRPC + :: Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg)] r + => Sem (GalleyProvider ': r) a -> Sem r a +interpretGalleyProviderToRPC = interpret $ \case + CreateSelfConv id' -> createSelfConv id' + GetConv id' id'' -> getConv id' id'' + GetTeamConv id' id'' id'2 -> getTeamConv id' id'' id'2 + NewClient id' ci -> newClient id' ci + CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' + AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 + CreateTeam id' bnt id'' -> createTeam id' bnt id'' + GetTeamMember id' id'' -> getTeamMember id' id'' + GetTeamMembers id' -> getTeamMembers id' + GetTeamId id' -> getTeamId id' + GetTeam id' -> getTeam id' + GetTeamName id' -> getTeamName id' + GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' + GetTeamSearchVisibility id' -> getTeamSearchVisibility id' + ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al + MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' + GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' + GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' runIt :: HttpClientIO a -> Sem r a runIt = undefined @@ -69,20 +72,17 @@ runIt = undefined -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> - m () + Sem r () createSelfConv u = do debug $ remote "galley" . msg (val "Creating self conversation") - void $ galleyRequest POST req + void $ ServiceRPC.request @'Galley POST req where req = path "/conversations/self" @@ -91,24 +91,22 @@ createSelfConv u = do -- | Calls 'Galley.API.getConversationH'. getConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> ConvId -> - m (Maybe Conversation) + Sem r (Maybe Conversation) getConv usr cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) . msg (val "Getting conversation") - rs <- galleyRequest GET req + rs <- ServiceRPC.request @'Galley GET req case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs + 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = @@ -118,25 +116,23 @@ getConv usr cnv = do -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> TeamId -> ConvId -> - m (Maybe Conv.TeamConversation) + Sem r (Maybe Conv.TeamConversation) getTeamConv usr tid cnv = do debug $ remote "galley" . field "conv" (toByteString cnv) . msg (val "Getting team conversation") - rs <- galleyRequest GET req + rs <- ServiceRPC.request @'Galley GET req case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs + 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = @@ -146,16 +142,13 @@ getTeamConv usr tid cnv = do -- | Calls 'Galley.API.addClientH'. newClient :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> ClientId -> - m () + Sem r () newClient u c = do debug $ remote "galley" @@ -163,27 +156,24 @@ newClient u c = do . field "client" (toByteString c) . msg (val "new client") let p = paths ["i", "clients", toByteString' c] - void $ galleyRequest POST (p . zUser u . expect2xx) + void $ ServiceRPC.request @'Galley POST (p . zUser u . expect2xx) -- | Calls 'Galley.API.canUserJoinTeamH'. checkUserCanJoinTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m (Maybe Wai.Error) + Sem r (Maybe Wai.Error) checkUserCanJoinTeam tid = do debug $ remote "galley" . msg (val "Check if can add member to team") - rs <- galleyRequest GET req + rs <- ServiceRPC.request @'Galley GET req pure $ case Bilge.statusCode rs of 200 -> Nothing - _ -> case decodeBody "galley" rs of + _ -> case decodeBodyMaybe "galley" rs of Just (e :: Wai.Error) -> pure e Nothing -> error ("Invalid response from galley: " <> show rs) where @@ -193,22 +183,19 @@ checkUserCanJoinTeam tid = do -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. addTeamMember :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Role) -> - m Bool + Sem r Bool addTeamMember u tid (minvmeta, role) = do debug $ remote "galley" . msg (val "Adding member to team") - rs <- galleyRequest POST req + rs <- ServiceRPC.request @'Galley POST req pure $ case Bilge.statusCode rs of 200 -> True _ -> False @@ -224,22 +211,19 @@ addTeamMember u tid (minvmeta, role) = do -- | Calls 'Galley.API.createBindingTeamH'. createTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> BindingNewTeam -> TeamId -> - m CreateUserTeam + Sem r CreateUserTeam createTeam u t@(BindingNewTeam bt) teamid = do debug $ remote "galley" . msg (val "Creating Team") - r <- galleyRequest PUT $ req teamid + r <- ServiceRPC.request @'Galley PUT $ req teamid tid <- maybe (error "invalid team id") pure $ fromByteString $ @@ -255,23 +239,21 @@ createTeam u t@(BindingNewTeam bt) teamid = do -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. getTeamMember :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> TeamId -> - m (Maybe Team.TeamMember) + Sem r (Maybe Team.TeamMember) getTeamMember u tid = do debug $ remote "galley" . msg (val "Get team member") - rs <- galleyRequest GET req + rs <- ServiceRPC.request @'Galley GET req case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs + 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = @@ -285,55 +267,49 @@ getTeamMember u tid = do -- means that only the first 2000 members of a team (according to some arbitrary order) will -- be suspended, and the rest will remain active. getTeamMembers :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m Team.TeamMemberList + Sem r Team.TeamMemberList getTeamMembers tid = do debug $ remote "galley" . msg (val "Get team members") - galleyRequest GET req >>= decodeBody "galley" + ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" where req = paths ["i", "teams", toByteString' tid, "members"] . expect2xx memberIsTeamOwner :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> UserId -> - m Bool + Sem r Bool memberIsTeamOwner tid uid = do r <- - galleyRequest GET $ + ServiceRPC.request @'Galley GET $ paths ["i", "teams", toByteString' tid, "is-team-owner", toByteString' uid] pure $ responseStatus r /= status403 -- | Calls 'Galley.API.getBindingTeamIdH'. getTeamId :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => UserId -> - m (Maybe TeamId) + Sem r (Maybe TeamId) getTeamId u = do debug $ remote "galley" . msg (val "Get team from user") - rs <- galleyRequest GET req + rs <- ServiceRPC.request @'Galley GET req case Bilge.statusCode rs of - 200 -> Just <$> decodeBody "galley" rs + 200 -> Just <$> decodeBodyOrThrow "galley" rs _ -> pure Nothing where req = @@ -342,18 +318,16 @@ getTeamId u = do -- | Calls 'Galley.API.getTeamInternalH'. getTeam :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m Team.TeamData + Sem r Team.TeamData getTeam tid = do debug $ remote "galley" . msg (val "Get team info") - galleyRequest GET req >>= decodeBody "galley" + ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" where req = paths ["i", "teams", toByteString' tid] @@ -361,18 +335,16 @@ getTeam tid = do -- | Calls 'Galley.API.getTeamInternalH'. getTeamName :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m Team.TeamName + Sem r Team.TeamName getTeamName tid = do debug $ remote "galley" . msg (val "Get team info") - galleyRequest GET req >>= decodeBody "galley" + ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" where req = paths ["i", "teams", toByteString' tid, "name"] @@ -380,18 +352,16 @@ getTeamName tid = do -- | Calls 'Galley.API.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m (WithStatus LegalholdConfig) + Sem r (WithStatus LegalholdConfig) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") - galleyRequest GET req >>= decodeBody "galley" + ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" where req = paths ["i", "teams", toByteString' tid, "features", featureNameBS @LegalholdConfig] @@ -399,38 +369,34 @@ getTeamLegalHoldStatus tid = do -- | Calls 'Galley.API.getSearchVisibilityInternalH'. getTeamSearchVisibility :: - ( MonadLogger m, - MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m TeamSearchVisibility + Sem r TeamSearchVisibility getTeamSearchVisibility tid = coerce @TeamSearchVisibilityView @TeamSearchVisibility <$> do debug $ remote "galley" . msg (val "Get search visibility settings") - galleyRequest GET req >>= decodeBody "galley" + ServiceRPC.request @'Galley GET req >>= decodeBodyOrThrow "galley" where req = paths ["i", "teams", toByteString' tid, "search-visibility"] . expect2xx getVerificationCodeEnabled :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> - m Bool + Sem r Bool getVerificationCodeEnabled tid = do debug $ remote "galley" . msg (val "Get snd factor password challenge settings") - response <- galleyRequest GET req - status <- wsStatus <$> decodeBody @(WithStatus SndFactorPasswordChallengeConfig) "galley" response + response <- ServiceRPC.request @'Galley GET req + status <- wsStatus <$> decodeBodyOrThrow @(WithStatus SndFactorPasswordChallengeConfig) "galley" response case status of FeatureStatusEnabled -> pure True FeatureStatusDisabled -> pure False @@ -439,18 +405,28 @@ getVerificationCodeEnabled tid = do paths ["i", "teams", toByteString' tid, "features", featureNameBS @SndFactorPasswordChallengeConfig] . expect2xx +decodeBodyOrThrow :: forall a r. (Typeable a, FromJSON a, Member (Error ParseException) r) => Text -> Response (Maybe BL.ByteString) -> Sem r a +decodeBodyOrThrow t r = + case decodeBody @a t r of + Left a -> + case Imports.fromException a of + Just pe -> throw @ParseException pe + Nothing -> error "impossible: something other than ParseExceptionNothing was thrown by decodeBody" + Right b -> pure b + +decodeBodyMaybe :: (Typeable a, FromJSON a) => Text -> Response (Maybe BL.ByteString) -> Maybe a +decodeBodyMaybe t r = hush $ decodeBody t r + getAllFeatureConfigsForUser :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => Maybe UserId -> - m AllFeatureConfigs + Sem r AllFeatureConfigs getAllFeatureConfigsForUser mbUserId = responseJsonUnsafe - <$> galleyRequest + <$> ServiceRPC.request @'Galley GET ( paths ["i", "feature-configs"] . maybe id (queryItem "user_id" . toByteString') mbUserId @@ -458,20 +434,17 @@ getAllFeatureConfigsForUser mbUserId = -- | Calls 'Galley.API.updateTeamStatusH'. changeTeamStatus :: - ( MonadReader Env m, - MonadIO m, - MonadMask m, - MonadHttp m, - HasRequestId m, - MonadLogger m - ) => + Members '[ + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] r => TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> - m () + Sem r () changeTeamStatus tid s cur = do debug $ remote "galley" . msg (val "Change Team status") - void $ galleyRequest PUT req + void $ ServiceRPC.request @'Galley PUT req where req = paths ["i", "teams", toByteString' tid, "status"] From 5ff8ec2af64f21f58494e35592b3c3328f872827 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 14:31:56 -0700 Subject: [PATCH 08/18] make format --- .../brig/src/Brig/CanonicalInterpreter.hs | 14 +- .../brig/src/Brig/Sem/GalleyProvider/RPC.hs | 250 ++++++++++-------- 2 files changed, 142 insertions(+), 122 deletions(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index d4dbe3b0e0..f382ae8154 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -5,6 +5,7 @@ import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistPhonePrefixStore.Cassandra (interpretBlacklistPhonePrefixStoreToCassandra) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) +import Brig.RPC (ParseException) import Brig.Sem.CodeStore (CodeStore) import Brig.Sem.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) import Brig.Sem.GalleyProvider (GalleyProvider) @@ -13,19 +14,18 @@ import Brig.Sem.PasswordResetStore (PasswordResetStore) import Brig.Sem.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) import Brig.Sem.RPC (RPC) import Brig.Sem.RPC.IO (interpretRpcToIO) +import Brig.Sem.ServiceRPC (Service (Galley), ServiceRPC) +import Brig.Sem.ServiceRPC.IO (interpretServiceRpcToRpc) import qualified Cassandra as Cas import Control.Lens ((^.)) +import Control.Monad.Catch (throwM) import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) +import Polysemy.Error (Error, mapError, runError) +import Polysemy.TinyLog (TinyLog) +import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) -import Brig.Sem.ServiceRPC (ServiceRPC, Service(Galley)) -import Brig.Sem.ServiceRPC.IO (interpretServiceRpcToRpc) -import Polysemy.Error (runError, mapError, Error) -import Brig.RPC (ParseException) -import Control.Monad.Catch (throwM) -import Wire.Sem.Logger.TinyLog (loggerToTinyLog) -import Polysemy.TinyLog (TinyLog) type BrigCanonicalEffects = '[ BlacklistPhonePrefixStore, diff --git a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs index 8ebbd56174..36b036cd44 100644 --- a/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Sem/GalleyProvider/RPC.hs @@ -2,14 +2,18 @@ module Brig.Sem.GalleyProvider.RPC where - import Bilge hiding (head, options, requestId) import Brig.API.Types import Brig.App import Brig.RPC +import Brig.Sem.GalleyProvider (GalleyProvider (..)) +import Brig.Sem.ServiceRPC (Service (Galley), ServiceRPC) +import qualified Brig.Sem.ServiceRPC as ServiceRPC +import Control.Error (hush) import Control.Lens ((^.)) import Data.Aeson hiding (json) import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as BL import Data.Coerce (coerce) import qualified Data.Currency as Currency import Data.Id @@ -21,6 +25,9 @@ import Imports import Network.HTTP.Types.Method import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai +import Polysemy +import Polysemy.Error +import System.Logger (Msg, field, msg, val) import Wire.API.Conversation hiding (Member) import Wire.API.Team import qualified Wire.API.Team.Conversation as Conv @@ -29,41 +36,36 @@ import qualified Wire.API.Team.Member as Member import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility -import Brig.Sem.GalleyProvider (GalleyProvider(..)) -import Polysemy -import System.Logger (Msg, val, msg, field) import Wire.Sem.Logger -import Brig.Sem.ServiceRPC (ServiceRPC, Service(Galley)) -import qualified Brig.Sem.ServiceRPC as ServiceRPC -import qualified Data.ByteString.Lazy as BL -import Polysemy.Error -import Control.Error (hush) -interpretGalleyProviderToRPC - :: Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg)] r - => Sem (GalleyProvider ': r) a -> Sem r a +interpretGalleyProviderToRPC :: + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => + Sem (GalleyProvider ': r) a -> + Sem r a interpretGalleyProviderToRPC = interpret $ \case - CreateSelfConv id' -> createSelfConv id' - GetConv id' id'' -> getConv id' id'' - GetTeamConv id' id'' id'2 -> getTeamConv id' id'' id'2 - NewClient id' ci -> newClient id' ci - CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' - AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 - CreateTeam id' bnt id'' -> createTeam id' bnt id'' - GetTeamMember id' id'' -> getTeamMember id' id'' - GetTeamMembers id' -> getTeamMembers id' - GetTeamId id' -> getTeamId id' - GetTeam id' -> getTeam id' - GetTeamName id' -> getTeamName id' - GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' - GetTeamSearchVisibility id' -> getTeamSearchVisibility id' - ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al - MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' - GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' - GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' + CreateSelfConv id' -> createSelfConv id' + GetConv id' id'' -> getConv id' id'' + GetTeamConv id' id'' id'2 -> getTeamConv id' id'' id'2 + NewClient id' ci -> newClient id' ci + CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' + AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 + CreateTeam id' bnt id'' -> createTeam id' bnt id'' + GetTeamMember id' id'' -> getTeamMember id' id'' + GetTeamMembers id' -> getTeamMembers id' + GetTeamId id' -> getTeamId id' + GetTeam id' -> getTeam id' + GetTeamName id' -> getTeamName id' + GetTeamLegalHoldStatus id' -> getTeamLegalHoldStatus id' + GetTeamSearchVisibility id' -> getTeamSearchVisibility id' + ChangeTeamStatus id' ts m_al -> changeTeamStatus id' ts m_al + MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' + GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' + GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' runIt :: HttpClientIO a -> Sem r a runIt = undefined @@ -72,10 +74,11 @@ runIt = undefined -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> Sem r () createSelfConv u = do @@ -91,11 +94,12 @@ createSelfConv u = do -- | Calls 'Galley.API.getConversationH'. getConv :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> ConvId -> Sem r (Maybe Conversation) @@ -116,11 +120,12 @@ getConv usr cnv = do -- | Calls 'Galley.API.getTeamConversationH'. getTeamConv :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> TeamId -> ConvId -> @@ -142,10 +147,11 @@ getTeamConv usr tid cnv = do -- | Calls 'Galley.API.addClientH'. newClient :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> ClientId -> Sem r () @@ -160,10 +166,11 @@ newClient u c = do -- | Calls 'Galley.API.canUserJoinTeamH'. checkUserCanJoinTeam :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r (Maybe Wai.Error) checkUserCanJoinTeam tid = do @@ -183,10 +190,11 @@ checkUserCanJoinTeam tid = do -- | Calls 'Galley.API.uncheckedAddTeamMemberH'. addTeamMember :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> TeamId -> (Maybe (UserId, UTCTimeMillis), Role) -> @@ -211,10 +219,11 @@ addTeamMember u tid (minvmeta, role) = do -- | Calls 'Galley.API.createBindingTeamH'. createTeam :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> BindingNewTeam -> TeamId -> @@ -239,11 +248,12 @@ createTeam u t@(BindingNewTeam bt) teamid = do -- | Calls 'Galley.API.uncheckedGetTeamMemberH'. getTeamMember :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> TeamId -> Sem r (Maybe Team.TeamMember) @@ -267,11 +277,12 @@ getTeamMember u tid = do -- means that only the first 2000 members of a team (according to some arbitrary order) will -- be suspended, and the rest will remain active. getTeamMembers :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r Team.TeamMemberList getTeamMembers tid = do @@ -283,10 +294,11 @@ getTeamMembers tid = do . expect2xx memberIsTeamOwner :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> UserId -> Sem r Bool @@ -298,11 +310,12 @@ memberIsTeamOwner tid uid = do -- | Calls 'Galley.API.getBindingTeamIdH'. getTeamId :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => UserId -> Sem r (Maybe TeamId) getTeamId u = do @@ -318,11 +331,12 @@ getTeamId u = do -- | Calls 'Galley.API.getTeamInternalH'. getTeam :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r Team.TeamData getTeam tid = do @@ -335,11 +349,12 @@ getTeam tid = do -- | Calls 'Galley.API.getTeamInternalH'. getTeamName :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r Team.TeamName getTeamName tid = do @@ -352,11 +367,12 @@ getTeamName tid = do -- | Calls 'Galley.API.getTeamFeatureStatusH'. getTeamLegalHoldStatus :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r (WithStatus LegalholdConfig) getTeamLegalHoldStatus tid = do @@ -369,11 +385,12 @@ getTeamLegalHoldStatus tid = do -- | Calls 'Galley.API.getSearchVisibilityInternalH'. getTeamSearchVisibility :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r TeamSearchVisibility getTeamSearchVisibility tid = @@ -386,11 +403,12 @@ getTeamSearchVisibility tid = . expect2xx getVerificationCodeEnabled :: - Members '[ - Error ParseException, - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ Error ParseException, + ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Sem r Bool getVerificationCodeEnabled tid = do @@ -418,10 +436,11 @@ decodeBodyMaybe :: (Typeable a, FromJSON a) => Text -> Response (Maybe BL.ByteSt decodeBodyMaybe t r = hush $ decodeBody t r getAllFeatureConfigsForUser :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => Maybe UserId -> Sem r AllFeatureConfigs getAllFeatureConfigsForUser mbUserId = @@ -434,10 +453,11 @@ getAllFeatureConfigsForUser mbUserId = -- | Calls 'Galley.API.updateTeamStatusH'. changeTeamStatus :: - Members '[ - ServiceRPC 'Galley, - Logger (Msg -> Msg) - ] r => + Members + '[ ServiceRPC 'Galley, + Logger (Msg -> Msg) + ] + r => TeamId -> Team.TeamStatus -> Maybe Currency.Alpha -> From 890ad929b88c8156f033610569dd5462240d0b67 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 14:32:26 -0700 Subject: [PATCH 09/18] nit tidy --- services/brig/src/Brig/IO/Intra.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 92f10e33f3..e1cee4a798 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -33,7 +33,6 @@ module Brig.IO.Intra upsertOne2OneConversation, -- * Clients - -- Brig.IO.Intra.newClient, rmClient, lookupPushToken, From 969056ad939683e8b77ff2bc7e5fd1f89bdf8d16 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 14:34:51 -0700 Subject: [PATCH 10/18] add new modules to cabal --- services/brig/brig.cabal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 8a4fac5294..39b1851018 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -88,8 +88,14 @@ library Brig.Run Brig.Sem.CodeStore Brig.Sem.CodeStore.Cassandra + Brig.Sem.GalleyProvider + Brig.Sem.GalleyProvider.RPC Brig.Sem.PasswordResetStore Brig.Sem.PasswordResetStore.CodeStore + Brig.Sem.RPC + Brig.Sem.RPC.IO + Brig.Sem.ServiceRPC + Brig.Sem.ServiceRPC.IO Brig.SMTP Brig.Team.API Brig.Team.DB From aeb0b82b08d44136259fc08000b89b6867a4cce2 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 25 Aug 2022 14:42:24 -0700 Subject: [PATCH 11/18] changelog.d --- changelog.d/5-internal/galley-rpc | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/galley-rpc diff --git a/changelog.d/5-internal/galley-rpc b/changelog.d/5-internal/galley-rpc new file mode 100644 index 0000000000..1726de5a6b --- /dev/null +++ b/changelog.d/5-internal/galley-rpc @@ -0,0 +1 @@ +Add RPC, ServiceRPC and GalleyProvider effects to brig From ed3ec804c9d64c34402978eb3567861f9d9ba11c Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 3 Oct 2022 11:49:42 -0700 Subject: [PATCH 12/18] chore: cleanup some of the bad merge --- services/brig/brig.cabal | 4 ++-- services/brig/src/Brig/API/Connection.hs | 4 ++-- services/brig/src/Brig/API/Federation.hs | 2 +- services/brig/src/Brig/API/User.hs | 13 ++----------- services/brig/src/Brig/CanonicalInterpreter.hs | 14 ++++---------- services/brig/src/Brig/Effects/GalleyProvider.hs | 2 +- .../brig/src/Brig/Effects/GalleyProvider/RPC.hs | 8 ++++---- services/brig/src/Brig/Effects/RPC.hs | 2 +- services/brig/src/Brig/Effects/RPC/IO.hs | 4 ++-- services/brig/src/Brig/Effects/ServiceRPC.hs | 2 +- services/brig/src/Brig/Effects/ServiceRPC/IO.hs | 6 +++--- services/brig/src/Brig/IO/Intra.hs | 1 - services/brig/src/Brig/Team/Util.hs | 4 ++-- services/brig/src/Brig/User/API/Auth.hs | 2 +- services/brig/src/Brig/User/API/Handle.hs | 2 +- services/brig/src/Brig/User/API/Search.hs | 4 ++-- services/brig/src/Brig/User/Auth.hs | 6 +++--- 17 files changed, 32 insertions(+), 48 deletions(-) diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 5e37279dd2..eca21d9c27 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -62,17 +62,17 @@ library Brig.Effects.CodeStore Brig.Effects.CodeStore.Cassandra Brig.Effects.Delay - Brig.Effects.JwtTools Brig.Effects.GalleyProvider Brig.Effects.GalleyProvider.RPC + Brig.Effects.JwtTools Brig.Effects.PasswordResetStore Brig.Effects.PasswordResetStore.CodeStore Brig.Effects.PublicKeyBundle Brig.Effects.RPC Brig.Effects.RPC.IO - Brig.Effects.SFT Brig.Effects.ServiceRPC Brig.Effects.ServiceRPC.IO + Brig.Effects.SFT Brig.Effects.UserPendingActivationStore Brig.Effects.UserPendingActivationStore.Cassandra Brig.Email diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index a29b56be22..9bc8273f7f 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -40,8 +40,8 @@ import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data import qualified Brig.IO.Intra as Intra -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Types.Connection import Brig.Types.User.Event import Control.Error diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 8466f12896..c06424888d 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -31,7 +31,7 @@ import Brig.App import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data import Brig.IO.Intra (notify) -import Brig.Sem.GalleyProvider (GalleyProvider) +import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Types.User.Event import Brig.User.API.Handle import qualified Brig.User.Search.SearchIndex as Q diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d82b62c91c..2b6c0e20f9 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -124,17 +124,8 @@ import qualified Brig.InternalEvent.Types as Internal import Brig.Options hiding (Timeout, internalEvents) import Brig.Password import qualified Brig.Queue as Queue -<<<<<<< HEAD -import Brig.Sem.CodeStore (CodeStore) -import qualified Brig.Sem.CodeStore as E -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider -import Brig.Sem.PasswordResetStore (PasswordResetStore) -import qualified Brig.Sem.PasswordResetStore as E -import Brig.Sem.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) -import qualified Brig.Sem.UserPendingActivationStore as UserPendingActivationStore -======= ->>>>>>> develop +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import qualified Brig.Team.DB as Team import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Types.Activation (ActivationPair) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 06917d2d51..2cebf5bafb 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -5,28 +5,21 @@ import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistPhonePrefixStore.Cassandra (interpretBlacklistPhonePrefixStoreToCassandra) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.BlacklistStore.Cassandra (interpretBlacklistStoreToCassandra) -import Brig.RPC (ParseException) import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Effects.GalleyProvider.RPC (interpretGalleyProviderToRPC) +import Brig.Effects.JwtTools import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) +import Brig.Effects.PublicKeyBundle import Brig.Effects.RPC (RPC) import Brig.Effects.RPC.IO (interpretRpcToIO) import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) import Brig.Effects.ServiceRPC.IO (interpretServiceRpcToRpc) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) -import Brig.Effects.CodeStore (CodeStore) -import Brig.Effects.CodeStore.Cassandra (codeStoreToCassandra, interpretClientToIO) -import Brig.Effects.JwtTools -import Brig.Effects.PasswordResetStore (PasswordResetStore) -import Brig.Effects.PasswordResetStore.CodeStore (passwordResetStoreToCodeStore) -import Brig.Effects.PublicKeyBundle -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) -import qualified Cassandra as Cas +import Brig.RPC (ParseException) import Control.Lens ((^.)) import Control.Monad.Catch (throwM) import Imports @@ -37,6 +30,7 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) +import qualified Cassandra as Cas type BrigCanonicalEffects = '[ PublicKeyBundle, diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/services/brig/src/Brig/Effects/GalleyProvider.hs index b62f9b87bb..77358b5b8e 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Brig.Sem.GalleyProvider where +module Brig.Effects.GalleyProvider where import Brig.API.Types import qualified Data.Currency as Currency diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 36b036cd44..f6b0b18d11 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -1,14 +1,14 @@ {-# OPTIONS_GHC -Wno-unused-matches #-} -module Brig.Sem.GalleyProvider.RPC where +module Brig.Effects.GalleyProvider.RPC where import Bilge hiding (head, options, requestId) import Brig.API.Types import Brig.App import Brig.RPC -import Brig.Sem.GalleyProvider (GalleyProvider (..)) -import Brig.Sem.ServiceRPC (Service (Galley), ServiceRPC) -import qualified Brig.Sem.ServiceRPC as ServiceRPC +import Brig.Effects.GalleyProvider (GalleyProvider (..)) +import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) +import qualified Brig.Effects.ServiceRPC as ServiceRPC import Control.Error (hush) import Control.Lens ((^.)) import Data.Aeson hiding (json) diff --git a/services/brig/src/Brig/Effects/RPC.hs b/services/brig/src/Brig/Effects/RPC.hs index 9adc87ab4c..9b6e928ca0 100644 --- a/services/brig/src/Brig/Effects/RPC.hs +++ b/services/brig/src/Brig/Effects/RPC.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Brig.Sem.RPC where +module Brig.Effects.RPC where import Bilge import qualified Data.ByteString.Lazy as BL diff --git a/services/brig/src/Brig/Effects/RPC/IO.hs b/services/brig/src/Brig/Effects/RPC/IO.hs index caacc0d77a..1fdbb224c3 100644 --- a/services/brig/src/Brig/Effects/RPC/IO.hs +++ b/services/brig/src/Brig/Effects/RPC/IO.hs @@ -1,12 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Brig.Sem.RPC.IO where +module Brig.Effects.RPC.IO where import Bilge (HttpT, MonadHttp, RequestId) import Bilge.IO (Manager, runHttpT) import Bilge.RPC import qualified Brig.RPC as RPC -import Brig.Sem.RPC +import Brig.Effects.RPC import Control.Monad.Catch import Imports import Polysemy diff --git a/services/brig/src/Brig/Effects/ServiceRPC.hs b/services/brig/src/Brig/Effects/ServiceRPC.hs index f83947df9c..8753a613f3 100644 --- a/services/brig/src/Brig/Effects/ServiceRPC.hs +++ b/services/brig/src/Brig/Effects/ServiceRPC.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Brig.Sem.ServiceRPC where +module Brig.Effects.ServiceRPC where import Bilge import qualified Data.ByteString.Lazy as BL diff --git a/services/brig/src/Brig/Effects/ServiceRPC/IO.hs b/services/brig/src/Brig/Effects/ServiceRPC/IO.hs index 449bee9b23..51dcc4191e 100644 --- a/services/brig/src/Brig/Effects/ServiceRPC/IO.hs +++ b/services/brig/src/Brig/Effects/ServiceRPC/IO.hs @@ -1,8 +1,8 @@ -module Brig.Sem.ServiceRPC.IO where +module Brig.Effects.ServiceRPC.IO where import Bilge (Request) -import Brig.Sem.RPC -import Brig.Sem.ServiceRPC +import Brig.Effects.RPC +import Brig.Effects.ServiceRPC import qualified Data.Text.Lazy as LT import Imports import Polysemy diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 2070ad8050..88c1894a97 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -59,7 +59,6 @@ import qualified Brig.Data.Connection as Data import Brig.Federation.Client (notifyUserDeleted) import qualified Brig.IO.Journal as Journal import Brig.RPC -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Types.User.Event import Brig.User.Search.Index (MonadIndexIO) import qualified Brig.User.Search.Index as Search diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index e768b4013f..987e849af7 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -19,8 +19,8 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Control.Error import Control.Lens import Data.Id diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 04f1246a5f..4e24750208 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -28,7 +28,7 @@ import qualified Brig.API.User as User import Brig.App import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Phone -import Brig.Sem.GalleyProvider (GalleyProvider) +import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction, reAuthPassword) import Brig.Types.User.Auth import qualified Brig.User.Auth as Auth diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 2f0edf550a..7bc60edd18 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -30,7 +30,7 @@ import Brig.App import qualified Brig.Data.User as Data import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) -import Brig.Sem.GalleyProvider (GalleyProvider) +import Brig.Effects.GalleyProvider (GalleyProvider) import Control.Lens (view) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index e6948a37b5..33af3a3a50 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -28,8 +28,8 @@ import Brig.App import qualified Brig.Data.User as DB import qualified Brig.Federation.Client as Federation import qualified Brig.Options as Opts -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Team.Util (ensurePermissions) import Brig.Types.Search as Search import qualified Brig.User.API.Handle as HandleAPI diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 6e3ff3985f..0541f1f77d 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -51,8 +51,8 @@ import qualified Brig.Data.UserKey as Data import Brig.Email import qualified Brig.Options as Opt import Brig.Phone -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Types.Intra import Brig.Types.User.Auth import Brig.User.Auth.Cookie @@ -182,7 +182,7 @@ verifyCode mbCode action uid = do featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyProvider.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe (Public.wsStatus (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled - isSsoUser <- Data.isSamlUser uid + isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do From 23bdcc44a8d9560596d124f3f8ffb90ac915e6a5 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 3 Oct 2022 12:12:21 -0700 Subject: [PATCH 13/18] chore: refactor #2684 into this change --- services/brig/src/Brig/API/Client.hs | 2 +- services/brig/src/Brig/API/Public.hs | 20 +++++++++------- .../brig/src/Brig/Effects/GalleyProvider.hs | 4 ++++ .../src/Brig/Effects/GalleyProvider/RPC.hs | 23 +++++++++++++++++++ services/brig/src/Brig/Provider/API.hs | 4 ++-- services/brig/src/Brig/Team/API.hs | 19 ++++++++++----- 6 files changed, 55 insertions(+), 17 deletions(-) diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 31e36d65dd..3779d1bff5 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -190,7 +190,7 @@ addClientWithReAuthPolicy policy u con ip new = do lift $ do for_ old $ execDelete u con liftSem $ GalleyProvider.newClient u (clientId clt) - Intra.onClientEvent u con (ClientAdded u clt) + wrapHttp $ Intra.onClientEvent u con (ClientAdded u clt) when (clientType clt == LegalHoldClientType) $ wrapHttpClient $ Intra.onUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ for_ (userEmail usr) $ diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index d96459bee0..4fd090b890 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -54,14 +54,8 @@ import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.JwtTools (JwtTools) -import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) -import qualified Brig.IO.Intra as Intra -import Brig.Options hiding (internalEvents, sesQueue) -import qualified Brig.Provider.API as Provider import qualified Brig.Team.API as Team import qualified Brig.Team.Email as Team import Brig.Types.Activation (ActivationPair) @@ -975,13 +969,23 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do -- activation -activate :: Public.ActivationKey -> Public.ActivationCode -> (Handler r) ActivationRespWithStatus +activate + :: Members '[ + GalleyProvider + ] 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 '[ + GalleyProvider + ] r + => + Public.Activate -> (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) | dryrun = do wrapClientE (API.preverify tgt code) !>> actError diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/services/brig/src/Brig/Effects/GalleyProvider.hs index 77358b5b8e..61dfad7e88 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider.hs @@ -17,6 +17,7 @@ import Wire.API.Team.Feature import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility +import Brig.Team.Types (ShowOrHideInvitationUrl (..)) data GalleyProvider m a where CreateSelfConv :: @@ -85,5 +86,8 @@ data GalleyProvider m a where GetVerificationCodeEnabled :: TeamId -> GalleyProvider m Bool + GetExposeInvitationURLsToTeamAdmin :: + TeamId -> + GalleyProvider m ShowOrHideInvitationUrl makeSem ''GalleyProvider diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index f6b0b18d11..60d49716e9 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -37,6 +37,7 @@ import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.Sem.Logger +import Brig.Team.Types (ShowOrHideInvitationUrl (..)) interpretGalleyProviderToRPC :: Members @@ -66,6 +67,7 @@ interpretGalleyProviderToRPC = interpret $ \case MemberIsTeamOwner id' id'' -> memberIsTeamOwner id' id'' GetAllFeatureConfigsForUser m_id' -> getAllFeatureConfigsForUser m_id' GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' + GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' runIt :: HttpClientIO a -> Sem r a runIt = undefined @@ -471,3 +473,24 @@ changeTeamStatus tid s cur = do . header "Content-Type" "application/json" . expect2xx . lbytes (encode $ Team.TeamStatusUpdate s cur) + +getTeamExposeInvitationURLsToTeamAdmin :: + Members + '[ ServiceRPC 'Galley, + Error ParseException, + Logger (Msg -> Msg) + ] + r => + TeamId -> + Sem r ShowOrHideInvitationUrl +getTeamExposeInvitationURLsToTeamAdmin tid = do + debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") + response <- ServiceRPC.request @'Galley GET req + status <- wsStatus <$> decodeBodyOrThrow @(WithStatus ExposeInvitationURLsToTeamAdminConfig) "galley" response + case status of + FeatureStatusEnabled -> pure ShowInvitationUrl + FeatureStatusDisabled -> pure HideInvitationUrl + where + req = + paths ["i", "teams", toByteString' tid, "features", featureNameBS @ExposeInvitationURLsToTeamAdminConfig] + . expect2xx diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index ff59740f73..99d2a853c6 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -46,8 +46,8 @@ import qualified Brig.Provider.DB as DB import Brig.Provider.Email import qualified Brig.Provider.RPC as RPC import qualified Brig.Queue as Queue -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Team.Util import Brig.Types.Intra (AccountStatus (..), UserAccount (..)) import Brig.Types.User diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 3f48c06951..67fc18b595 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -37,7 +37,6 @@ import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import qualified Brig.Phone as Phone import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import qualified Brig.Team.DB as DB import Brig.Team.Email import Brig.Team.Types (ShowOrHideInvitationUrl (..)) @@ -64,7 +63,7 @@ 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 (Members) import System.Logger (Msg) import qualified System.Logger.Class as Log import Util.Logging (logFunction, logTeam) @@ -316,6 +315,7 @@ createInvitationPublic uid tid body = do createInvitationViaScimH :: Members '[ BlacklistStore, + GalleyProvider, UserPendingActivationStore p ] r => @@ -328,6 +328,7 @@ createInvitationViaScimH (_ ::: req) = do createInvitationViaScim :: Members '[ BlacklistStore, + GalleyProvider, UserPendingActivationStore p ] r => @@ -370,7 +371,13 @@ 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 , + GalleyProvider + ] 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 @@ -403,7 +410,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do let locale = irLocale body let inviteeName = irInviteeName body - showInvitationUrl <- lift $ wrapHttp $ Intra.getTeamExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid lift $ do iid <- liftIO DB.mkInvitationId @@ -440,7 +447,7 @@ listInvitationsH (_ ::: uid ::: tid ::: start ::: size) = do listInvitations :: Members '[GalleyProvider] r => UserId -> TeamId -> Maybe InvitationId -> Range 1 500 Int32 -> (Handler r) Public.InvitationList listInvitations uid tid start size = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ wrapHttp $ Intra.getTeamExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start size pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) @@ -454,7 +461,7 @@ getInvitationH (_ ::: uid ::: tid ::: iid) = do getInvitation :: Members '[GalleyProvider] r => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ wrapHttp $ Intra.getTeamExposeInvitationURLsToTeamAdmin tid + showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid lift $ wrapClient $ DB.lookupInvitation showInvitationUrl tid iid getInvitationByCodeH :: JSON ::: Public.InvitationCode -> (Handler r) Response From f2237887db948e91dee306bffab6bda2333710cd Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 3 Oct 2022 12:27:21 -0700 Subject: [PATCH 14/18] chore: finish fixing merge --- services/brig/src/Brig/API/Internal.hs | 3 --- services/brig/src/Brig/User/EJPD.hs | 4 ++-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 47ecb10883..d445ddfe57 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -48,10 +48,7 @@ import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider -import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.GalleyProvider (GalleyProvider) -import Brig.Effects.PasswordResetStore (PasswordResetStore) -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import qualified Brig.Team.API as Team import Brig.Team.DB (lookupInvitationByEmail) import Brig.Team.Types (ShowOrHideInvitationUrl (..)) diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 4f2537d66a..61c3b78c5c 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -26,8 +26,8 @@ import Brig.App (AppT, liftSem, wrapClient, wrapHttp) import qualified Brig.Data.Connection as Conn import Brig.Data.User (lookupUser) import qualified Brig.IO.Intra as Intra -import Brig.Sem.GalleyProvider (GalleyProvider) -import qualified Brig.Sem.GalleyProvider as GalleyProvider +import Brig.Effects.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error hiding (bool) import Control.Lens (view, (^.)) From 92f5ae728f7987f349dfe9f44bd4e0882a39d037 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 3 Oct 2022 12:28:55 -0700 Subject: [PATCH 15/18] chore: make format --- services/brig/src/Brig/API/Client.hs | 7 ++-- services/brig/src/Brig/API/Connection.hs | 2 +- services/brig/src/Brig/API/Federation.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 2 +- services/brig/src/Brig/API/Public.hs | 35 ++++++++++--------- services/brig/src/Brig/API/User.hs | 4 +-- .../brig/src/Brig/CanonicalInterpreter.hs | 2 +- .../brig/src/Brig/Effects/GalleyProvider.hs | 4 +-- .../src/Brig/Effects/GalleyProvider/RPC.hs | 4 +-- services/brig/src/Brig/Effects/RPC/IO.hs | 2 +- services/brig/src/Brig/Provider/API.hs | 4 +-- services/brig/src/Brig/Team/API.hs | 27 ++++++++------ services/brig/src/Brig/User/API/Auth.hs | 2 +- services/brig/src/Brig/User/API/Handle.hs | 2 +- services/brig/src/Brig/User/API/Search.hs | 4 +-- services/brig/src/Brig/User/Auth.hs | 4 +-- services/brig/src/Brig/User/EJPD.hs | 2 +- 17 files changed, 58 insertions(+), 51 deletions(-) diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 3779d1bff5..3da9219944 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -54,6 +54,8 @@ 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.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Effects.JwtTools (JwtTools) import qualified Brig.Effects.JwtTools as JwtTools import Brig.Effects.PublicKeyBundle (PublicKeyBundle) @@ -64,8 +66,6 @@ import Brig.IO.Intra (guardLegalhold) import qualified Brig.IO.Intra as Intra import qualified Brig.InternalEvent.Types as Internal import qualified Brig.Options as Opt -import Brig.Effects.GalleyProvider (GalleyProvider) -import qualified Brig.Effects.GalleyProvider as GalleyProvider import qualified Brig.Queue as Queue import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -92,8 +92,7 @@ import Data.String.Conversions (cs) import Imports import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities -import Polysemy (Members) -import Polysemy (Member) +import Polysemy (Member, Members) import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index 9bc8273f7f..d00b758680 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -39,9 +39,9 @@ import Brig.App import qualified Brig.Data.Connection as Data import Brig.Data.Types (resultHasMore, resultList) import qualified Brig.Data.User as Data -import qualified Brig.IO.Intra as Intra import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider +import qualified Brig.IO.Intra as Intra import Brig.Types.Connection import Brig.Types.User.Event import Control.Error diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index c06424888d..5f72178583 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -30,8 +30,8 @@ import Brig.API.Util (lookupSearchPolicy) import Brig.App import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data -import Brig.IO.Intra (notify) import Brig.Effects.GalleyProvider (GalleyProvider) +import Brig.IO.Intra (notify) import Brig.Types.User.Event import Brig.User.API.Handle import qualified Brig.User.Search.SearchIndex as Q diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d445ddfe57..7fe68751cd 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -43,12 +43,12 @@ import qualified Brig.Data.User as Data import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) import Brig.Effects.CodeStore (CodeStore) +import Brig.Effects.GalleyProvider (GalleyProvider) import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import qualified Brig.IO.Intra as Intra import Brig.Options hiding (internalEvents, sesQueue) import qualified Brig.Provider.API as Provider -import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Team.API as Team import Brig.Team.DB (lookupInvitationByEmail) import Brig.Team.Types (ShowOrHideInvitationUrl (..)) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 4fd090b890..8084396e6d 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -47,15 +47,15 @@ import qualified Brig.Data.User as Data import qualified Brig.Data.UserKey as UserKey import Brig.Effects.BlacklistPhonePrefixStore (BlacklistPhonePrefixStore) import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Options hiding (internalEvents, sesQueue) -import qualified Brig.Provider.API as Provider import Brig.Effects.CodeStore (CodeStore) import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider -import Brig.Effects.PasswordResetStore (PasswordResetStore) -import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.JwtTools (JwtTools) +import Brig.Effects.PasswordResetStore (PasswordResetStore) import Brig.Effects.PublicKeyBundle (PublicKeyBundle) +import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) +import Brig.Options hiding (internalEvents, sesQueue) +import qualified Brig.Provider.API as Provider import qualified Brig.Team.API as Team import qualified Brig.Team.Email as Team import Brig.Types.Activation (ActivationPair) @@ -969,23 +969,26 @@ updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do -- activation -activate - :: Members '[ - GalleyProvider - ] r - => - Public.ActivationKey -> Public.ActivationCode -> (Handler r) ActivationRespWithStatus +activate :: + Members + '[ GalleyProvider + ] + 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 - :: Members '[ - GalleyProvider - ] r - => - Public.Activate -> (Handler r) ActivationRespWithStatus +activateKey :: + Members + '[ GalleyProvider + ] + r => + Public.Activate -> + (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) | dryrun = do wrapClientE (API.preverify tgt code) !>> actError diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 2b6c0e20f9..c5c665077d 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -114,6 +114,8 @@ 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.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Effects.PasswordResetStore (PasswordResetStore) import qualified Brig.Effects.PasswordResetStore as E import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) @@ -124,8 +126,6 @@ import qualified Brig.InternalEvent.Types as Internal import Brig.Options hiding (Timeout, internalEvents) import Brig.Password import qualified Brig.Queue as Queue -import Brig.Effects.GalleyProvider (GalleyProvider) -import qualified Brig.Effects.GalleyProvider as GalleyProvider import qualified Brig.Team.DB as Team import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Brig.Types.Activation (ActivationPair) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 2cebf5bafb..574d7009cd 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -20,6 +20,7 @@ import Brig.Effects.ServiceRPC.IO (interpretServiceRpcToRpc) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore.Cassandra (userPendingActivationStoreToCassandra) import Brig.RPC (ParseException) +import qualified Cassandra as Cas import Control.Lens ((^.)) import Control.Monad.Catch (throwM) import Imports @@ -30,7 +31,6 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) -import qualified Cassandra as Cas type BrigCanonicalEffects = '[ PublicKeyBundle, diff --git a/services/brig/src/Brig/Effects/GalleyProvider.hs b/services/brig/src/Brig/Effects/GalleyProvider.hs index 61dfad7e88..e92c14e720 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider.hs @@ -3,6 +3,7 @@ module Brig.Effects.GalleyProvider where import Brig.API.Types +import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import qualified Data.Currency as Currency import Data.Id import Data.Json.Util (UTCTimeMillis) @@ -17,7 +18,6 @@ import Wire.API.Team.Feature import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) data GalleyProvider m a where CreateSelfConv :: @@ -88,6 +88,6 @@ data GalleyProvider m a where GalleyProvider m Bool GetExposeInvitationURLsToTeamAdmin :: TeamId -> - GalleyProvider m ShowOrHideInvitationUrl + GalleyProvider m ShowOrHideInvitationUrl makeSem ''GalleyProvider diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 60d49716e9..7a5e108fa9 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -5,10 +5,11 @@ module Brig.Effects.GalleyProvider.RPC where import Bilge hiding (head, options, requestId) import Brig.API.Types import Brig.App -import Brig.RPC import Brig.Effects.GalleyProvider (GalleyProvider (..)) import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) import qualified Brig.Effects.ServiceRPC as ServiceRPC +import Brig.RPC +import Brig.Team.Types (ShowOrHideInvitationUrl (..)) import Control.Error (hush) import Control.Lens ((^.)) import Data.Aeson hiding (json) @@ -37,7 +38,6 @@ import qualified Wire.API.Team.Member as Team import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.Sem.Logger -import Brig.Team.Types (ShowOrHideInvitationUrl (..)) interpretGalleyProviderToRPC :: Members diff --git a/services/brig/src/Brig/Effects/RPC/IO.hs b/services/brig/src/Brig/Effects/RPC/IO.hs index 1fdbb224c3..4f1b13d062 100644 --- a/services/brig/src/Brig/Effects/RPC/IO.hs +++ b/services/brig/src/Brig/Effects/RPC/IO.hs @@ -5,8 +5,8 @@ module Brig.Effects.RPC.IO where import Bilge (HttpT, MonadHttp, RequestId) import Bilge.IO (Manager, runHttpT) import Bilge.RPC -import qualified Brig.RPC as RPC import Brig.Effects.RPC +import qualified Brig.RPC as RPC import Control.Monad.Catch import Imports import Polysemy diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 99d2a853c6..3b216f787c 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -36,6 +36,8 @@ 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.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Email (mkEmailKey) import qualified Brig.InternalEvent.Types as Internal import Brig.Options (Settings (..)) @@ -46,8 +48,6 @@ import qualified Brig.Provider.DB as DB import Brig.Provider.Email import qualified Brig.Provider.RPC as RPC import qualified Brig.Queue as Queue -import Brig.Effects.GalleyProvider (GalleyProvider) -import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Team.Util import Brig.Types.Intra (AccountStatus (..), UserAccount (..)) import Brig.Types.User diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 67fc18b595..7d64a9f9c9 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -31,12 +31,12 @@ 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.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import qualified Brig.Email as Email import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) import qualified Brig.Phone as Phone -import Brig.Effects.GalleyProvider (GalleyProvider) -import qualified Brig.Effects.GalleyProvider as GalleyProvider import qualified Brig.Team.DB as DB import Brig.Team.Email import Brig.Team.Types (ShowOrHideInvitationUrl (..)) @@ -315,7 +315,7 @@ createInvitationPublic uid tid body = do createInvitationViaScimH :: Members '[ BlacklistStore, - GalleyProvider, + GalleyProvider, UserPendingActivationStore p ] r => @@ -328,7 +328,7 @@ createInvitationViaScimH (_ ::: req) = do createInvitationViaScim :: Members '[ BlacklistStore, - GalleyProvider, + GalleyProvider, UserPendingActivationStore p ] r => @@ -371,13 +371,18 @@ logInvitationRequest context action = Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) -createInvitation' - :: Members '[ - BlacklistStore , - GalleyProvider - ] r - => TeamId - -> Public.Role -> Maybe UserId -> Email -> Public.InvitationRequest -> Handler r (Public.Invitation, Public.InvitationCode) +createInvitation' :: + Members + '[ BlacklistStore, + GalleyProvider + ] + 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 diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 4e24750208..2d66ea2736 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -27,8 +27,8 @@ import Brig.API.Types import qualified Brig.API.User as User import Brig.App import Brig.Effects.BlacklistStore (BlacklistStore) -import Brig.Phone import Brig.Effects.GalleyProvider (GalleyProvider) +import Brig.Phone import Brig.Types.Intra (ReAuthUser, reAuthCode, reAuthCodeAction, reAuthPassword) import Brig.Types.User.Auth import qualified Brig.User.Auth as Auth diff --git a/services/brig/src/Brig/User/API/Handle.hs b/services/brig/src/Brig/User/API/Handle.hs index 7bc60edd18..c32303e49c 100644 --- a/services/brig/src/Brig/User/API/Handle.hs +++ b/services/brig/src/Brig/User/API/Handle.hs @@ -28,9 +28,9 @@ 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.GalleyProvider (GalleyProvider) import qualified Brig.Federation.Client as Federation import Brig.Options (searchSameTeamOnly) -import Brig.Effects.GalleyProvider (GalleyProvider) import Control.Lens (view) import Data.Handle (Handle, fromHandle) import Data.Id (UserId) diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 33af3a3a50..33cc30c3b0 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -26,10 +26,10 @@ import Brig.API.Error (fedError) import Brig.API.Handler import Brig.App import qualified Brig.Data.User as DB -import qualified Brig.Federation.Client as Federation -import qualified Brig.Options as Opts import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider +import qualified Brig.Federation.Client as Federation +import qualified Brig.Options as Opts import Brig.Team.Util (ensurePermissions) import Brig.Types.Search as Search import qualified Brig.User.API.Handle as HandleAPI diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 0541f1f77d..95ce5c13eb 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -48,11 +48,11 @@ 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.GalleyProvider (GalleyProvider) +import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Email import qualified Brig.Options as Opt import Brig.Phone -import Brig.Effects.GalleyProvider (GalleyProvider) -import qualified Brig.Effects.GalleyProvider as GalleyProvider import Brig.Types.Intra import Brig.Types.User.Auth import Brig.User.Auth.Cookie diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 61c3b78c5c..70760c9ac6 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -25,9 +25,9 @@ import Brig.API.User (lookupHandle) import Brig.App (AppT, liftSem, wrapClient, wrapHttp) import qualified Brig.Data.Connection as Conn import Brig.Data.User (lookupUser) -import qualified Brig.IO.Intra as Intra import Brig.Effects.GalleyProvider (GalleyProvider) import qualified Brig.Effects.GalleyProvider as GalleyProvider +import qualified Brig.IO.Intra as Intra import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error hiding (bool) import Control.Lens (view, (^.)) From 383d69125bb14c305009b3fa55157fa51be717c3 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 6 Oct 2022 11:58:09 -0700 Subject: [PATCH 16/18] feat: use unsafe concurrency for lookupProfiles --- services/brig/src/Brig/API/Public.hs | 4 +++ services/brig/src/Brig/API/User.hs | 10 +++--- services/brig/src/Brig/API/Util.hs | 31 +++++++++++++++++++ services/brig/src/Brig/App.hs | 8 +++++ .../brig/src/Brig/CanonicalInterpreter.hs | 4 +++ 5 files changed, 53 insertions(+), 4 deletions(-) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 8084396e6d..48c8e27436 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -138,6 +138,7 @@ 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.Now (Now) +import Wire.Sem.Concurrency -- User API ----------------------------------------------------------- @@ -170,6 +171,7 @@ servantSitemap :: CodeStore, JwtTools, PublicKeyBundle, + Concurrency 'Unsafe, Now ] r => @@ -642,6 +644,7 @@ getUser self qualifiedUserId = do listUsersByUnqualifiedIdsOrHandles :: Members '[ GalleyProvider + , Concurrency 'Unsafe ] r => UserId -> @@ -667,6 +670,7 @@ listUsersByIdsOrHandles :: forall r. Members '[ GalleyProvider + , Concurrency 'Unsafe ] r => UserId -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index c5c665077d..9cdae6c6af 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -186,6 +186,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 @@ -1437,16 +1438,17 @@ lookupProfile self other = -- Otherwise only the 'PublicProfile' is accessible for user 'self'. -- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: - Members '[GalleyProvider] r => + Members '[ GalleyProvider + , Concurrency 'Unsafe + ] r => -- | User 'self' on whose behalf the profiles are requested. Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> ExceptT FederationError (AppT r) [UserProfile] --- TODO(sandy): PERFORMANCE CHANGE: no longer concurrent lookupProfiles self others = - concat - <$> traverse + concat <$> + traverseConcurrentlyWithErrorsAppT (lookupProfilesFromDomain self) (bucketQualified others) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 01607c93bd..7046a957f3 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -23,6 +23,8 @@ module Brig.API.Util validateHandle, logEmail, traverseConcurrentlyWithErrors, + traverseConcurrentlyWithErrorsSem, + traverseConcurrentlyWithErrorsAppT, exceptTToMaybe, lookupSearchPolicy, ensureLocal, @@ -60,6 +62,9 @@ import Wire.API.Error.Brig import Wire.API.Federation.Error import Wire.API.User import Wire.API.User.Search (FederatedUserSearchPolicy (NoSearch)) +import Polysemy +import qualified Polysemy.Error as E +import qualified Wire.Sem.Concurrency as C lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] lookupProfilesMaybeFilterSameTeamOnly self us = do @@ -103,6 +108,32 @@ traverseConcurrentlyWithErrors f = <=< pooledMapConcurrentlyN 8 (runExceptT . f) ) +-- | Traverse concurrently and fail on first error. +traverseConcurrentlyWithErrorsSem :: + forall t e a r b. + (Traversable t, Member (C.Concurrency 'C.Unsafe) r) => + (a -> ExceptT e (Sem r) b) -> + t a -> + ExceptT e (Sem r) [b] +traverseConcurrentlyWithErrorsSem f = + ExceptT . E.runError + . ( traverse (either E.throw pure) + <=< C.unsafePooledMapConcurrentlyN 8 (raise . runExceptT . f) + ) + +traverseConcurrentlyWithErrorsAppT :: + forall t e a r b. + (Traversable t, Member (C.Concurrency 'C.Unsafe) r) => + (a -> ExceptT e (AppT r) b) -> + t a -> + ExceptT e (AppT r) [b] +traverseConcurrentlyWithErrorsAppT f t = do + env <- lift temporaryGetEnv + ExceptT $ AppT $ lift $ + runExceptT $ traverseConcurrentlyWithErrorsSem + (mapExceptT (lowerAppT env) . f) + t + exceptTToMaybe :: Monad m => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 4a18a47ec8..1b8a7d388d 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -78,6 +78,8 @@ module Brig.App wrapHttp, HttpClientIO (..), liftSem, + lowerAppT, + temporaryGetEnv, ) where @@ -438,6 +440,12 @@ newtype AppT r a = AppT ) via (Ap (AppT r) a) +lowerAppT :: Member (Final IO) r => Env -> AppT r a -> Sem r a +lowerAppT env = flip runReaderT env . unAppT + +temporaryGetEnv :: AppT r Env +temporaryGetEnv = AppT ask + instance Functor (AppT r) where fmap fab (AppT x0) = AppT $ fmap fab x0 diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 574d7009cd..2c11f94e2f 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -31,6 +31,8 @@ import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) +import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) type BrigCanonicalEffects = '[ PublicKeyBundle, @@ -49,6 +51,7 @@ type BrigCanonicalEffects = Error SomeException, TinyLog, Embed IO, + Concurrency 'Unsafe, Final IO ] @@ -56,6 +59,7 @@ runBrigToIO :: Env -> AppT BrigCanonicalEffects a -> IO a runBrigToIO e (AppT ma) = do (either throwM pure =<<) . runFinal + . unsafelyPerformConcurrency . embedToFinal . loggerToTinyLog (e ^. applog) . runError @SomeException From 76d3d59ad62c03f67e4d915528c4bff72675c220 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 6 Oct 2022 12:00:14 -0700 Subject: [PATCH 17/18] chore: make format --- services/brig/src/Brig/API/Public.hs | 10 +++++----- services/brig/src/Brig/API/User.hs | 12 +++++++----- services/brig/src/Brig/API/Util.hs | 15 +++++++++------ services/brig/src/Brig/CanonicalInterpreter.hs | 4 ++-- 4 files changed, 23 insertions(+), 18 deletions(-) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 48c8e27436..6620bf1f9f 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -137,8 +137,8 @@ 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.Now (Now) import Wire.Sem.Concurrency +import Wire.Sem.Now (Now) -- User API ----------------------------------------------------------- @@ -643,8 +643,8 @@ getUser self qualifiedUserId = do -- FUTUREWORK: Make servant understand that at least one of these is required listUsersByUnqualifiedIdsOrHandles :: Members - '[ GalleyProvider - , Concurrency 'Unsafe + '[ GalleyProvider, + Concurrency 'Unsafe ] r => UserId -> @@ -669,8 +669,8 @@ listUsersByUnqualifiedIdsOrHandles self mUids mHandles = do listUsersByIdsOrHandles :: forall r. Members - '[ GalleyProvider - , Concurrency 'Unsafe + '[ GalleyProvider, + Concurrency 'Unsafe ] r => UserId -> diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 9cdae6c6af..07c3d600e2 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -1438,17 +1438,19 @@ lookupProfile self other = -- Otherwise only the 'PublicProfile' is accessible for user 'self'. -- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: - Members '[ GalleyProvider - , Concurrency 'Unsafe - ] r => + Members + '[ GalleyProvider, + Concurrency 'Unsafe + ] + r => -- | User 'self' on whose behalf the profiles are requested. Local UserId -> -- | The users ('others') for which to obtain the profiles. [Qualified UserId] -> ExceptT FederationError (AppT r) [UserProfile] lookupProfiles self others = - concat <$> - traverseConcurrentlyWithErrorsAppT + concat + <$> traverseConcurrentlyWithErrorsAppT (lookupProfilesFromDomain self) (bucketQualified others) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 7046a957f3..322fbf391b 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -52,6 +52,8 @@ import Data.Qualified import Data.String.Conversions (cs) import Data.Text.Ascii (AsciiText (toText)) import Imports +import Polysemy +import qualified Polysemy.Error as E import System.Logger (Msg) import qualified System.Logger as Log import UnliftIO.Async @@ -62,8 +64,6 @@ import Wire.API.Error.Brig import Wire.API.Federation.Error import Wire.API.User import Wire.API.User.Search (FederatedUserSearchPolicy (NoSearch)) -import Polysemy -import qualified Polysemy.Error as E import qualified Wire.Sem.Concurrency as C lookupProfilesMaybeFilterSameTeamOnly :: UserId -> [UserProfile] -> (Handler r) [UserProfile] @@ -129,10 +129,13 @@ traverseConcurrentlyWithErrorsAppT :: ExceptT e (AppT r) [b] traverseConcurrentlyWithErrorsAppT f t = do env <- lift temporaryGetEnv - ExceptT $ AppT $ lift $ - runExceptT $ traverseConcurrentlyWithErrorsSem - (mapExceptT (lowerAppT env) . f) - t + ExceptT $ + AppT $ + lift $ + runExceptT $ + traverseConcurrentlyWithErrorsSem + (mapExceptT (lowerAppT env) . f) + t exceptTToMaybe :: Monad m => ExceptT e m () -> m (Maybe e) exceptTToMaybe = (pure . either Just (const Nothing)) <=< runExceptT diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 2c11f94e2f..3214185917 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -27,12 +27,12 @@ import Imports import Polysemy (Embed, Final, embedToFinal, runFinal) import Polysemy.Error (Error, mapError, runError) import Polysemy.TinyLog (TinyLog) +import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) +import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) import Wire.Sem.Logger.TinyLog (loggerToTinyLog) import Wire.Sem.Now (Now) import Wire.Sem.Now.IO (nowToIOAction) import Wire.Sem.Paging.Cassandra (InternalPaging) -import Wire.Sem.Concurrency (Concurrency, ConcurrencySafety (Unsafe)) -import Wire.Sem.Concurrency.IO (unsafelyPerformConcurrency) type BrigCanonicalEffects = '[ PublicKeyBundle, From b18e3658922c2eca1c3d067d0122a2504118ed81 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 10 Oct 2022 11:37:44 +0200 Subject: [PATCH 18/18] Remove an unused and undefined function --- services/brig/src/Brig/Effects/GalleyProvider/RPC.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs index 7a5e108fa9..e84ef002e0 100644 --- a/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs +++ b/services/brig/src/Brig/Effects/GalleyProvider/RPC.hs @@ -4,7 +4,6 @@ module Brig.Effects.GalleyProvider.RPC where import Bilge hiding (head, options, requestId) import Brig.API.Types -import Brig.App import Brig.Effects.GalleyProvider (GalleyProvider (..)) import Brig.Effects.ServiceRPC (Service (Galley), ServiceRPC) import qualified Brig.Effects.ServiceRPC as ServiceRPC @@ -69,11 +68,6 @@ interpretGalleyProviderToRPC = interpret $ \case GetVerificationCodeEnabled id' -> getVerificationCodeEnabled id' GetExposeInvitationURLsToTeamAdmin id' -> getTeamExposeInvitationURLsToTeamAdmin id' -runIt :: HttpClientIO a -> Sem r a -runIt = undefined - --- runIt = undefined - -- | Calls 'Galley.API.createSelfConversationH'. createSelfConv :: Members