Spar Polysemy: Final Cassandra effects

changelog.d/5-internal/last-spar-effects

@@ -0,0 +1 @@
+Polysemize the remainder of Spar's Cassandra effects

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f135fc7f6d1e85694286faaeb615c1808dedee43fd207e59f50864481c2a9cca
+-- hash: d04f829f6801dc459cf2f535b387c77caf06d3d99c2d95c9b46c469c1ec8b890
 
 name:           spar
 version:        0.1
@@ -34,6 +34,12 @@ library
       Spar.Scim.Auth
       Spar.Scim.Types
       Spar.Scim.User
+      Spar.Sem.AReqIDStore
+      Spar.Sem.AReqIDStore.Cassandra
+      Spar.Sem.AssIDStore
+      Spar.Sem.AssIDStore.Cassandra
+      Spar.Sem.BindCookieStore
+      Spar.Sem.BindCookieStore.Cassandra
       Spar.Sem.DefaultSsoCode
       Spar.Sem.DefaultSsoCode.Cassandra
       Spar.Sem.IdP

services/spar/src/Spar/API.hs

@@ -58,12 +58,17 @@ import qualified SAML2.WebSSO as SAML
 import Servant
 import qualified Servant.Multipart as Multipart
 import Spar.App
-import qualified Spar.Data as Data hiding (clearReplacedBy, deleteIdPRawMetadata, getIdPConfig, getIdPConfigsByTeam, getIdPIdByIssuerWithTeam, getIdPIdByIssuerWithoutTeam, getIdPRawMetadata, setReplacedBy, storeIdPConfig, storeIdPRawMetadata)
+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 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.DefaultSsoCode (DefaultSsoCode)
 import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode
 import qualified Spar.Sem.IdP as IdPEffect
@@ -84,7 +89,21 @@ app ctx =
   SAML.setHttpCachePolicy $
     serve (Proxy @API) (hoistServer (Proxy @API) (SAML.nt @SparError @(Spar _) ctx) (api $ sparCtxOpts ctx) :: Server API)
 
-api :: Members '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore] r => Opts -> ServerT API (Spar r)
+api ::
+  Members
+    '[ BindCookieStore,
+       AssIDStore,
+       AReqIDStore,
+       ScimExternalIdStore,
+       ScimUserTimesStore,
+       ScimTokenStore,
+       DefaultSsoCode,
+       IdPEffect.IdP,
+       SAMLUserStore
+     ]
+    r =>
+  Opts ->
+  ServerT API (Spar r)
 api opts =
   apiSSO opts
     :<|> authreqPrecheck
@@ -93,7 +112,19 @@ api opts =
     :<|> apiScim
     :<|> apiINTERNAL
 
-apiSSO :: Members '[ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore] r => Opts -> ServerT APISSO (Spar r)
+apiSSO ::
+  Members
+    '[ BindCookieStore,
+       AssIDStore,
+       AReqIDStore,
+       ScimTokenStore,
+       DefaultSsoCode,
+       IdPEffect.IdP,
+       SAMLUserStore
+     ]
+    r =>
+  Opts ->
+  ServerT APISSO (Spar r)
 apiSSO opts =
   SAML.meta appName (sparSPIssuer Nothing) (sparResponseURI Nothing)
     :<|> (\tid -> SAML.meta appName (sparSPIssuer (Just tid)) (sparResponseURI (Just tid)))
@@ -131,7 +162,7 @@ authreqPrecheck msucc merr idpid =
     *> return NoContent
 
 authreq ::
-  Member IdPEffect.IdP r =>
+  Members '[BindCookieStore, AssIDStore, AReqIDStore, IdPEffect.IdP] r =>
   NominalDiffTime ->
   DoInitiate ->
   Maybe UserId ->
@@ -150,23 +181,23 @@ authreq authreqttl _ zusr msucc merr idpid = do
           WireIdPAPIV1 -> Nothing
           WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam
     SAML.authreq authreqttl (sparSPIssuer mbtid) idpid
-  wrapMonadClient $ Data.storeVerdictFormat authreqttl reqid vformat
+  wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat
   cky <- initializeBindCookie zusr authreqttl
   SAML.logger SAML.Debug $ "setting bind cookie: " <> show cky
   pure $ addHeader cky form
 
 -- | If the user is already authenticated, create bind cookie with a given life expectancy and our
 -- domain, and store it in C*.  If the user is not authenticated, return a deletion 'SetCookie'
 -- value that deletes any bind cookies on the client.
