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

@@ -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.

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

services/spar/src/Spar/API.hs

@@ -54,23 +54,27 @@ 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)
 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,15 +95,18 @@ app ctx =
 
 api ::
   Members
-    '[ BindCookieStore,
+    '[ GalleyAccess,
+       BrigAccess,
+       BindCookieStore,
        AssIDStore,
        AReqIDStore,
        ScimExternalIdStore,
        ScimUserTimesStore,
        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 ()