From 89f67c5f71ed14e20b874f3a0c5eba338081a46f Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 27 Sep 2021 13:29:22 -0700 Subject: [PATCH] Spar Polysemy: Separate out Brig and Galley effects (#1810) * Make sure to actually wrap the action in 'wrapMonadClientSem' * Implement wrapMonadClient in terms of wrapMonadClientSem * Pull out IdP effect * Push Member IdP constraints throughout * Pull application logic out of Data and into App * Use application-level functions instead * Remove deleteTeam from Data too * Get rid of wrapMonadClientWithEnvSem * Implement wrapSpar * Undo accidental formatting * Update cabal * make format * Update changelog * Get rid of the untouchable variable in liftSem * Be very careful about wrapping in the same places * Resort exports * Changelog * DefaultSsoCode effect * ScimTokenStore effect * wip BindCookie effect * Forgot some callsites * Get tests compiling again * Get everything compiling * remove runSparCassSem * Change the tests to use IdP * Finish all SAMLUser and IdP effects refs in tests * Excise all references to IdP and SAMLUser effects * make format * make format * Remove all references to new effects * make format * Add ScimUserTimesStore effect * ScimExternalIdStore effect * make format * Implement scimExternalIdStoreToCassandra * Use Members when appropriate * make format * Fixes. * Remove unwritten BindCookie effect modules * SAMLUser -> SAMLUserStore * Don't do extraneous lifting * Changelog.d * AReqIDStore effect * make format * AssIDStore effect * Update Spar/API * Fix tests * make format * Add store/getVerdictFormat to AReqIDStore * BindCookieStore effect * Remove runSparCass* * Remove cassandra-specific utils * make format * Add BrigAccess effect * Make tests compile * make format * GalleyAccess effect * Comments/formatting * make format * Remove MonadHttp instance * Tear Brig and Galley apart into effects * Implement HTTP handlers for Brig and Galley * Remove commented instances * make format * Get tests compiling again * Stale comment * Implement MonadLogger for RunHttp * Fix build for :spec target * Add changelog * make formt --- changelog.d/5-internal/spar-no-io | 1 + services/spar/spar.cabal | 7 +- services/spar/src/Spar/API.hs | 105 ++++++--- services/spar/src/Spar/App.hs | 100 ++++----- services/spar/src/Spar/Intra/Brig.hs | 151 +------------ services/spar/src/Spar/Intra/BrigApp.hs | 202 ++++++++++++++++++ services/spar/src/Spar/Scim.hs | 5 +- services/spar/src/Spar/Scim/Auth.hs | 26 ++- services/spar/src/Spar/Scim/User.hs | 97 +++++---- services/spar/src/Spar/Sem/BrigAccess.hs | 36 ++++ services/spar/src/Spar/Sem/BrigAccess/Http.hs | 41 ++++ services/spar/src/Spar/Sem/GalleyAccess.hs | 14 ++ .../spar/src/Spar/Sem/GalleyAccess/Http.hs | 68 ++++++ .../test-integration/Test/Spar/APISpec.hs | 5 +- .../test-integration/Test/Spar/DataSpec.hs | 2 +- .../Test/Spar/Intra/BrigSpec.hs | 7 +- .../Test/Spar/Scim/UserSpec.hs | 57 ++--- services/spar/test-integration/Util/Core.hs | 18 +- services/spar/test-integration/Util/Scim.hs | 2 +- .../spar/test/Test/Spar/Intra/BrigSpec.hs | 2 +- 20 files changed, 619 insertions(+), 327 deletions(-) create mode 100644 changelog.d/5-internal/spar-no-io create mode 100644 services/spar/src/Spar/Intra/BrigApp.hs create mode 100644 services/spar/src/Spar/Sem/BrigAccess.hs create mode 100644 services/spar/src/Spar/Sem/BrigAccess/Http.hs create mode 100644 services/spar/src/Spar/Sem/GalleyAccess.hs create mode 100644 services/spar/src/Spar/Sem/GalleyAccess/Http.hs diff --git a/changelog.d/5-internal/spar-no-io b/changelog.d/5-internal/spar-no-io new file mode 100644 index 00000000000..31c02e241cf --- /dev/null +++ b/changelog.d/5-internal/spar-no-io @@ -0,0 +1 @@ +This PR pulls apart the Spar.Intra.(Brig|Galley) modules into polysemy effects, as part of ongoing work to excise all IO from Spar. diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 43574c643a9..cf3a787eee1 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d04f829f6801dc459cf2f535b387c77caf06d3d99c2d95c9b46c469c1ec8b890 +-- hash: 9e886413a5108fd6abf098b0c1d23473e27606b12e5a2a36934f2df41cd4c80d name: spar version: 0.1 @@ -26,6 +26,7 @@ library Spar.Data.Instances Spar.Error Spar.Intra.Brig + Spar.Intra.BrigApp Spar.Intra.Galley Spar.Options Spar.Orphans @@ -40,8 +41,12 @@ library Spar.Sem.AssIDStore.Cassandra Spar.Sem.BindCookieStore Spar.Sem.BindCookieStore.Cassandra + Spar.Sem.BrigAccess + Spar.Sem.BrigAccess.Http Spar.Sem.DefaultSsoCode Spar.Sem.DefaultSsoCode.Cassandra + Spar.Sem.GalleyAccess + Spar.Sem.GalleyAccess.Http Spar.Sem.IdP Spar.Sem.IdP.Cassandra Spar.Sem.IdP.Mem diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index fba2cad8fe2..ed4097fc811 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -54,14 +54,14 @@ import Galley.Types.Teams (HiddenPerm (CreateUpdateDeleteIdp, ReadIdp)) import Imports import OpenSSL.Random (randBytes) import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import Servant import qualified Servant.Multipart as Multipart import Spar.App import qualified Spar.Data as Data (GetIdPResult (..), Replaced (..), Replacing (..)) import Spar.Error -import qualified Spar.Intra.Brig as Brig -import qualified Spar.Intra.Galley as Galley +import qualified Spar.Intra.BrigApp as Brig import Spar.Orphans () import Spar.Scim import Spar.Sem.AReqIDStore (AReqIDStore) @@ -69,8 +69,12 @@ import qualified Spar.Sem.AReqIDStore as AReqIDStore import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore +import Spar.Sem.BrigAccess (BrigAccess) +import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode +import Spar.Sem.GalleyAccess (GalleyAccess) +import qualified Spar.Sem.GalleyAccess as GalleyAccess import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore @@ -91,7 +95,9 @@ app ctx = api :: Members - '[ BindCookieStore, + '[ GalleyAccess, + BrigAccess, + BindCookieStore, AssIDStore, AReqIDStore, ScimExternalIdStore, @@ -99,7 +105,8 @@ api :: ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, - SAMLUserStore + SAMLUserStore, + Error SparError ] r => Opts -> @@ -114,7 +121,9 @@ api opts = apiSSO :: Members - '[ BindCookieStore, + '[ GalleyAccess, + BrigAccess, + BindCookieStore, AssIDStore, AReqIDStore, ScimTokenStore, @@ -134,7 +143,7 @@ apiSSO opts = :<|> authresp . Just :<|> ssoSettings -apiIDP :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => ServerT APIIDP (Spar r) +apiIDP :: Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, SAMLUserStore, Error SparError] r => ServerT APIIDP (Spar r) apiIDP = idpGet :<|> idpGetRaw @@ -220,7 +229,7 @@ validateRedirectURL uri = do authresp :: forall r. - Members '[BindCookieStore, AssIDStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, BindCookieStore, AssIDStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> @@ -252,23 +261,31 @@ ssoSettings = do ---------------------------------------------------------------------------- -- IdP API -idpGet :: Member IdPEffect.IdP r => Maybe UserId -> SAML.IdPId -> Spar r IdP +idpGet :: + Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + SAML.IdPId -> + Spar r IdP idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do idp <- SAML.getIdPConfig idpid - _ <- authorizeIdP zusr idp + _ <- liftSem $ authorizeIdP zusr idp pure idp -idpGetRaw :: Member IdPEffect.IdP r => Maybe UserId -> SAML.IdPId -> Spar r RawIdPMetadata +idpGetRaw :: + Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + SAML.IdPId -> + Spar r RawIdPMetadata idpGetRaw zusr idpid = do idp <- SAML.getIdPConfig idpid - _ <- authorizeIdP zusr idp + _ <- liftSem $ authorizeIdP zusr idp wrapMonadClientSem (IdPEffect.getRawMetadata idpid) >>= \case Just txt -> pure $ RawIdPMetadata txt Nothing -> throwSpar $ SparIdPNotFound (cs $ show idpid) -idpGetAll :: Member IdPEffect.IdP r => Maybe UserId -> Spar r IdPList +idpGetAll :: Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => Maybe UserId -> Spar r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do - teamid <- Brig.getZUsrCheckPerm zusr ReadIdp + teamid <- liftSem $ Brig.getZUsrCheckPerm zusr ReadIdp _idplProviders <- wrapMonadClientSem $ IdPEffect.getConfigsByTeam teamid pure IdPList {..} @@ -280,10 +297,16 @@ idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do -- matter what the team size, it shouldn't choke any servers, just the client (which is -- probably curl running locally on one of the spar instances). -- https://github.com/zinfra/backend-issues/issues/1314 -idpDelete :: forall r. Members '[ScimTokenStore, SAMLUserStore, IdPEffect.IdP] r => Maybe UserId -> SAML.IdPId -> Maybe Bool -> Spar r NoContent +idpDelete :: + forall r. + Members '[GalleyAccess, BrigAccess, ScimTokenStore, SAMLUserStore, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + SAML.IdPId -> + Maybe Bool -> + Spar r NoContent idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do idp <- SAML.getIdPConfig idpid - _ <- authorizeIdP zusr idp + _ <- liftSem $ authorizeIdP zusr idp let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer team = idp ^. SAML.idpExtraInfo . wiTeam -- if idp is not empty: fail or purge @@ -292,7 +315,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons doPurge = do some <- wrapMonadClientSem (SAMLUserStore.getSomeByIssuer issuer) forM_ some $ \(uref, uid) -> do - Brig.deleteBrigUser uid + liftSem $ BrigAccess.delete uid wrapMonadClientSem (SAMLUserStore.delete uid uref) unless (null some) doPurge when (not idpIsEmpty) $ do @@ -335,14 +358,27 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons -- | This handler only does the json parsing, and leaves all authorization checks and -- application logic to 'idpCreateXML'. -idpCreate :: Members '[ScimTokenStore, IdPEffect.IdP] r => Maybe UserId -> IdPMetadataInfo -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Spar r IdP +idpCreate :: + Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + IdPMetadataInfo -> + Maybe SAML.IdPId -> + Maybe WireIdPAPIVersion -> + Spar r IdP idpCreate zusr (IdPMetadataValue raw xml) midpid apiversion = idpCreateXML zusr raw xml midpid apiversion -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. -idpCreateXML :: Members '[ScimTokenStore, IdPEffect.IdP] r => Maybe UserId -> Text -> SAML.IdPMetadata -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Spar r IdP +idpCreateXML :: + Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + Text -> + SAML.IdPMetadata -> + Maybe SAML.IdPId -> + Maybe WireIdPAPIVersion -> + Spar r IdP idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do - teamid <- Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp - Galley.assertSSOEnabled teamid + teamid <- liftSem $ Brig.getZUsrCheckPerm zusr CreateUpdateDeleteIdp + liftSem $ GalleyAccess.assertSSOEnabled teamid assertNoScimOrNoIdP teamid idp <- validateNewIdP apiversion idpmeta teamid mReplaces wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw @@ -433,13 +469,24 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validate -- | FUTUREWORK: 'idpUpdateXML' is only factored out of this function for symmetry with -- 'idpCreate', which is not a good reason. make this one function and pass around -- 'IdPMetadataInfo' directly where convenient. -idpUpdate :: Member IdPEffect.IdP r => Maybe UserId -> IdPMetadataInfo -> SAML.IdPId -> Spar r IdP +idpUpdate :: + Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + IdPMetadataInfo -> + SAML.IdPId -> + Spar r IdP idpUpdate zusr (IdPMetadataValue raw xml) idpid = idpUpdateXML zusr raw xml idpid -idpUpdateXML :: Member IdPEffect.IdP r => Maybe UserId -> Text -> SAML.IdPMetadata -> SAML.IdPId -> Spar r IdP +idpUpdateXML :: + Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => + Maybe UserId -> + Text -> + SAML.IdPMetadata -> + SAML.IdPId -> + Spar r IdP idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^. SAML.idpId)) $ do (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid - Galley.assertSSOEnabled teamid + liftSem $ GalleyAccess.assertSSOEnabled teamid wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw -- (if raw metadata is stored and then spar goes out, raw metadata won't match the -- structured idp config. since this will lead to a 5xx response, the client is epected to @@ -454,7 +501,7 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^ validateIdPUpdate :: forall m r. (HasCallStack, m ~ Spar r) => - Member IdPEffect.IdP r => + Members '[GalleyAccess, BrigAccess, IdPEffect.IdP, Error SparError] r => Maybe UserId -> SAML.IdPMetadata -> SAML.IdPId -> @@ -464,7 +511,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just wrapMonadClientSem (IdPEffect.getConfig _idpId) >>= \case Nothing -> throwError errUnknownIdPId Just idp -> pure idp - teamId <- authorizeIdP zusr previousIdP + teamId <- liftSem $ authorizeIdP zusr previousIdP unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do throwError errUnknownIdP _idpExtraInfo <- do @@ -502,14 +549,14 @@ withDebugLog msg showval action = do pure val authorizeIdP :: - (HasCallStack, MonadError SparError m, SAML.SP m, Galley.MonadSparToGalley m, Brig.MonadSparToBrig m) => + (HasCallStack, Members '[GalleyAccess, BrigAccess, Error SparError] r) => Maybe UserId -> IdP -> - m TeamId -authorizeIdP Nothing _ = throwSpar (SparNoPermission (cs $ show CreateUpdateDeleteIdp)) + Sem r TeamId +authorizeIdP Nothing _ = throw (SAML.CustomError $ SparNoPermission (cs $ show CreateUpdateDeleteIdp)) authorizeIdP (Just zusr) idp = do let teamid = idp ^. SAML.idpExtraInfo . wiTeam - Galley.assertHasPermission teamid CreateUpdateDeleteIdp zusr + GalleyAccess.assertHasPermission teamid CreateUpdateDeleteIdp zusr pure teamid enforceHttps :: URI.URI -> Spar r () diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 7aeef5a9370..67a73acafff 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -92,8 +92,7 @@ import Servant import qualified Servant.Multipart as Multipart import qualified Spar.Data as Data (GetIdPResult (..)) import Spar.Error -import qualified Spar.Intra.Brig as Intra -import qualified Spar.Intra.Galley as Intra +import qualified Spar.Intra.BrigApp as Intra import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) import qualified Spar.Sem.AReqIDStore as AReqIDStore @@ -104,8 +103,14 @@ import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.BindCookieStore (BindCookieStore) import qualified Spar.Sem.BindCookieStore as BindCookieStore import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) +import Spar.Sem.BrigAccess (BrigAccess) +import qualified Spar.Sem.BrigAccess as BrigAccess +import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) +import Spar.Sem.GalleyAccess (GalleyAccess) +import qualified Spar.Sem.GalleyAccess as GalleyAccess +import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import Spar.Sem.IdP (GetIdPResult (..)) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.IdP.Cassandra (idPToCassandra) @@ -265,17 +270,17 @@ insertUser uref uid = wrapMonadClientSem $ SAMLUserStore.insert uref uid -- the team with valid SAML credentials. -- -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR. (in https://github.com/wireapp/wire-server/pull/1410, undo https://github.com/wireapp/wire-server/pull/1418) -getUserIdByUref :: Member SAMLUserStore r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult UserId) +getUserIdByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult UserId) getUserIdByUref mbteam uref = userId <$$> getUserByUref mbteam uref -getUserByUref :: Member SAMLUserStore r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult User) +getUserByUref :: Members '[BrigAccess, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult User) getUserByUref mbteam uref = do muid <- wrapMonadClientSem $ SAMLUserStore.get uref case muid of Nothing -> pure GetUserNotFound Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - Intra.getBrigUser withpending uid >>= \case + liftSem (Intra.getBrigUser withpending uid) >>= \case Nothing -> pure GetUserNotFound Just user | isNothing (userTeam user) -> pure GetUserNoTeam @@ -296,14 +301,14 @@ instance Functor GetUserResult where fmap _ GetUserWrongTeam = GetUserWrongTeam -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR -getUserIdByScimExternalId :: Member ScimExternalIdStore r => TeamId -> Email -> Spar r (Maybe UserId) +getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Spar r (Maybe UserId) getUserIdByScimExternalId tid email = do muid <- wrapMonadClientSem $ (ScimExternalIdStore.lookup tid email) case muid of Nothing -> pure Nothing Just uid -> do let withpending = Intra.WithPendingInvitations -- see haddocks above - itis <- isJust <$> Intra.getBrigUserTeam withpending uid + itis <- liftSem $ isJust <$> Intra.getBrigUserTeam withpending uid pure $ if itis then Just uid else Nothing -- | Create a fresh 'UserId', store it on C* locally together with 'SAML.UserRef', then @@ -322,23 +327,23 @@ getUserIdByScimExternalId tid email = do -- FUTUREWORK: once we support , brig will refuse to delete -- users that have an sso id, unless the request comes from spar. then we can make users -- undeletable in the team admin page, and ask admins to go talk to their IdP system. -createSamlUserWithId :: Member SAMLUserStore r => TeamId -> UserId -> SAML.UserRef -> Spar r () +createSamlUserWithId :: Members '[BrigAccess, SAMLUserStore] r => TeamId -> UserId -> SAML.UserRef -> Spar r () createSamlUserWithId teamid buid suid = do uname <- either (throwSpar . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- Intra.createBrigUserSAML suid buid teamid uname ManagedByWire + buid' <- liftSem $ BrigAccess.createSAML suid buid teamid uname ManagedByWire assert (buid == buid') $ pure () insertUser suid buid -- | If the team has no scim token, call 'createSamlUser'. Otherwise, raise "invalid -- credentials". -autoprovisionSamlUser :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r UserId +autoprovisionSamlUser :: Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r UserId autoprovisionSamlUser mbteam suid = do buid <- Id <$> liftIO UUID.nextRandom autoprovisionSamlUserWithId mbteam buid suid pure buid -- | Like 'autoprovisionSamlUser', but for an already existing 'UserId'. -autoprovisionSamlUserWithId :: forall r. Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> UserId -> SAML.UserRef -> Spar r () +autoprovisionSamlUserWithId :: forall r. Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> UserId -> SAML.UserRef -> Spar r () autoprovisionSamlUserWithId mbteam buid suid = do idp <- getIdPConfigByIssuerOptionalSPId (suid ^. uidTenant) mbteam guardReplacedIdP idp @@ -362,7 +367,7 @@ autoprovisionSamlUserWithId mbteam buid suid = do -- | If user's 'NameID' is an email address and the team has email validation for SSO enabled, -- make brig initiate the email validate procedure. -validateEmailIfExists :: forall r. UserId -> SAML.UserRef -> Spar r () +validateEmailIfExists :: forall r. Members '[GalleyAccess, BrigAccess] r => UserId -> SAML.UserRef -> Spar r () validateEmailIfExists uid = \case (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> doValidate (CI.original email) _ -> pure () @@ -370,10 +375,10 @@ validateEmailIfExists uid = \case doValidate :: SAMLEmail.Email -> Spar r () doValidate email = do enabled <- do - tid <- Intra.getBrigUserTeam Intra.NoPendingInvitations uid - maybe (pure False) Intra.isEmailValidationEnabledTeam tid + tid <- liftSem $ Intra.getBrigUserTeam Intra.NoPendingInvitations uid + maybe (pure False) (liftSem . GalleyAccess.isEmailValidationEnabledTeam) tid when enabled $ do - Intra.updateEmail uid (Intra.emailFromSAML email) + liftSem $ BrigAccess.updateEmail uid (Intra.emailFromSAML email) -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, -- register a the user under its SAML credentials and write the 'UserRef' into the @@ -381,7 +386,7 @@ validateEmailIfExists uid = \case -- -- Before returning, change account status or fail if account is nto active or pending an -- invitation. -bindUser :: Members '[IdPEffect.IdP, SAMLUserStore] r => UserId -> SAML.UserRef -> Spar r UserId +bindUser :: Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => UserId -> SAML.UserRef -> Spar r UserId bindUser buid userref = do oldStatus <- do let err :: Spar r a @@ -393,20 +398,20 @@ bindUser buid userref = do Data.GetIdPDanglingId _ -> err -- database inconsistency Data.GetIdPNonUnique is -> throwSpar $ SparUserRefInNoOrMultipleTeams (cs $ show (buid, is)) Data.GetIdPWrongTeam _ -> err -- impossible - acc <- Intra.getBrigUserAccount Intra.WithPendingInvitations buid >>= maybe err pure + acc <- liftSem (BrigAccess.getAccount Intra.WithPendingInvitations buid) >>= maybe err pure teamid' :: TeamId <- userTeam (accountUser acc) & maybe err pure unless (teamid' == teamid) err pure (accountStatus acc) insertUser userref buid buid <$ do - Intra.setBrigUserVeid buid (UrefOnly userref) + liftSem $ BrigAccess.setVeid buid (UrefOnly userref) let err = throwSpar . SparBindFromBadAccountStatus . cs . show case oldStatus of Active -> pure () Suspended -> err oldStatus Deleted -> err oldStatus Ephemeral -> err oldStatus - PendingInvitation -> Intra.setStatus buid Active + PendingInvitation -> liftSem $ BrigAccess.setStatus buid Active instance ( r @@ -420,6 +425,8 @@ instance IdPEffect.IdP, SAMLUserStore, Embed (Cas.Client), + BrigAccess, + GalleyAccess, ReaderEff.Reader Opts, Error TTLError, Error SparError, @@ -444,38 +451,25 @@ instance runError @SparError $ ttlErrorToSparError $ ReaderEff.runReader (sparCtxOpts ctx) $ - interpretClientToIO (sparCtxCas ctx) $ - samlUserStoreToCassandra @Cas.Client $ - idPToCassandra @Cas.Client $ - defaultSsoCodeToCassandra $ - scimTokenStoreToCassandra $ - scimUserTimesStoreToCassandra $ - scimExternalIdStoreToCassandra $ - aReqIDStoreToCassandra $ - assIDStoreToCassandra $ - bindCookieStoreToCassandra $ - runExceptT $ - runReaderT action ctx + galleyAccessToHttp (sparCtxLogger ctx) (sparCtxHttpManager ctx) (sparCtxHttpGalley ctx) $ + brigAccessToHttp (sparCtxLogger ctx) (sparCtxHttpManager ctx) (sparCtxHttpBrig ctx) $ + interpretClientToIO (sparCtxCas ctx) $ + samlUserStoreToCassandra @Cas.Client $ + idPToCassandra @Cas.Client $ + defaultSsoCodeToCassandra $ + scimTokenStoreToCassandra $ + scimUserTimesStoreToCassandra $ + scimExternalIdStoreToCassandra $ + aReqIDStoreToCassandra $ + assIDStoreToCassandra $ + bindCookieStoreToCassandra $ + runExceptT $ + runReaderT action ctx throwErrorAsHandlerException :: Either SparError a -> Handler a throwErrorAsHandlerException (Left err) = sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError throwErrorAsHandlerException (Right a) = pure a -instance MonadHttp (Spar r) where - handleRequestWithCont req handler = do - manager <- asks sparCtxHttpManager - liftIO $ withResponse req manager handler - -instance Intra.MonadSparToBrig (Spar r) where - call modreq = do - req <- asks sparCtxHttpBrig - httpLbs req modreq - -instance Intra.MonadSparToGalley (Spar r) where - call modreq = do - req <- asks sparCtxHttpGalley - httpLbs req modreq - -- | The from of the response on the finalize-login request depends on the verdict (denied or -- granted), plus the choice that the client has made during the initiate-login request. Here we -- call either 'verdictHandlerWeb' or 'verdictHandlerMobile', resp., on the 'SAML.AccessVerdict'. @@ -487,7 +481,7 @@ instance Intra.MonadSparToGalley (Spar r) where -- latter. verdictHandler :: HasCallStack => - Members '[BindCookieStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, BindCookieStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AuthnResponse -> @@ -519,7 +513,7 @@ data VerdictHandlerResult verdictHandlerResult :: HasCallStack => - Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> @@ -544,7 +538,7 @@ catchVerdictErrors = (`catchError` hndlr) -- | If a user attempts to login presenting a new IdP issuer, but there is no entry in -- @"spar.user"@ for her: lookup @"old_issuers"@ from @"spar.idp"@ for the new IdP, and -- traverse the old IdPs in search for the old entry. Return that old entry. -findUserIdWithOldIssuer :: forall r. Members '[IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult (SAML.UserRef, UserId)) +findUserIdWithOldIssuer :: forall r. Members '[BrigAccess, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> SAML.UserRef -> Spar r (GetUserResult (SAML.UserRef, UserId)) findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do idp <- getIdPConfigByIssuerOptionalSPId issuer mbteam let tryFind :: GetUserResult (SAML.UserRef, UserId) -> Issuer -> Spar r (GetUserResult (SAML.UserRef, UserId)) @@ -556,15 +550,15 @@ findUserIdWithOldIssuer mbteam (SAML.UserRef issuer subject) = do -- | After a user has been found using 'findUserWithOldIssuer', update it everywhere so that -- the old IdP is not needed any more next time. -moveUserToNewIssuer :: Member SAMLUserStore r => SAML.UserRef -> SAML.UserRef -> UserId -> Spar r () +moveUserToNewIssuer :: Members '[BrigAccess, SAMLUserStore] r => SAML.UserRef -> SAML.UserRef -> UserId -> Spar r () moveUserToNewIssuer oldUserRef newUserRef uid = do wrapMonadClientSem $ SAMLUserStore.insert newUserRef uid - Intra.setBrigUserVeid uid (UrefOnly newUserRef) + liftSem $ BrigAccess.setVeid uid (UrefOnly newUserRef) wrapMonadClientSem $ SAMLUserStore.delete uid oldUserRef verdictHandlerResultCore :: HasCallStack => - Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> @@ -614,7 +608,7 @@ verdictHandlerResultCore bindCky mbteam = \case -- to see why, consider the condition on the call to 'findUserWithOldIssuer' above. error "impossible." SAML.logger SAML.Debug ("granting sso login for " <> show uid) - cky <- Intra.ssoLogin uid + cky <- liftSem $ BrigAccess.ssoLogin uid pure $ VerifyHandlerGranted cky uid -- | If the client is web, it will be served with an HTML page that it can process to decide whether diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 751911f3fdd..fd118824789 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -19,21 +19,8 @@ -- | Client functions for interacting with the Brig API. module Spar.Intra.Brig - ( veidToUserSSOId, - urefToExternalId, - urefToEmail, - veidFromBrigUser, - veidFromUserSSOId, - mkUserName, - renderValidExternalId, - emailFromSAML, - emailToSAML, - emailToSAMLNameID, - emailFromSAMLNameID, + ( MonadSparToBrig (..), getBrigUserAccount, - HavePendingInvitations (..), - getBrigUser, - getBrigUserTeam, getBrigUserByHandle, getBrigUserByEmail, getBrigUserRichInfo, @@ -47,16 +34,11 @@ module Spar.Intra.Brig createBrigUserSAML, createBrigUserNoSAML, updateEmail, - getZUsrCheckPerm, - authorizeScimTokenManagement, ensureReAuthorised, ssoLogin, - parseResponse, - MonadSparToBrig (..), getStatus, getStatusMaybe, setStatus, - giveDefaultHandle, ) where @@ -64,22 +46,17 @@ import Bilge import Brig.Types.Intra import Brig.Types.User import Brig.Types.User.Auth (SsoLogin (..)) -import Control.Lens import Control.Monad.Except import Data.ByteString.Conversion -import qualified Data.CaseInsensitive as CI -import Data.Handle (Handle (Handle, fromHandle)) +import Data.Handle (Handle (fromHandle)) import Data.Id (Id (Id), TeamId, UserId) import Data.Misc (PlainTextPassword) import Data.String.Conversions -import Galley.Types.Teams (HiddenPerm (CreateReadDeleteScimToken), IsPerm) import Imports import Network.HTTP.Types.Method import qualified Network.Wai.Utilities.Error as Wai import qualified SAML2.WebSSO as SAML -import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Spar.Error -import Spar.Intra.Galley as Galley (MonadSparToGalley, assertHasPermission) import qualified System.Logger.Class as Log import Web.Cookie import Wire.API.User @@ -94,59 +71,6 @@ veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromE urefToUserSSOId :: SAML.UserRef -> UserSSOId urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) -veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId -veidFromUserSSOId = \case - UserSSOId tenant subject -> - case (SAML.decodeElem $ cs tenant, SAML.decodeElem $ cs subject) of - (Right t, Right s) -> do - let uref = SAML.UserRef t s - case urefToEmail uref of - Nothing -> pure $ UrefOnly uref - Just email -> pure $ EmailAndUref email uref - (Left msg, _) -> throwError msg - (_, Left msg) -> throwError msg - UserScimExternalId email -> - maybe - (throwError "externalId not an email and no issuer") - (pure . EmailOnly) - (parseEmail email) - -urefToExternalId :: SAML.UserRef -> Maybe Text -urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject - -urefToEmail :: SAML.UserRef -> Maybe Email -urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of - SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email - _ -> Nothing - --- | If the brig user has a 'UserSSOId', transform that into a 'ValidExternalId' (this is a --- total function as long as brig obeys the api). Otherwise, if the user has an email, we can --- construct a return value from that (and an optional saml issuer). If a user only has a --- phone number, or no identity at all, throw an error. --- --- Note: the saml issuer is only needed in the case where a user has been invited via team --- settings and is now onboarded to saml/scim. If this case can safely be ruled out, it's ok --- to just set it to 'Nothing'. -veidFromBrigUser :: MonadError String m => User -> Maybe SAML.Issuer -> m ValidExternalId -veidFromBrigUser usr mIssuer = case (userSSOId usr, userEmail usr, mIssuer) of - (Just ssoid, _, _) -> veidFromUserSSOId ssoid - (Nothing, Just email, Just issuer) -> pure $ EmailAndUref email (SAML.UserRef issuer (emailToSAMLNameID email)) - (Nothing, Just email, Nothing) -> pure $ EmailOnly email - (Nothing, Nothing, _) -> throwError "user has neither ssoIdentity nor userEmail" - --- | Take a maybe text, construct a 'Name' from what we have in a scim user. If the text --- isn't present, use an email address or a saml subject (usually also an email address). If --- both are 'Nothing', fail. -mkUserName :: Maybe Text -> ValidExternalId -> Either String Name -mkUserName (Just n) = const $ mkName n -mkUserName Nothing = - runValidExternalId - (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject)) - (\email -> mkName (fromEmail email)) - -renderValidExternalId :: ValidExternalId -> Maybe Text -renderValidExternalId = runValidExternalId urefToExternalId (Just . fromEmail) - -- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the -- cookie in the response, and the redirect will make the client negotiate a fresh auth token. -- (This is the easiest way, since the login-request that we are in the middle of responding to here @@ -158,22 +82,6 @@ respToCookie resp = do unless (statusCode resp == 200) crash maybe crash (pure . parseSetCookie) $ getHeader "Set-Cookie" resp -emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email -emailFromSAML = fromJust . parseEmail . SAMLEmail.render - -emailToSAML :: HasCallStack => Email -> SAMLEmail.Email -emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString - --- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this --- function total without all that praying and hoping. -emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID -emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail - -emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email -emailFromSAMLNameID nid = case nid ^. SAML.nameID of - SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email - _ -> Nothing - ---------------------------------------------------------------------- class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where @@ -240,9 +148,6 @@ updateEmail buid email = do 202 -> pure () _ -> rethrow "brig" resp -getBrigUser :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe User) -getBrigUser ifpend = (accountUser <$$>) . getBrigUserAccount ifpend - -- | Get a user; returns 'Nothing' if the user was not found or has been deleted. getBrigUserAccount :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe UserAccount) getBrigUserAccount havePending buid = do @@ -412,33 +317,6 @@ deleteBrigUser buid = do unless (statusCode resp == 202) $ rethrow "brig" resp --- | Check that an id maps to an user on brig that is 'Active' (or optionally --- 'PendingInvitation') and has a team id. -getBrigUserTeam :: (HasCallStack, MonadSparToBrig m) => HavePendingInvitations -> UserId -> m (Maybe TeamId) -getBrigUserTeam ifpend = fmap (userTeam =<<) . getBrigUser ifpend - --- | Pull team id for z-user from brig. Check permission in galley. Return team id. Fail if --- permission check fails or the user is not in status 'Active'. -getZUsrCheckPerm :: - (HasCallStack, SAML.SP m, MonadSparToBrig m, MonadSparToGalley m, IsPerm perm, Show perm) => - Maybe UserId -> - perm -> - m TeamId -getZUsrCheckPerm Nothing _ = throwSpar SparMissingZUsr -getZUsrCheckPerm (Just uid) perm = do - getBrigUserTeam NoPendingInvitations uid - >>= maybe - (throwSpar SparNotInTeam) - (\teamid -> teamid <$ Galley.assertHasPermission teamid perm uid) - -authorizeScimTokenManagement :: (HasCallStack, SAML.SP m, MonadSparToBrig m, MonadSparToGalley m) => Maybe UserId -> m TeamId -authorizeScimTokenManagement Nothing = throwSpar SparMissingZUsr -authorizeScimTokenManagement (Just uid) = do - getBrigUserTeam NoPendingInvitations uid - >>= maybe - (throwSpar SparNotInTeam) - (\teamid -> teamid <$ Galley.assertHasPermission teamid CreateReadDeleteScimToken uid) - -- | Verify user's password (needed for certain powerful operations). ensureReAuthorised :: (HasCallStack, MonadSparToBrig m) => @@ -465,7 +343,7 @@ ensureReAuthorised (Just uid) secret = do -- -- If brig responds with status >=400;<500, return Nothing. Otherwise, crash (500). ssoLogin :: - (HasCallStack, SAML.HasConfig m, MonadSparToBrig m) => + (HasCallStack, MonadSparToBrig m) => UserId -> m SetCookie ssoLogin buid = do @@ -509,26 +387,3 @@ setStatus uid status = do case statusCode resp of 200 -> pure () _ -> rethrow "brig" resp - --- | If the user has no 'Handle', set it to its 'UserId' and update the user in brig. --- Return the handle the user now has (the old one if it existed, the newly created one --- otherwise). --- --- RATIONALE: Finding the handle can fail for users that have been created without scim, and --- have stopped the onboarding process at the point where they are asked by the client to --- enter a handle. --- --- We make up a handle in this case, and the scim peer can find the user, see that the handle --- is not the one it expects, and update it. --- --- We cannot simply respond with 404 in this case, because the user exists. 404 would suggest --- do the scim peer that it should post the user to create it, but that would create a new --- user instead of finding the old that should be put under scim control. -giveDefaultHandle :: (HasCallStack, MonadSparToBrig m) => User -> m Handle -giveDefaultHandle usr = case userHandle usr of - Just handle -> pure handle - Nothing -> do - let handle = Handle . cs . toByteString' $ uid - uid = userId usr - setBrigUserHandle uid handle - pure handle diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs new file mode 100644 index 00000000000..6c4d2d34f0e --- /dev/null +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- | Client functions for interacting with the Brig API. +module Spar.Intra.BrigApp + ( veidToUserSSOId, + urefToExternalId, + urefToEmail, + veidFromBrigUser, + veidFromUserSSOId, + mkUserName, + renderValidExternalId, + emailFromSAML, + emailToSAML, + emailToSAMLNameID, + emailFromSAMLNameID, + HavePendingInvitations (..), + getBrigUser, + getBrigUserTeam, + getZUsrCheckPerm, + authorizeScimTokenManagement, + parseResponse, + giveDefaultHandle, + ) +where + +import Brig.Types.Intra +import Brig.Types.User +import Control.Lens +import Control.Monad.Except +import Data.ByteString.Conversion +import qualified Data.CaseInsensitive as CI +import Data.Handle (Handle (Handle)) +import Data.Id (TeamId, UserId) +import Data.String.Conversions +import Galley.Types.Teams (HiddenPerm (CreateReadDeleteScimToken), IsPerm) +import Imports +import Polysemy +import Polysemy.Error +import qualified SAML2.WebSSO as SAML +import qualified SAML2.WebSSO.Types.Email as SAMLEmail +import Spar.Error +import Spar.Sem.BrigAccess (BrigAccess) +import qualified Spar.Sem.BrigAccess as BrigAccess +import Spar.Sem.GalleyAccess (GalleyAccess) +import qualified Spar.Sem.GalleyAccess as GalleyAccess +import Wire.API.User +import Wire.API.User.Scim (ValidExternalId (..), runValidExternalId) + +---------------------------------------------------------------------- + +veidToUserSSOId :: ValidExternalId -> UserSSOId +veidToUserSSOId = runValidExternalId urefToUserSSOId (UserScimExternalId . fromEmail) + +urefToUserSSOId :: SAML.UserRef -> UserSSOId +urefToUserSSOId (SAML.UserRef t s) = UserSSOId (cs $ SAML.encodeElem t) (cs $ SAML.encodeElem s) + +veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId +veidFromUserSSOId = \case + UserSSOId tenant subject -> + case (SAML.decodeElem $ cs tenant, SAML.decodeElem $ cs subject) of + (Right t, Right s) -> do + let uref = SAML.UserRef t s + case urefToEmail uref of + Nothing -> pure $ UrefOnly uref + Just email -> pure $ EmailAndUref email uref + (Left msg, _) -> throwError msg + (_, Left msg) -> throwError msg + UserScimExternalId email -> + maybe + (throwError "externalId not an email and no issuer") + (pure . EmailOnly) + (parseEmail email) + +urefToExternalId :: SAML.UserRef -> Maybe Text +urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject + +urefToEmail :: SAML.UserRef -> Maybe Email +urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of + SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email + _ -> Nothing + +-- | If the brig user has a 'UserSSOId', transform that into a 'ValidExternalId' (this is a +-- total function as long as brig obeys the api). Otherwise, if the user has an email, we can +-- construct a return value from that (and an optional saml issuer). If a user only has a +-- phone number, or no identity at all, throw an error. +-- +-- Note: the saml issuer is only needed in the case where a user has been invited via team +-- settings and is now onboarded to saml/scim. If this case can safely be ruled out, it's ok +-- to just set it to 'Nothing'. +veidFromBrigUser :: MonadError String m => User -> Maybe SAML.Issuer -> m ValidExternalId +veidFromBrigUser usr mIssuer = case (userSSOId usr, userEmail usr, mIssuer) of + (Just ssoid, _, _) -> veidFromUserSSOId ssoid + (Nothing, Just email, Just issuer) -> pure $ EmailAndUref email (SAML.UserRef issuer (emailToSAMLNameID email)) + (Nothing, Just email, Nothing) -> pure $ EmailOnly email + (Nothing, Nothing, _) -> throwError "user has neither ssoIdentity nor userEmail" + +-- | Take a maybe text, construct a 'Name' from what we have in a scim user. If the text +-- isn't present, use an email address or a saml subject (usually also an email address). If +-- both are 'Nothing', fail. +mkUserName :: Maybe Text -> ValidExternalId -> Either String Name +mkUserName (Just n) = const $ mkName n +mkUserName Nothing = + runValidExternalId + (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject)) + (\email -> mkName (fromEmail email)) + +renderValidExternalId :: ValidExternalId -> Maybe Text +renderValidExternalId = runValidExternalId urefToExternalId (Just . fromEmail) + +emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email +emailFromSAML = fromJust . parseEmail . SAMLEmail.render + +emailToSAML :: HasCallStack => Email -> SAMLEmail.Email +emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString + +-- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this +-- function total without all that praying and hoping. +emailToSAMLNameID :: HasCallStack => Email -> SAML.NameID +emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmail + +emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email +emailFromSAMLNameID nid = case nid ^. SAML.nameID of + SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email + _ -> Nothing + +---------------------------------------------------------------------- + +getBrigUser :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe User) +getBrigUser ifpend = (accountUser <$$>) . BrigAccess.getAccount ifpend + +-- | Check that an id maps to an user on brig that is 'Active' (or optionally +-- 'PendingInvitation') and has a team id. +getBrigUserTeam :: (HasCallStack, Member BrigAccess r) => HavePendingInvitations -> UserId -> Sem r (Maybe TeamId) +getBrigUserTeam ifpend = fmap (userTeam =<<) . getBrigUser ifpend + +-- | Pull team id for z-user from brig. Check permission in galley. Return team id. Fail if +-- permission check fails or the user is not in status 'Active'. +getZUsrCheckPerm :: + forall r perm. + (HasCallStack, Members '[BrigAccess, GalleyAccess, Error SparError] r, IsPerm perm, Show perm) => + Maybe UserId -> + perm -> + Sem r TeamId +getZUsrCheckPerm Nothing _ = throw $ SAML.CustomError SparMissingZUsr +getZUsrCheckPerm (Just uid) perm = do + getBrigUserTeam NoPendingInvitations uid + >>= maybe + (throw $ SAML.CustomError SparNotInTeam) + (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid perm uid) + +authorizeScimTokenManagement :: + forall r. + (HasCallStack, Members '[BrigAccess, GalleyAccess, Error SparError] r) => + Maybe UserId -> + Sem r TeamId +authorizeScimTokenManagement Nothing = throw $ SAML.CustomError SparMissingZUsr +authorizeScimTokenManagement (Just uid) = do + getBrigUserTeam NoPendingInvitations uid + >>= maybe + (throw $ SAML.CustomError SparNotInTeam) + (\teamid -> teamid <$ GalleyAccess.assertHasPermission teamid CreateReadDeleteScimToken uid) + +-- | If the user has no 'Handle', set it to its 'UserId' and update the user in brig. +-- Return the handle the user now has (the old one if it existed, the newly created one +-- otherwise). +-- +-- RATIONALE: Finding the handle can fail for users that have been created without scim, and +-- have stopped the onboarding process at the point where they are asked by the client to +-- enter a handle. +-- +-- We make up a handle in this case, and the scim peer can find the user, see that the handle +-- is not the one it expects, and update it. +-- +-- We cannot simply respond with 404 in this case, because the user exists. 404 would suggest +-- do the scim peer that it should post the user to create it, but that would create a new +-- user instead of finding the old that should be put under scim control. +giveDefaultHandle :: (HasCallStack, Member BrigAccess r) => User -> Sem r Handle +giveDefaultHandle usr = case userHandle usr of + Just handle -> pure handle + Nothing -> do + let handle = Handle . cs . toByteString' $ uid + uid = userId usr + BrigAccess.setHandle uid handle + pure handle diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index 3e16b92bd79..5da6d5d02d5 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -69,6 +69,7 @@ import Control.Monad.Except import Data.String.Conversions (cs) import Imports import Polysemy +import Polysemy.Error (Error) import qualified SAML2.WebSSO as SAML import Servant import Servant.API.Generic @@ -82,6 +83,8 @@ import Spar.Error ) import Spar.Scim.Auth import Spar.Scim.User +import Spar.Sem.BrigAccess (BrigAccess) +import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.SAMLUserStore (SAMLUserStore) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -105,7 +108,7 @@ configuration :: Scim.Meta.Configuration configuration = Scim.Meta.empty apiScim :: - Members '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[Error SparError, GalleyAccess, BrigAccess, ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => ServerT APIScim (Spar r) apiScim = hoistScim (toServant (server configuration)) diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 2b902309842..773f5781129 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -45,11 +45,15 @@ import OpenSSL.Random (randBytes) -- Spar.Scim.{Core,User,Group} to avoid at least some of the hscim name clashes? import Polysemy +import Polysemy.Error import qualified SAML2.WebSSO as SAML import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>))) -import Spar.App (Spar, sparCtxOpts, wrapMonadClientSem) +import Spar.App (Spar, liftSem, sparCtxOpts, wrapMonadClientSem) import qualified Spar.Error as E -import qualified Spar.Intra.Brig as Intra.Brig +import qualified Spar.Intra.BrigApp as Intra.Brig +import Spar.Sem.BrigAccess (BrigAccess) +import qualified Spar.Sem.BrigAccess as BrigAccess +import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore @@ -77,7 +81,9 @@ instance Member ScimTokenStore r => Scim.Class.Auth.AuthDB SparTag (Spar r) wher -- | API for manipulating SCIM tokens (protected by normal Wire authentication and available -- only to team owners). -apiScimToken :: Members '[ScimTokenStore, IdPEffect.IdP] r => ServerT APIScimToken (Spar r) +apiScimToken :: + Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, Error E.SparError] r => + ServerT APIScimToken (Spar r) apiScimToken = createScimToken :<|> deleteScimToken @@ -88,7 +94,7 @@ apiScimToken = -- Create a token for user's team. createScimToken :: forall r. - Members '[ScimTokenStore, IdPEffect.IdP] r => + Members '[GalleyAccess, BrigAccess, ScimTokenStore, IdPEffect.IdP, Error E.SparError] r => -- | Who is trying to create a token Maybe UserId -> -- | Request body @@ -96,8 +102,8 @@ createScimToken :: Spar r CreateScimTokenResponse createScimToken zusr CreateScimToken {..} = do let descr = createScimTokenDescr - teamid <- Intra.Brig.authorizeScimTokenManagement zusr - Intra.Brig.ensureReAuthorised zusr createScimTokenPassword + teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr + liftSem $ BrigAccess.ensureReAuthorised zusr createScimTokenPassword tokenNumber <- fmap length $ wrapMonadClientSem $ ScimTokenStore.getByTeam teamid maxTokens <- asks (maxScimTokens . sparCtxOpts) unless (tokenNumber < maxTokens) $ @@ -135,13 +141,13 @@ createScimToken zusr CreateScimToken {..} = do -- -- Delete a token belonging to user's team. deleteScimToken :: - Member ScimTokenStore r => + Members '[GalleyAccess, BrigAccess, ScimTokenStore, Error E.SparError] r => -- | Who is trying to delete a token Maybe UserId -> ScimTokenId -> Spar r NoContent deleteScimToken zusr tokenid = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr wrapMonadClientSem $ ScimTokenStore.delete teamid tokenid pure NoContent @@ -150,10 +156,10 @@ deleteScimToken zusr tokenid = do -- List all tokens belonging to user's team. Tokens themselves are not available, only -- metadata about them. listScimTokens :: - Member ScimTokenStore r => + Members '[GalleyAccess, BrigAccess, ScimTokenStore, Error E.SparError] r => -- | Who is trying to list tokens Maybe UserId -> Spar r ScimTokenList listScimTokens zusr = do - teamid <- Intra.Brig.authorizeScimTokenManagement zusr + teamid <- liftSem $ Intra.Brig.authorizeScimTokenManagement zusr ScimTokenList <$> wrapMonadClientSem (ScimTokenStore.getByTeam teamid) diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index c877687d37d..2d1d922d8c4 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -65,10 +65,12 @@ import Imports import Network.URI (URI, parseURI) import Polysemy import qualified SAML2.WebSSO as SAML -import Spar.App (GetUserResult (..), Spar, getUserIdByScimExternalId, getUserIdByUref, sparCtxOpts, validateEmailIfExists, wrapMonadClientSem) -import qualified Spar.Intra.Brig as Brig +import Spar.App (GetUserResult (..), Spar, getUserIdByScimExternalId, getUserIdByUref, liftSem, sparCtxOpts, validateEmailIfExists, wrapMonadClientSem) +import qualified Spar.Intra.BrigApp as Brig import Spar.Scim.Auth () import qualified Spar.Scim.Types as ST +import Spar.Sem.BrigAccess as BrigAccess +import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore @@ -101,7 +103,7 @@ import qualified Wire.API.User.Scim as ST ---------------------------------------------------------------------------- -- UserDB instance -instance Members '[ScimExternalIdStore, ScimUserTimesStore, IdPEffect.IdP, SAMLUserStore] r => Scim.UserDB ST.SparTag (Spar r) where +instance Members '[GalleyAccess, BrigAccess, ScimExternalIdStore, ScimUserTimesStore, IdPEffect.IdP, SAMLUserStore] r => Scim.UserDB ST.SparTag (Spar r) where getUsers :: ScimTokenInfo -> Maybe Scim.Filter -> @@ -140,7 +142,7 @@ instance Members '[ScimExternalIdStore, ScimUserTimesStore, IdPEffect.IdP, SAMLU $ do mIdpConfig <- maybe (pure Nothing) (lift . wrapMonadClientSem . IdPEffect.getConfig) stiIdP let notfound = Scim.notFound "User" (idToText uid) - brigUser <- lift (Brig.getBrigUserAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure + brigUser <- lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure unless (userTeam (accountUser brigUser) == Just stiTeam) (throwError notfound) case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> synthesizeStoredUser brigUser veid @@ -369,7 +371,7 @@ veidEmail (ST.EmailOnly email) = Just email createValidScimUser :: forall m r. (m ~ Scim.ScimHandler (Spar r)) => - Members '[ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore] r => ScimTokenInfo -> ST.ValidScimUser -> m (Scim.StoredUser ST.SparTag) @@ -395,10 +397,10 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid ( \uref -> do uid <- liftIO $ Id <$> UUID.nextRandom - Brig.createBrigUserSAML uref uid stiTeam name ManagedByScim + liftSem $ BrigAccess.createSAML uref uid stiTeam name ManagedByScim ) ( \email -> do - Brig.createBrigUserNoSAML email stiTeam name + liftSem $ BrigAccess.createNoSAML email stiTeam name ) veid @@ -409,8 +411,9 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- up. We should consider making setUserHandle part of createUser and -- making it transactional. If the user redoes the POST A new standalone -- user will be created.} - Brig.setBrigUserHandle buid handl - Brig.setBrigUserRichInfo buid richInfo + liftSem $ do + BrigAccess.setHandle buid handl + BrigAccess.setRichInfo buid richInfo pure buid -- {If we crash now, a POST retry will fail with 409 user already exists. @@ -423,7 +426,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- to reload the Account from brig. storedUser <- do acc <- - lift (Brig.getBrigUserAccount Brig.WithPendingInvitations buid) + lift (liftSem $ BrigAccess.getAccount Brig.WithPendingInvitations buid) >>= maybe (throwError $ Scim.serverError "Server error: user vanished") pure synthesizeStoredUser acc veid lift $ Log.debug (Log.msg $ "createValidScimUser: spar says " <> show storedUser) @@ -442,16 +445,16 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- {suspension via scim: if we don't reach the following line, the user will be active.} lift $ do - old <- Brig.getStatus buid + old <- liftSem $ BrigAccess.getStatus buid let new = ST.scimActiveFlagToAccountStatus old (Scim.unScimBool <$> active) active = Scim.active . Scim.value . Scim.thing $ storedUser - when (new /= old) $ Brig.setStatus buid new + when (new /= old) $ liftSem $ BrigAccess.setStatus buid new pure storedUser -- TODO(arianvp): how do we get this safe w.r.t. race conditions / crashes? updateValidScimUser :: forall m r. - Members '[ScimExternalIdStore, ScimUserTimesStore, IdPEffect.IdP, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, ScimExternalIdStore, ScimUserTimesStore, IdPEffect.IdP, SAMLUserStore] r => (m ~ Scim.ScimHandler (Spar r)) => ScimTokenInfo -> UserId -> @@ -488,25 +491,26 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = _ -> pure () when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ do - Brig.setBrigUserName uid (newValidScimUser ^. ST.vsuName) + liftSem $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ do - Brig.setBrigUserHandle uid (newValidScimUser ^. ST.vsuHandle) + liftSem $ BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ do - Brig.setBrigUserRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) + liftSem $ BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) - Brig.getStatusMaybe uid >>= \case - Nothing -> pure () - Just old -> do - let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) - when (new /= old) $ Brig.setStatus uid new + liftSem $ + BrigAccess.getStatusMaybe uid >>= \case + Nothing -> pure () + Just old -> do + let new = ST.scimActiveFlagToAccountStatus old (Just $ newValidScimUser ^. ST.vsuActive) + when (new /= old) $ BrigAccess.setStatus uid new wrapMonadClientSem $ ScimUserTimesStore.write newScimStoredUser pure newScimStoredUser updateVsuUref :: - Members '[ScimExternalIdStore, SAMLUserStore] r => + Members '[GalleyAccess, BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> UserId -> ST.ValidExternalId -> @@ -522,7 +526,7 @@ updateVsuUref team uid old new = do old & ST.runValidExternalId (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) new & ST.runValidExternalId (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) - Brig.setBrigUserVeid uid new + liftSem $ BrigAccess.setVeid uid new toScimStoredUser' :: HasCallStack => @@ -579,7 +583,7 @@ updScimStoredUser' now usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = } deleteScimUser :: - Members '[ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, IdPEffect.IdP] r => + Members '[BrigAccess, ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, IdPEffect.IdP] r => ScimTokenInfo -> UserId -> Scim.ScimHandler (Spar r) () @@ -590,7 +594,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = . logUser uid ) $ do - mbBrigUser <- lift (Brig.getBrigUser Brig.WithPendingInvitations uid) + mbBrigUser <- lift (liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid) case mbBrigUser of Nothing -> do -- double-deletion gets you a 404. @@ -616,7 +620,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = veid lift . wrapMonadClientSem $ ScimUserTimesStore.delete uid - lift $ Brig.deleteBrigUser uid + lift . liftSem $ BrigAccess.delete uid return () ---------------------------------------------------------------------------- @@ -646,7 +650,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdUnused :: Members '[ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () assertExternalIdUnused tid veid = do assertExternalIdInAllowedValues [Nothing] @@ -660,7 +664,7 @@ assertExternalIdUnused tid veid = do -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdNotUsedElsewhere :: Members '[ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Spar r) () +assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Spar r) () assertExternalIdNotUsedElsewhere tid veid wireUserId = do assertExternalIdInAllowedValues [Nothing, Just wireUserId] @@ -668,7 +672,7 @@ assertExternalIdNotUsedElsewhere tid veid wireUserId = do tid veid -assertExternalIdInAllowedValues :: Members '[ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () +assertExternalIdInAllowedValues :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => [Maybe UserId] -> Text -> TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) () assertExternalIdInAllowedValues allowedValues errmsg tid veid = do isGood <- lift $ @@ -685,25 +689,25 @@ assertExternalIdInAllowedValues allowedValues errmsg tid veid = do unless isGood $ throwError Scim.conflict {Scim.detail = Just errmsg} -assertHandleUnused :: Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Spar r) () assertHandleUnused = assertHandleUnused' "userName is already taken" -assertHandleUnused' :: Text -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleUnused' :: Member BrigAccess r => Text -> Handle -> Scim.ScimHandler (Spar r) () assertHandleUnused' msg hndl = - lift (Brig.checkHandleAvailable hndl) >>= \case + lift (liftSem $ BrigAccess.checkHandleAvailable hndl) >>= \case True -> pure () False -> throwError Scim.conflict {Scim.detail = Just msg} -assertHandleNotUsedElsewhere :: UserId -> Handle -> Scim.ScimHandler (Spar r) () +assertHandleNotUsedElsewhere :: Member BrigAccess r => UserId -> Handle -> Scim.ScimHandler (Spar r) () assertHandleNotUsedElsewhere uid hndl = do - musr <- lift $ Brig.getBrigUser Brig.WithPendingInvitations uid + musr <- lift $ liftSem $ Brig.getBrigUser Brig.WithPendingInvitations uid unless ((userHandle =<< musr) == Just hndl) $ assertHandleUnused' "userName already in use by another wire user" hndl -- | Helper function that translates a given brig user into a 'Scim.StoredUser', with some -- effects like updating the 'ManagedBy' field in brig and storing creation and update time -- stamps. -synthesizeStoredUser :: forall r. Member ScimUserTimesStore r => UserAccount -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) +synthesizeStoredUser :: forall r. Members '[BrigAccess, ScimUserTimesStore] r => UserAccount -> ST.ValidExternalId -> Scim.ScimHandler (Spar r) (Scim.StoredUser ST.SparTag) synthesizeStoredUser usr veid = logScim ( logFunction "Spar.Scim.User.synthesizeStoredUser" @@ -718,7 +722,7 @@ synthesizeStoredUser usr veid = let readState :: Spar r (RI.RichInfo, Maybe (UTCTimeMillis, UTCTimeMillis), URIBS.URI) readState = do - richInfo <- Brig.getBrigUserRichInfo uid + richInfo <- liftSem $ BrigAccess.getRichInfo uid accessTimes <- wrapMonadClientSem (ScimUserTimesStore.read uid) baseuri <- asks $ derivedOptsScimBaseURI . derivedOpts . sparCtxOpts pure (richInfo, accessTimes, baseuri) @@ -728,16 +732,16 @@ synthesizeStoredUser usr veid = when (isNothing oldAccessTimes) $ do wrapMonadClientSem $ ScimUserTimesStore.write storedUser when (oldManagedBy /= ManagedByScim) $ do - Brig.setBrigUserManagedBy uid ManagedByScim + liftSem $ BrigAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser when (oldRichInfo /= newRichInfo) $ do - Brig.setBrigUserRichInfo uid newRichInfo + liftSem $ BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState SAML.Time (toUTCTimeMillis -> now) <- lift SAML.getNow let (createdAt, lastUpdatedAt) = fromMaybe (now, now) accessTimes - handle <- lift $ Brig.giveDefaultHandle (accountUser usr) + handle <- lift $ liftSem $ Brig.giveDefaultHandle (accountUser usr) storedUser <- synthesizeStoredUser' @@ -789,10 +793,15 @@ synthesizeScimUser info = Scim.active = Just . Scim.ScimBool $ info ^. ST.vsuActive } -scimFindUserByHandle :: Member ScimUserTimesStore r => Maybe IdP -> TeamId -> Text -> MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) +scimFindUserByHandle :: + Members '[BrigAccess, ScimUserTimesStore] r => + Maybe IdP -> + TeamId -> + Text -> + MaybeT (Scim.ScimHandler (Spar r)) (Scim.StoredUser ST.SparTag) scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl - brigUser <- MaybeT . lift . Brig.getBrigUserByHandle $ handle + brigUser <- MaybeT . lift . liftSem . BrigAccess.getByHandle $ handle guard $ userTeam (accountUser brigUser) == Just stiTeam case Brig.veidFromBrigUser (accountUser brigUser) ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Right veid -> lift $ synthesizeStoredUser brigUser veid @@ -806,7 +815,7 @@ scimFindUserByHandle mIdpConfig stiTeam hndl = do -- successful authentication with their SAML credentials. scimFindUserByEmail :: forall r. - Members '[ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore] r => + Members '[BrigAccess, ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore] r => Maybe IdP -> TeamId -> Text -> @@ -820,7 +829,7 @@ scimFindUserByEmail mIdpConfig stiTeam email = do -- a UUID, or any other text that is valid according to SCIM. veid <- MaybeT (either (const Nothing) Just <$> runExceptT (mkValidExternalId mIdpConfig (pure email))) uid <- MaybeT . lift $ ST.runValidExternalId withUref withEmailOnly veid - brigUser <- MaybeT . lift . Brig.getBrigUserAccount Brig.WithPendingInvitations $ uid + brigUser <- MaybeT . lift . liftSem . BrigAccess.getAccount Brig.WithPendingInvitations $ uid guard $ userTeam (accountUser brigUser) == Just stiTeam lift $ synthesizeStoredUser brigUser veid where @@ -837,7 +846,7 @@ scimFindUserByEmail mIdpConfig stiTeam email = do -- and it never should be visible in spar, but not in brig. inspar, inbrig :: Spar r (Maybe UserId) inspar = wrapMonadClientSem $ ScimExternalIdStore.lookup stiTeam eml - inbrig = userId . accountUser <$$> Brig.getBrigUserByEmail eml + inbrig = liftSem $ userId . accountUser <$$> BrigAccess.getByEmail eml logFilter :: Filter -> (Msg -> Msg) logFilter (FilterAttrCompare attr op val) = diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs new file mode 100644 index 00000000000..8d5fb82b383 --- /dev/null +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -0,0 +1,36 @@ +module Spar.Sem.BrigAccess where + +import Brig.Types.Intra +import Brig.Types.User +import Data.Handle (Handle) +import Data.Id (TeamId, UserId) +import Data.Misc (PlainTextPassword) +import Imports +import Polysemy +import qualified SAML2.WebSSO as SAML +import Web.Cookie +import Wire.API.User.RichInfo as RichInfo +import Wire.API.User.Scim (ValidExternalId (..)) + +data BrigAccess m a where + CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> BrigAccess m UserId + CreateNoSAML :: Email -> TeamId -> Name -> BrigAccess m UserId + UpdateEmail :: UserId -> Email -> BrigAccess m () + GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe UserAccount) + GetByHandle :: Handle -> BrigAccess m (Maybe UserAccount) + GetByEmail :: Email -> BrigAccess m (Maybe UserAccount) + SetName :: UserId -> Name -> BrigAccess m () + SetHandle :: UserId -> Handle {- not 'HandleUpdate'! -} -> BrigAccess m () + SetManagedBy :: UserId -> ManagedBy -> BrigAccess m () + SetVeid :: UserId -> ValidExternalId -> BrigAccess m () + SetRichInfo :: UserId -> RichInfo -> BrigAccess m () + GetRichInfo :: UserId -> BrigAccess m RichInfo + CheckHandleAvailable :: Handle -> BrigAccess m Bool + Delete :: UserId -> BrigAccess m () + EnsureReAuthorised :: Maybe UserId -> Maybe PlainTextPassword -> BrigAccess m () + SsoLogin :: UserId -> BrigAccess m SetCookie + GetStatus :: UserId -> BrigAccess m AccountStatus + GetStatusMaybe :: UserId -> BrigAccess m (Maybe AccountStatus) + SetStatus :: UserId -> AccountStatus -> BrigAccess m () + +makeSem ''BrigAccess diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs new file mode 100644 index 00000000000..547756bab7d --- /dev/null +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -0,0 +1,41 @@ +module Spar.Sem.BrigAccess.Http where + +import Bilge +import Imports +import Polysemy +import Polysemy.Error (Error) +import Spar.Error (SparError) +import qualified Spar.Intra.Brig as Intra +import Spar.Sem.BrigAccess +import Spar.Sem.GalleyAccess.Http (RunHttpEnv (..), viaRunHttp) +import qualified System.Logger as Log + +brigAccessToHttp :: + Members '[Error SparError, Embed IO] r => + Log.Logger -> + Bilge.Manager -> + Bilge.Request -> + Sem (BrigAccess ': r) a -> + Sem r a +brigAccessToHttp logger mgr req = + interpret $ + viaRunHttp (RunHttpEnv logger mgr req) . \case + CreateSAML u itlu itlt n m -> Intra.createBrigUserSAML u itlu itlt n m + CreateNoSAML e itlt n -> Intra.createBrigUserNoSAML e itlt n + UpdateEmail itlu e -> Intra.updateEmail itlu e + GetAccount h itlu -> Intra.getBrigUserAccount h itlu + GetByHandle h -> Intra.getBrigUserByHandle h + GetByEmail e -> Intra.getBrigUserByEmail e + SetName itlu n -> Intra.setBrigUserName itlu n + SetHandle itlu h -> Intra.setBrigUserHandle itlu h + SetManagedBy itlu m -> Intra.setBrigUserManagedBy itlu m + SetVeid itlu v -> Intra.setBrigUserVeid itlu v + SetRichInfo itlu r -> Intra.setBrigUserRichInfo itlu r + GetRichInfo itlu -> Intra.getBrigUserRichInfo itlu + CheckHandleAvailable h -> Intra.checkHandleAvailable h + Delete itlu -> Intra.deleteBrigUser itlu + EnsureReAuthorised mitlu mp -> Intra.ensureReAuthorised mitlu mp + SsoLogin itlu -> Intra.ssoLogin itlu + GetStatus itlu -> Intra.getStatus itlu + GetStatusMaybe itlu -> Intra.getStatusMaybe itlu + SetStatus itlu a -> Intra.setStatus itlu a diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs new file mode 100644 index 00000000000..8a3952db218 --- /dev/null +++ b/services/spar/src/Spar/Sem/GalleyAccess.hs @@ -0,0 +1,14 @@ +module Spar.Sem.GalleyAccess where + +import Data.Id (TeamId, UserId) +import Galley.Types.Teams (IsPerm, TeamMember) +import Imports +import Polysemy + +data GalleyAccess m a where + GetTeamMembers :: TeamId -> GalleyAccess m [TeamMember] + AssertHasPermission :: (Show perm, IsPerm perm) => TeamId -> perm -> UserId -> GalleyAccess m () + AssertSSOEnabled :: TeamId -> GalleyAccess m () + IsEmailValidationEnabledTeam :: TeamId -> GalleyAccess m Bool + +makeSem ''GalleyAccess diff --git a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs new file mode 100644 index 00000000000..fca40c66bf1 --- /dev/null +++ b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Spar.Sem.GalleyAccess.Http where + +import Bilge +import Control.Monad.Except +import Imports hiding (log) +import Polysemy +import Polysemy.Error +import Spar.Error (SparError) +import Spar.Intra.Brig (MonadSparToBrig (..)) +import Spar.Intra.Galley (MonadSparToGalley) +import qualified Spar.Intra.Galley as Intra +import Spar.Sem.GalleyAccess +import qualified System.Logger as Log +import qualified System.Logger.Class as LogClass + +data RunHttpEnv = RunHttpEnv + { rheLogger :: Log.Logger, + rheManager :: Bilge.Manager, + rheRequest :: Bilge.Request + } + +newtype RunHttp a = RunHttp + { unRunHttp :: ReaderT RunHttpEnv (ExceptT SparError (HttpT IO)) a + } + deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadIO, MonadHttp, MonadReader RunHttpEnv) + +viaRunHttp :: + Members '[Error SparError, Embed IO] r => + RunHttpEnv -> + RunHttp a -> + Sem r a +viaRunHttp env m = do + ma <- embed @IO $ runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m + case ma of + Left err -> throw err + Right a -> pure a + +instance LogClass.MonadLogger RunHttp where + log lvl msg = do + logger <- asks rheLogger + Log.log logger lvl msg + +instance MonadSparToGalley RunHttp where + call modreq = do + req <- asks rheRequest + httpLbs req modreq + +instance MonadSparToBrig RunHttp where + call modreq = do + req <- asks rheRequest + httpLbs req modreq + +galleyAccessToHttp :: + Members '[Error SparError, Embed IO] r => + Log.Logger -> + Bilge.Manager -> + Bilge.Request -> + Sem (GalleyAccess ': r) a -> + Sem r a +galleyAccessToHttp logger mgr req = + interpret $ + viaRunHttp (RunHttpEnv logger mgr req) . \case + GetTeamMembers itlt -> Intra.getTeamMembers itlt + AssertHasPermission itlt perm itlu -> Intra.assertHasPermission itlt perm itlu + AssertSSOEnabled itlt -> Intra.assertSSOEnabled itlt + IsEmailValidationEnabledTeam itlt -> Intra.isEmailValidationEnabledTeam itlt diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index dad4316f3b6..57afed49fd2 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -71,7 +71,8 @@ import SAML2.WebSSO.Test.Lenses import SAML2.WebSSO.Test.MockResponse import SAML2.WebSSO.Test.Util import Spar.App (liftSem) -import qualified Spar.Intra.Brig as Intra +import qualified Spar.Intra.BrigApp as Intra +import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdP as IdPEffect import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI @@ -1297,7 +1298,7 @@ specDeleteCornerCases = describe "delete corner cases" $ do brig <- view teBrig resp <- call . delete $ brig . paths ["i", "users", toByteString' uid] liftIO $ responseStatus resp `shouldBe` status202 - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Deleted) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Deleted) specScimAndSAML :: SpecWith TestEnv specScimAndSAML = do diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 7d69db0d3c4..b37ba065a80 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -34,7 +34,7 @@ import Polysemy import SAML2.WebSSO as SAML import Spar.App as App import Spar.Data as Data -import Spar.Intra.Brig (veidFromUserSSOId) +import Spar.Intra.BrigApp (veidFromUserSSOId) import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore import qualified Spar.Sem.BindCookieStore as BindCookieStore diff --git a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs index e6ed4aac923..84114d80278 100644 --- a/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test-integration/Test/Spar/Intra/BrigSpec.hs @@ -25,7 +25,8 @@ import Control.Lens ((^.)) import Data.Id (Id (Id)) import qualified Data.UUID as UUID import Imports hiding (head) -import qualified Spar.Intra.Brig as Intra +import Spar.App (liftSem) +import qualified Spar.Intra.BrigApp as Intra import Util import qualified Web.Scim.Schema.User as Scim.User @@ -39,7 +40,7 @@ spec = do describe "getBrigUser" $ do it "return Nothing if n/a" $ do - musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") + musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations (Id . fromJust $ UUID.fromText "29546d9e-ed5b-11ea-8228-c324b1ea1030") liftIO $ musr `shouldSatisfy` isNothing it "return Just if /a" $ do @@ -52,5 +53,5 @@ spec = do scimUserId <$> createUser tok scimUser uid <- setup - musr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid + musr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid liftIO $ musr `shouldSatisfy` isJust diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 127c5ef540e..fa424629192 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -60,9 +60,10 @@ import qualified Network.Wai.Utilities.Error as Wai import qualified SAML2.WebSSO as SAML import qualified SAML2.WebSSO.Test.MockResponse as SAML import Spar.App (liftSem) -import qualified Spar.Intra.Brig as Intra +import qualified Spar.Intra.BrigApp as Intra import Spar.Scim import qualified Spar.Scim.User as SU +import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore @@ -116,9 +117,9 @@ specSuspend = do -- NOTE: once SCIM is enabled, SSO Auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) handle'@(Handle handle) <- nextHandle - runSpar $ Intra.setBrigUserHandle member handle' + runSpar $ liftSem $ BrigAccess.setHandle member handle' unless isActive $ do - runSpar $ Intra.setStatus member Suspended + runSpar $ liftSem $ BrigAccess.setStatus member Suspended [user] <- listUsers tok (Just (filterBy "userName" handle)) lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ user) `shouldBe` Just isActive it "pre-existing suspended users are inactive" $ do @@ -137,19 +138,19 @@ specSuspend = do -- Once we get rid of the `scim` table and make scim serve brig records directly, this is -- not an issue anymore. lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUserBlah) `shouldBe` Just True - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) do scimStoredUser <- putOrPatch tok uid user False lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just False - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Suspended) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) do scimStoredUser <- putOrPatch tok uid user True lift $ (fmap Scim.unScimBool . Scim.User.active . Scim.value . Scim.thing $ scimStoredUser) `shouldBe` Just True - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) it "PUT will change state from active to inactive and back" $ do void . activeInactiveAndBack $ \tok uid user active -> @@ -188,10 +189,10 @@ specSuspend = do (tok, _) <- registerIdPAndScimToken scimStoredUserBlah <- createUser tok user let uid = Scim.id . Scim.thing $ scimStoredUserBlah - runSpar $ Intra.setStatus uid Suspended - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Suspended) + runSpar $ liftSem $ BrigAccess.setStatus uid Suspended + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Suspended) void $ patchUser tok uid $ PatchOp.PatchOp [deleteAttrib "active"] - void $ aFewTimes (runSpar $ Intra.getStatus uid) (== Active) + void $ aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus uid) (== Active) ---------------------------------------------------------------------------- -- User creation @@ -302,10 +303,10 @@ testCreateUserNoIdP = do -- get account from brig, status should be PendingInvitation do - aFewTimes (runSpar $ Intra.getBrigUserAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (pure ()) (error "pending user in brig is visible, even though it should not be") brigUserAccount <- - aFewTimes (runSpar $ Intra.getBrigUserAccount Intra.WithPendingInvitations userid) isJust + aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.WithPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure let brigUser = accountUser brigUserAccount brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser @@ -345,7 +346,7 @@ testCreateUserNoIdP = do -- user should now be active do brigUser <- - aFewTimes (runSpar $ Intra.getBrigUserAccount Intra.NoPendingInvitations userid) isJust + aFewTimes (runSpar $ liftSem $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust >>= maybe (error "could not find user in brig") pure liftIO $ accountStatus brigUser `shouldBe` Active liftIO $ userManagedBy (accountUser brigUser) `shouldBe` ManagedByScim @@ -429,7 +430,7 @@ testCreateUserWithSamlIdP = do . expect2xx ) brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser - accStatus <- aFewTimes (runSpar $ Intra.getStatus (userId brigUser)) (== Active) + accStatus <- aFewTimes (runSpar $ liftSem $ BrigAccess.getStatus (userId brigUser)) (== Active) liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim @@ -820,9 +821,9 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do -- auto-provision user via saml memberWithSSO <- do uid <- loginSsoUserFirstTime idp privCreds - Just usr <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid handle <- nextHandle - runSpar $ Intra.setBrigUserHandle uid handle + runSpar $ liftSem $ BrigAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO externalId = either error id $ veidToText =<< Intra.veidFromBrigUser memberWithSSO Nothing @@ -833,7 +834,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ userManagedBy memberWithSSO `shouldBe` ManagedByWire users <- listUsers tok (Just (filterBy "externalId" externalId)) liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] - Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO + Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim where veidToText :: MonadError String m => ValidExternalId -> m Text @@ -854,7 +855,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do users' <- listUsers tok (Just (filterBy "externalId" emailInvited)) liftIO $ (scimUserId <$> users') `shouldContain` [memberIdInvited] - Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited + Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations memberIdInvited liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId :: TestSpar () @@ -866,7 +867,7 @@ testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSOViaUserId = do let memberIdInvited = userId memberInvited _ <- getUser tok memberIdInvited - Just brigUserInvited' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) + Just brigUserInvited' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations (memberIdInvited) liftIO $ userManagedBy brigUserInvited' `shouldBe` ManagedByScim testFindProvisionedUserNoIdP :: TestSpar () @@ -885,8 +886,8 @@ testFindNonProvisionedUserNoIdP findBy = do uid <- userId <$> call (inviteAndRegisterUser (env ^. teBrig) owner teamid) handle <- nextHandle - runSpar $ Intra.setBrigUserHandle uid handle - Just brigUser <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid + runSpar $ liftSem $ BrigAccess.setHandle uid handle + Just brigUser <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid let Just email = userEmail brigUser do @@ -901,7 +902,7 @@ testFindNonProvisionedUserNoIdP findBy = do do liftIO $ users `shouldBe` [uid] - Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid + Just brigUser' <- runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim liftIO $ brigUser' `shouldBe` brigUser {userManagedBy = ManagedByScim} @@ -986,7 +987,7 @@ testGetUser = do shouldBeManagedBy :: HasCallStack => UserId -> ManagedBy -> TestSpar () shouldBeManagedBy uid flag = do - managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) + managedBy <- maybe (error "user not found") userManagedBy <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ managedBy `shouldBe` flag -- | This is (roughly) the behavior on develop as well as on the branch where this test was @@ -1039,12 +1040,12 @@ testGetUserWithNoHandle = do uid <- loginSsoUserFirstTime idp privcreds tok <- registerScimToken tid (Just (idp ^. SAML.idpId)) - mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid) + mhandle :: Maybe Handle <- maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) liftIO $ mhandle `shouldSatisfy` isNothing storedUser <- getUser tok uid liftIO $ (Scim.User.displayName . Scim.value . Scim.thing) storedUser `shouldSatisfy` isJust - mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust + mhandle' :: Maybe Handle <- aFewTimes (maybe (error "user not found") userHandle <$> runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid)) isJust liftIO $ mhandle' `shouldSatisfy` isJust liftIO $ (fromHandle <$> mhandle') `shouldBe` (Just . Scim.User.userName . Scim.value . Scim.thing $ storedUser) @@ -1342,7 +1343,7 @@ testBrigSideIsUpdated = do validScimUser <- either (error . show) pure $ validateScimUser' (Just idp) 999999 user' - brigUser <- maybe (error "no brig user") pure =<< runSpar (Intra.getBrigUser Intra.WithPendingInvitations userid) + brigUser <- maybe (error "no brig user") pure =<< runSpar (liftSem $ Intra.getBrigUser Intra.WithPendingInvitations userid) brigUser `userShouldMatch` validScimUser ---------------------------------------------------------------------------- @@ -1524,7 +1525,7 @@ specDeleteUser = do storedUser <- createUser tok user let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do - usr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid + usr <- runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid let err = error . ("brig user without UserRef: " <>) . show case (`Intra.veidFromBrigUser` Nothing) <$> usr of bad@(Just (Right veid)) -> runValidExternalId pure (const $ err bad) veid @@ -1533,7 +1534,7 @@ specDeleteUser = do deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode brigUser :: Maybe User <- - aFewTimes (runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing + aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.WithPendingInvitations uid) isNothing samlUser :: Maybe UserId <- aFewTimes (getUserIdViaRef' uref) isNothing scimUser <- diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index cbbc41273d7..e6c00b5820a 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -178,7 +178,7 @@ import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata) import Spar.App (liftSem, toLevel) import qualified Spar.App as Spar import Spar.Error (SparError) -import qualified Spar.Intra.Brig as Intra +import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Options import Spar.Run import Spar.Sem.AReqIDStore (AReqIDStore) @@ -187,8 +187,12 @@ import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.BindCookieStore (BindCookieStore) import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra) +import Spar.Sem.BrigAccess (BrigAccess) +import Spar.Sem.BrigAccess.Http (brigAccessToHttp) import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) +import Spar.Sem.GalleyAccess (GalleyAccess) +import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) import qualified Spar.Sem.IdP as IdPEffect import Spar.Sem.IdP.Cassandra import Spar.Sem.SAMLUserStore (SAMLUserStore) @@ -1239,7 +1243,9 @@ runSimpleSP action = do either (throwIO . ErrorCall . show) pure result type RealInterpretation = - '[ BindCookieStore, + '[ GalleyAccess, + BrigAccess, + BindCookieStore, AssIDStore, AReqIDStore, ScimExternalIdStore, @@ -1280,8 +1286,10 @@ runSpar (Spar.Spar action) = do aReqIDStoreToCassandra @Cas.Client $ assIDStoreToCassandra @Cas.Client $ bindCookieStoreToCassandra @Cas.Client $ - runExceptT $ - runReaderT action env + brigAccessToHttp (Spar.sparCtxLogger env) (Spar.sparCtxHttpManager env) (Spar.sparCtxHttpBrig env) $ + galleyAccessToHttp (Spar.sparCtxLogger env) (Spar.sparCtxHttpManager env) (Spar.sparCtxHttpBrig env) $ + runExceptT $ + runReaderT action env either (throwIO . ErrorCall . show) pure result getSsoidViaSelf :: HasCallStack => UserId -> TestSpar UserSSOId @@ -1289,7 +1297,7 @@ getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) getSsoidViaSelf' uid = do - musr <- aFewTimes (runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust + musr <- aFewTimes (runSpar $ liftSem $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust pure $ case userIdentity =<< musr of Just (SSOIdentity ssoid _ _) -> Just ssoid Just (FullIdentity _ _) -> Nothing diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 732df54d361..4f332e98855 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -35,7 +35,7 @@ import Imports import qualified SAML2.WebSSO as SAML import SAML2.WebSSO.Types (IdPId, idpId) import Spar.App (liftSem) -import qualified Spar.Intra.Brig as Intra +import qualified Spar.Intra.BrigApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Test.QuickCheck (arbitrary, generate) diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs index 44aa7e0d588..d37e98582f5 100644 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ b/services/spar/test/Test/Spar/Intra/BrigSpec.hs @@ -26,7 +26,7 @@ import Control.Lens ((^.)) import Data.String.Conversions (ST, cs) import Imports import SAML2.WebSSO as SAML -import Spar.Intra.Brig +import Spar.Intra.BrigApp import Test.Hspec import Test.QuickCheck import URI.ByteString (URI, laxURIParserOptions, parseURI)