-initializeBindCookie :: Maybe UserId -> NominalDiffTime -> Spar r SetBindCookie
+initializeBindCookie :: Member BindCookieStore r => Maybe UserId -> NominalDiffTime -> Spar r SetBindCookie
 initializeBindCookie zusr authreqttl = do
   DerivedOpts {derivedOptsBindCookiePath} <- asks (derivedOpts . sparCtxOpts)
   msecret <-
     if isJust zusr
       then liftIO $ Just . cs . ES.encode <$> randBytes 32
       else pure Nothing
   cky <- fmap SetBindCookie . SAML.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret
-  forM_ zusr $ \userid -> wrapMonadClientWithEnv $ Data.insertBindCookie cky userid authreqttl
+  forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl
   pure cky
 
 redirectURLMaxLength :: Int
@@ -187,7 +218,13 @@ validateRedirectURL uri = do
   unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do
     throwSpar $ SparBadInitiateLoginQueryParams "url-too-long"
 
-authresp :: forall r. Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> Spar r Void
+authresp ::
+  forall r.
+  Members '[BindCookieStore, AssIDStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
+  Maybe TeamId ->
+  Maybe ST ->
+  SAML.AuthnResponseBody ->
+  Spar r Void
 authresp mbtid ckyraw arbody = logErrors $ SAML.authresp mbtid (sparSPIssuer mbtid) (sparResponseURI mbtid) go arbody
   where
     cky :: Maybe BindCookie

services/spar/src/Spar/App.hs

@@ -25,8 +25,6 @@ module Spar.App
   ( Spar (..),
     Env (..),
     toLevel,
-    wrapMonadClientWithEnv,
-    wrapMonadClient,
     wrapMonadClientSem,
     verdictHandler,
     GetUserResult (..),
@@ -41,14 +39,12 @@ module Spar.App
     deleteTeam,
     wrapSpar,
     liftSem,
-    liftMonadClient,
   )
 where
 
 import Bilge
 import Brig.Types (ManagedBy (..), User, userId, userTeam)
 import Brig.Types.Intra (AccountStatus (..), accountStatus, accountUser)
-import Cassandra
 import qualified Cassandra as Cas
 import Control.Exception (assert)
 import Control.Lens hiding ((.=))
@@ -68,7 +64,9 @@ import Imports hiding (log)
 import qualified Network.HTTP.Types.Status as Http
 import qualified Network.Wai.Utilities.Error as Wai
 import Polysemy
+import Polysemy.Error
 import Polysemy.Final
+import qualified Polysemy.Reader as ReaderEff
 import SAML2.Util (renderURI)
 import SAML2.WebSSO
   ( Assertion (..),
@@ -84,7 +82,6 @@ import SAML2.WebSSO
     SPStoreIdP (getIdPConfigByIssuerOptionalSPId),
     UnqualifiedNameID (..),
     explainDeniedReason,
-    fromTime,
     idpExtraInfo,
     idpId,
     uidTenant,
@@ -93,11 +90,20 @@ import qualified SAML2.WebSSO as SAML
 import qualified SAML2.WebSSO.Types.Email as SAMLEmail
 import Servant
 import qualified Servant.Multipart as Multipart
-import qualified Spar.Data as Data hiding (deleteSAMLUser, deleteSAMLUsersByIssuer, getIdPConfig, getSAMLAnyUserByIssuer, getSAMLSomeUsersByIssuer, getSAMLUser, insertSAMLUser, storeIdPConfig)
+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 Spar.Orphans ()
+import Spar.Sem.AReqIDStore (AReqIDStore)
+import qualified Spar.Sem.AReqIDStore as AReqIDStore
+import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError)
+import Spar.Sem.AssIDStore (AssIDStore)
+import qualified Spar.Sem.AssIDStore as AssIDStore
+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.DefaultSsoCode (DefaultSsoCode)
 import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra)
 import Spar.Sem.IdP (GetIdPResult (..))
@@ -186,15 +192,15 @@ toLevel = \case
   SAML.Debug -> Log.Debug
   SAML.Trace -> Log.Trace
 
-instance SPStoreID AuthnRequest (Spar r) where
-  storeID i r = wrapMonadClientWithEnv $ Data.storeAReqID i r
-  unStoreID r = wrapMonadClient $ Data.unStoreAReqID r
-  isAliveID r = wrapMonadClient $ Data.isAliveAReqID r
+instance Member AReqIDStore r => SPStoreID AuthnRequest (Spar r) where
+  storeID i r = wrapMonadClientSem $ AReqIDStore.store i r
+  unStoreID r = wrapMonadClientSem $ AReqIDStore.unStore r
+  isAliveID r = wrapMonadClientSem $ AReqIDStore.isAlive r
 
-instance SPStoreID Assertion (Spar r) where
-  storeID i r = wrapMonadClientWithEnv $ Data.storeAssID i r
-  unStoreID r = wrapMonadClient $ Data.unStoreAssID r
-  isAliveID r = wrapMonadClient $ Data.isAliveAssID r
+instance Member AssIDStore r => SPStoreID Assertion (Spar r) where
+  storeID i r = wrapMonadClientSem $ AssIDStore.store i r
+  unStoreID r = wrapMonadClientSem $ AssIDStore.unStore r
+  isAliveID r = wrapMonadClientSem $ AssIDStore.isAlive r
 
 instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where
   type IdPConfigExtra (Spar r) = WireIdP
@@ -215,13 +221,6 @@ instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where
       res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res)
       res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res)
 
--- | 'wrapMonadClient' with an 'Env' in a 'ReaderT', and exceptions. If you
--- don't need either of those, 'wrapMonadClient' will suffice.
-wrapMonadClientWithEnv :: forall r a. ReaderT Data.Env (ExceptT TTLError Cas.Client) a -> Spar r a
-wrapMonadClientWithEnv action = do
-  denv <- Data.mkEnv <$> (sparCtxOpts <$> ask) <*> (fromTime <$> getNow)
-  either (throwSpar . SparCassandraTTLError) pure =<< wrapMonadClient (runExceptT $ action `runReaderT` denv)
-
 instance Member (Final IO) r => Catch.MonadThrow (Sem r) where
   throwM = embedFinal . Catch.throwM @IO
 
@@ -232,22 +231,6 @@ instance Member (Final IO) r => Catch.MonadCatch (Sem r) where
     handler' <- bindS handler
     pure $ m' `Catch.catch` \e -> handler' $ e <$ st
 
--- | Call a cassandra command in the 'Spar' monad.  Catch all exceptions and re-throw them as 500 in
--- Handler.
-wrapMonadClient :: Cas.Client a -> Spar r a
-wrapMonadClient action =
-  Spar $ do
-    ctx <- asks sparCtxCas
-    fromSpar $ wrapMonadClientSem $ embedFinal @IO $ runClient ctx action
-
--- | Lift a cassandra command into the 'Spar' monad. Like 'wrapMonadClient',
--- but doesn't catch any exceptions.
-liftMonadClient :: Cas.Client a -> Spar r a
-liftMonadClient action =
-  Spar $ do
-    ctx <- asks sparCtxCas
-    lift $ lift $ embedFinal @IO $ runClient ctx action
-
 -- | Call a 'Sem' command in the 'Spar' monad.  Catch all (IO) exceptions and
 -- re-throw them as 500 in Handler.
 wrapMonadClientSem :: Sem r a -> Spar r a
@@ -425,7 +408,27 @@ bindUser buid userref = do
       Ephemeral -> err oldStatus
       PendingInvitation -> Intra.setStatus buid Active
 
-instance (r ~ '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore, Embed (Cas.Client), Embed IO, Final IO]) => SPHandler SparError (Spar r) where
+instance
+  ( r
+      ~ '[ BindCookieStore,
+           AssIDStore,
+           AReqIDStore,
+           ScimExternalIdStore,
+           ScimUserTimesStore,
+           ScimTokenStore,
+           DefaultSsoCode,
+           IdPEffect.IdP,
+           SAMLUserStore,
+           Embed (Cas.Client),
+           ReaderEff.Reader Opts,
+           Error TTLError,
+           Error SparError,
+           Embed IO,
+           Final IO
+         ]
+  ) =>
+  SPHandler SparError (Spar r)
+  where
   type NTCTX (Spar r) = Env
   nt :: forall a. Env -> Spar r a -> Handler a
   nt ctx (Spar action) = do
@@ -434,18 +437,25 @@ instance (r ~ '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, Default
     where
       actionHandler :: Handler (Either SparError a)
       actionHandler =
-        liftIO $
-          runFinal $
-            embedToFinal @IO $
-              interpretClientToIO (sparCtxCas ctx) $
-                samlUserStoreToCassandra @Cas.Client $
-                  idPToCassandra @Cas.Client $
-                    defaultSsoCodeToCassandra $
-                      scimTokenStoreToCassandra $
-                        scimUserTimesStoreToCassandra $
-                          scimExternalIdStoreToCassandra $
-                            runExceptT $
-                              runReaderT action ctx
+        fmap join $
+          liftIO $
+            runFinal $
+              embedToFinal @IO $
+                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
       throwErrorAsHandlerException :: Either SparError a -> Handler a
       throwErrorAsHandlerException (Left err) =
         sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError
@@ -475,14 +485,21 @@ instance Intra.MonadSparToGalley (Spar r) where
 -- signed in-response-to info in the assertions matches the unsigned in-response-to field in the
 -- 'SAML.Response', and fills in the response id in the header if missing, we can just go for the
 -- latter.
-verdictHandler :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> Spar r SAML.ResponseVerdict
+verdictHandler ::
+  HasCallStack =>
+  Members '[BindCookieStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
+  Maybe BindCookie ->
+  Maybe TeamId ->
+  SAML.AuthnResponse ->
+  SAML.AccessVerdict ->
+  Spar r SAML.ResponseVerdict
 verdictHandler cky mbteam aresp verdict = do
   -- [3/4.1.4.2]
   -- <SubjectConfirmation> [...] If the containing message is in response to an <AuthnRequest>, then
   -- the InResponseTo attribute MUST match the request's ID.
   SAML.logger SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict)
   reqid <- either (throwSpar . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp
-  format :: Maybe VerdictFormat <- wrapMonadClient $ Data.getVerdictFormat reqid
+  format :: Maybe VerdictFormat <- wrapMonadClientSem $ AReqIDStore.getVerdictFormat reqid
   resp <- case format of
     Just (VerdictFormatWeb) ->
       verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb
@@ -500,7 +517,13 @@ data VerdictHandlerResult
   | VerifyHandlerError {_vhrLabel :: ST, _vhrMessage :: ST}
   deriving (Eq, Show)
 
-verdictHandlerResult :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Spar r VerdictHandlerResult
+verdictHandlerResult ::
+  HasCallStack =>
+  Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
+  Maybe BindCookie ->
+  Maybe TeamId ->
+  SAML.AccessVerdict ->
+  Spar r VerdictHandlerResult
 verdictHandlerResult bindCky mbteam verdict = do
   SAML.logger SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky)
   result <- catchVerdictErrors $ verdictHandlerResultCore bindCky mbteam verdict
@@ -539,13 +562,19 @@ moveUserToNewIssuer oldUserRef newUserRef uid = do
   Intra.setBrigUserVeid uid (UrefOnly newUserRef)
   wrapMonadClientSem $ SAMLUserStore.delete uid oldUserRef
 
-verdictHandlerResultCore :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Spar r VerdictHandlerResult
+verdictHandlerResultCore ::
+  HasCallStack =>
+  Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
+  Maybe BindCookie ->
+  Maybe TeamId ->
+  SAML.AccessVerdict ->
+  Spar r VerdictHandlerResult
 verdictHandlerResultCore bindCky mbteam = \case
   SAML.AccessDenied reasons -> do
     pure $ VerifyHandlerDenied reasons
   SAML.AccessGranted userref -> do
     uid :: UserId <- do
-      viaBindCookie <- maybe (pure Nothing) (wrapMonadClient . Data.lookupBindCookie) bindCky
+      viaBindCookie <- maybe (pure Nothing) (wrapMonadClientSem . BindCookieStore.lookup) bindCky
       viaSparCassandra <- getUserIdByUref mbteam userref
       -- race conditions: if the user has been created on spar, but not on brig, 'getUser'
       -- returns 'Nothing'.  this is ok assuming 'createUser', 'bindUser' (called below) are