Skip to content

Commit 5426977

Browse files
isovectorisovector
authored
Spar Polysemy: Final Cassandra effects (#1806)
* 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 * changelog.d
1 parent 34e693b commit 5426977

File tree

12 files changed

+361
-131
lines changed

12 files changed

+361
-131
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
Polysemize the remainder of Spar's Cassandra effects

‎services/spar/spar.cabal

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ cabal-version: 1.12
44
--
55
-- see: https://github.com/sol/hpack
66
--
7-
-- hash: f135fc7f6d1e85694286faaeb615c1808dedee43fd207e59f50864481c2a9cca
7+
-- hash: d04f829f6801dc459cf2f535b387c77caf06d3d99c2d95c9b46c469c1ec8b890
88

99
name: spar
1010
version: 0.1
@@ -34,6 +34,12 @@ library
3434
Spar.Scim.Auth
3535
Spar.Scim.Types
3636
Spar.Scim.User
37+
Spar.Sem.AReqIDStore
38+
Spar.Sem.AReqIDStore.Cassandra
39+
Spar.Sem.AssIDStore
40+
Spar.Sem.AssIDStore.Cassandra
41+
Spar.Sem.BindCookieStore
42+
Spar.Sem.BindCookieStore.Cassandra
3743
Spar.Sem.DefaultSsoCode
3844
Spar.Sem.DefaultSsoCode.Cassandra
3945
Spar.Sem.IdP

‎services/spar/src/Spar/API.hs

Lines changed: 45 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -58,12 +58,17 @@ import qualified SAML2.WebSSO as SAML
5858
import Servant
5959
import qualified Servant.Multipart as Multipart
6060
import Spar.App
61-
import qualified Spar.Data as Data hiding (clearReplacedBy, deleteIdPRawMetadata, getIdPConfig, getIdPConfigsByTeam, getIdPIdByIssuerWithTeam, getIdPIdByIssuerWithoutTeam, getIdPRawMetadata, setReplacedBy, storeIdPConfig, storeIdPRawMetadata)
61+
import qualified Spar.Data as Data (GetIdPResult (..), Replaced (..), Replacing (..))
6262
import Spar.Error
6363
import qualified Spar.Intra.Brig as Brig
6464
import qualified Spar.Intra.Galley as Galley
6565
import Spar.Orphans ()
6666
import Spar.Scim
67+
import Spar.Sem.AReqIDStore (AReqIDStore)
68+
import qualified Spar.Sem.AReqIDStore as AReqIDStore
69+
import Spar.Sem.AssIDStore (AssIDStore)
70+
import Spar.Sem.BindCookieStore (BindCookieStore)
71+
import qualified Spar.Sem.BindCookieStore as BindCookieStore
6772
import Spar.Sem.DefaultSsoCode (DefaultSsoCode)
6873
import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode
6974
import qualified Spar.Sem.IdP as IdPEffect
@@ -84,7 +89,21 @@ app ctx =
8489
SAML.setHttpCachePolicy $
8590
serve (Proxy @API) (hoistServer (Proxy @API) (SAML.nt @SparError @(Spar _) ctx) (api $ sparCtxOpts ctx) :: Server API)
8691

87-
api :: Members '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore] r => Opts -> ServerT API (Spar r)
92+
api ::
93+
Members
94+
'[ BindCookieStore,
95+
AssIDStore,
96+
AReqIDStore,
97+
ScimExternalIdStore,
98+
ScimUserTimesStore,
99+
ScimTokenStore,
100+
DefaultSsoCode,
101+
IdPEffect.IdP,
102+
SAMLUserStore
103+
]
104+
r =>
105+
Opts ->
106+
ServerT API (Spar r)
88107
api opts =
89108
apiSSO opts
90109
:<|> authreqPrecheck
@@ -93,7 +112,19 @@ api opts =
93112
:<|> apiScim
94113
:<|> apiINTERNAL
95114

96-
apiSSO :: Members '[ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore] r => Opts -> ServerT APISSO (Spar r)
115+
apiSSO ::
116+
Members
117+
'[ BindCookieStore,
118+
AssIDStore,
119+
AReqIDStore,
120+
ScimTokenStore,
121+
DefaultSsoCode,
122+
IdPEffect.IdP,
123+
SAMLUserStore
124+
]
125+
r =>
126+
Opts ->
127+
ServerT APISSO (Spar r)
97128
apiSSO opts =
98129
SAML.meta appName (sparSPIssuer Nothing) (sparResponseURI Nothing)
99130
:<|> (\tid -> SAML.meta appName (sparSPIssuer (Just tid)) (sparResponseURI (Just tid)))
@@ -131,7 +162,7 @@ authreqPrecheck msucc merr idpid =
131162
*> return NoContent
132163

133164
authreq ::
134-
Member IdPEffect.IdP r =>
165+
Members '[BindCookieStore, AssIDStore, AReqIDStore, IdPEffect.IdP] r =>
135166
NominalDiffTime ->
136167
DoInitiate ->
137168
Maybe UserId ->
@@ -150,23 +181,23 @@ authreq authreqttl _ zusr msucc merr idpid = do
150181
WireIdPAPIV1 -> Nothing
151182
WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam
152183
SAML.authreq authreqttl (sparSPIssuer mbtid) idpid
153-
wrapMonadClient $ Data.storeVerdictFormat authreqttl reqid vformat
184+
wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat
154185
cky <- initializeBindCookie zusr authreqttl
155186
SAML.logger SAML.Debug $ "setting bind cookie: " <> show cky
156187
pure $ addHeader cky form
157188

158189
-- | If the user is already authenticated, create bind cookie with a given life expectancy and our
159190
-- domain, and store it in C*. If the user is not authenticated, return a deletion 'SetCookie'
160191
-- value that deletes any bind cookies on the client.
161-
initializeBindCookie :: Maybe UserId -> NominalDiffTime -> Spar r SetBindCookie
192+
initializeBindCookie :: Member BindCookieStore r => Maybe UserId -> NominalDiffTime -> Spar r SetBindCookie
162193
initializeBindCookie zusr authreqttl = do
163194
DerivedOpts {derivedOptsBindCookiePath} <- asks (derivedOpts . sparCtxOpts)
164195
msecret <-
165196
if isJust zusr
166197
then liftIO $ Just . cs . ES.encode <$> randBytes 32
167198
else pure Nothing
168199
cky <- fmap SetBindCookie . SAML.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret
169-
forM_ zusr $ \userid -> wrapMonadClientWithEnv $ Data.insertBindCookie cky userid authreqttl
200+
forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl
170201
pure cky
171202

172203
redirectURLMaxLength :: Int
@@ -187,7 +218,13 @@ validateRedirectURL uri = do
187218
unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do
188219
throwSpar $ SparBadInitiateLoginQueryParams "url-too-long"
189220

190-
authresp :: forall r. Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe TeamId -> Maybe ST -> SAML.AuthnResponseBody -> Spar r Void
221+
authresp ::
222+
forall r.
223+
Members '[BindCookieStore, AssIDStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
224+
Maybe TeamId ->
225+
Maybe ST ->
226+
SAML.AuthnResponseBody ->
227+
Spar r Void
191228
authresp mbtid ckyraw arbody = logErrors $ SAML.authresp mbtid (sparSPIssuer mbtid) (sparResponseURI mbtid) go arbody
192229
where
193230
cky :: Maybe BindCookie

‎services/spar/src/Spar/App.hs

Lines changed: 84 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -25,8 +25,6 @@ module Spar.App
2525
( Spar (..),
2626
Env (..),
2727
toLevel,
28-
wrapMonadClientWithEnv,
29-
wrapMonadClient,
3028
wrapMonadClientSem,
3129
verdictHandler,
3230
GetUserResult (..),
@@ -41,14 +39,12 @@ module Spar.App
4139
deleteTeam,
4240
wrapSpar,
4341
liftSem,
44-
liftMonadClient,
4542
)
4643
where
4744

4845
import Bilge
4946
import Brig.Types (ManagedBy (..), User, userId, userTeam)
5047
import Brig.Types.Intra (AccountStatus (..), accountStatus, accountUser)
51-
import Cassandra
5248
import qualified Cassandra as Cas
5349
import Control.Exception (assert)
5450
import Control.Lens hiding ((.=))
@@ -68,7 +64,9 @@ import Imports hiding (log)
6864
import qualified Network.HTTP.Types.Status as Http
6965
import qualified Network.Wai.Utilities.Error as Wai
7066
import Polysemy
67+
import Polysemy.Error
7168
import Polysemy.Final
69+
import qualified Polysemy.Reader as ReaderEff
7270
import SAML2.Util (renderURI)
7371
import SAML2.WebSSO
7472
( Assertion (..),
@@ -84,7 +82,6 @@ import SAML2.WebSSO
8482
SPStoreIdP (getIdPConfigByIssuerOptionalSPId),
8583
UnqualifiedNameID (..),
8684
explainDeniedReason,
87-
fromTime,
8885
idpExtraInfo,
8986
idpId,
9087
uidTenant,
@@ -93,11 +90,20 @@ import qualified SAML2.WebSSO as SAML
9390
import qualified SAML2.WebSSO.Types.Email as SAMLEmail
9491
import Servant
9592
import qualified Servant.Multipart as Multipart
96-
import qualified Spar.Data as Data hiding (deleteSAMLUser, deleteSAMLUsersByIssuer, getIdPConfig, getSAMLAnyUserByIssuer, getSAMLSomeUsersByIssuer, getSAMLUser, insertSAMLUser, storeIdPConfig)
93+
import qualified Spar.Data as Data (GetIdPResult (..))
9794
import Spar.Error
9895
import qualified Spar.Intra.Brig as Intra
9996
import qualified Spar.Intra.Galley as Intra
10097
import Spar.Orphans ()
98+
import Spar.Sem.AReqIDStore (AReqIDStore)
99+
import qualified Spar.Sem.AReqIDStore as AReqIDStore
100+
import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError)
101+
import Spar.Sem.AssIDStore (AssIDStore)
102+
import qualified Spar.Sem.AssIDStore as AssIDStore
103+
import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra)
104+
import Spar.Sem.BindCookieStore (BindCookieStore)
105+
import qualified Spar.Sem.BindCookieStore as BindCookieStore
106+
import Spar.Sem.BindCookieStore.Cassandra (bindCookieStoreToCassandra)
101107
import Spar.Sem.DefaultSsoCode (DefaultSsoCode)
102108
import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra)
103109
import Spar.Sem.IdP (GetIdPResult (..))
@@ -186,15 +192,15 @@ toLevel = \case
186192
SAML.Debug -> Log.Debug
187193
SAML.Trace -> Log.Trace
188194

189-
instance SPStoreID AuthnRequest (Spar r) where
190-
storeID i r = wrapMonadClientWithEnv $ Data.storeAReqID i r
191-
unStoreID r = wrapMonadClient $ Data.unStoreAReqID r
192-
isAliveID r = wrapMonadClient $ Data.isAliveAReqID r
195+
instance Member AReqIDStore r => SPStoreID AuthnRequest (Spar r) where
196+
storeID i r = wrapMonadClientSem $ AReqIDStore.store i r
197+
unStoreID r = wrapMonadClientSem $ AReqIDStore.unStore r
198+
isAliveID r = wrapMonadClientSem $ AReqIDStore.isAlive r
193199

194-
instance SPStoreID Assertion (Spar r) where
195-
storeID i r = wrapMonadClientWithEnv $ Data.storeAssID i r
196-
unStoreID r = wrapMonadClient $ Data.unStoreAssID r
197-
isAliveID r = wrapMonadClient $ Data.isAliveAssID r
200+
instance Member AssIDStore r => SPStoreID Assertion (Spar r) where
201+
storeID i r = wrapMonadClientSem $ AssIDStore.store i r
202+
unStoreID r = wrapMonadClientSem $ AssIDStore.unStore r
203+
isAliveID r = wrapMonadClientSem $ AssIDStore.isAlive r
198204

199205
instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where
200206
type IdPConfigExtra (Spar r) = WireIdP
@@ -215,13 +221,6 @@ instance Member IdPEffect.IdP r => SPStoreIdP SparError (Spar r) where
215221
res@(Data.GetIdPNonUnique _) -> throwSpar $ SparIdPNotFound (cs $ show res)
216222
res@(Data.GetIdPWrongTeam _) -> throwSpar $ SparIdPNotFound (cs $ show res)
217223

218-
-- | 'wrapMonadClient' with an 'Env' in a 'ReaderT', and exceptions. If you
219-
-- don't need either of those, 'wrapMonadClient' will suffice.
220-
wrapMonadClientWithEnv :: forall r a. ReaderT Data.Env (ExceptT TTLError Cas.Client) a -> Spar r a
221-
wrapMonadClientWithEnv action = do
222-
denv <- Data.mkEnv <$> (sparCtxOpts <$> ask) <*> (fromTime <$> getNow)
223-
either (throwSpar . SparCassandraTTLError) pure =<< wrapMonadClient (runExceptT $ action `runReaderT` denv)
224-
225224
instance Member (Final IO) r => Catch.MonadThrow (Sem r) where
226225
throwM = embedFinal . Catch.throwM @IO
227226

@@ -232,22 +231,6 @@ instance Member (Final IO) r => Catch.MonadCatch (Sem r) where
232231
handler' <- bindS handler
233232
pure $ m' `Catch.catch` \e -> handler' $ e <$ st
234233

235-
-- | Call a cassandra command in the 'Spar' monad. Catch all exceptions and re-throw them as 500 in
236-
-- Handler.
237-
wrapMonadClient :: Cas.Client a -> Spar r a
238-
wrapMonadClient action =
239-
Spar $ do
240-
ctx <- asks sparCtxCas
241-
fromSpar $ wrapMonadClientSem $ embedFinal @IO $ runClient ctx action
242-
243-
-- | Lift a cassandra command into the 'Spar' monad. Like 'wrapMonadClient',
244-
-- but doesn't catch any exceptions.
245-
liftMonadClient :: Cas.Client a -> Spar r a
246-
liftMonadClient action =
247-
Spar $ do
248-
ctx <- asks sparCtxCas
249-
lift $ lift $ embedFinal @IO $ runClient ctx action
250-
251234
-- | Call a 'Sem' command in the 'Spar' monad. Catch all (IO) exceptions and
252235
-- re-throw them as 500 in Handler.
253236
wrapMonadClientSem :: Sem r a -> Spar r a
@@ -425,7 +408,27 @@ bindUser buid userref = do
425408
Ephemeral -> err oldStatus
426409
PendingInvitation -> Intra.setStatus buid Active
427410

428-
instance (r ~ '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, IdPEffect.IdP, SAMLUserStore, Embed (Cas.Client), Embed IO, Final IO]) => SPHandler SparError (Spar r) where
411+
instance
412+
( r
413+
~ '[ BindCookieStore,
414+
AssIDStore,
415+
AReqIDStore,
416+
ScimExternalIdStore,
417+
ScimUserTimesStore,
418+
ScimTokenStore,
419+
DefaultSsoCode,
420+
IdPEffect.IdP,
421+
SAMLUserStore,
422+
Embed (Cas.Client),
423+
ReaderEff.Reader Opts,
424+
Error TTLError,
425+
Error SparError,
426+
Embed IO,
427+
Final IO
428+
]
429+
) =>
430+
SPHandler SparError (Spar r)
431+
where
429432
type NTCTX (Spar r) = Env
430433
nt :: forall a. Env -> Spar r a -> Handler a
431434
nt ctx (Spar action) = do
@@ -434,18 +437,25 @@ instance (r ~ '[ScimExternalIdStore, ScimUserTimesStore, ScimTokenStore, Default
434437
where
435438
actionHandler :: Handler (Either SparError a)
436439
actionHandler =
437-
liftIO $
438-
runFinal $
439-
embedToFinal @IO $
440-
interpretClientToIO (sparCtxCas ctx) $
441-
samlUserStoreToCassandra @Cas.Client $
442-
idPToCassandra @Cas.Client $
443-
defaultSsoCodeToCassandra $
444-
scimTokenStoreToCassandra $
445-
scimUserTimesStoreToCassandra $
446-
scimExternalIdStoreToCassandra $
447-
runExceptT $
448-
runReaderT action ctx
440+
fmap join $
441+
liftIO $
442+
runFinal $
443+
embedToFinal @IO $
444+
runError @SparError $
445+
ttlErrorToSparError $
446+
ReaderEff.runReader (sparCtxOpts ctx) $
447+
interpretClientToIO (sparCtxCas ctx) $
448+
samlUserStoreToCassandra @Cas.Client $
449+
idPToCassandra @Cas.Client $
450+
defaultSsoCodeToCassandra $
451+
scimTokenStoreToCassandra $
452+
scimUserTimesStoreToCassandra $
453+
scimExternalIdStoreToCassandra $
454+
aReqIDStoreToCassandra $
455+
assIDStoreToCassandra $
456+
bindCookieStoreToCassandra $
457+
runExceptT $
458+
runReaderT action ctx
449459
throwErrorAsHandlerException :: Either SparError a -> Handler a
450460
throwErrorAsHandlerException (Left err) =
451461
sparToServerErrorWithLogging (sparCtxLogger ctx) err >>= throwError
@@ -475,14 +485,21 @@ instance Intra.MonadSparToGalley (Spar r) where
475485
-- signed in-response-to info in the assertions matches the unsigned in-response-to field in the
476486
-- 'SAML.Response', and fills in the response id in the header if missing, we can just go for the
477487
-- latter.
478-
verdictHandler :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AuthnResponse -> SAML.AccessVerdict -> Spar r SAML.ResponseVerdict
488+
verdictHandler ::
489+
HasCallStack =>
490+
Members '[BindCookieStore, AReqIDStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
491+
Maybe BindCookie ->
492+
Maybe TeamId ->
493+
SAML.AuthnResponse ->
494+
SAML.AccessVerdict ->
495+
Spar r SAML.ResponseVerdict
479496
verdictHandler cky mbteam aresp verdict = do
480497
-- [3/4.1.4.2]
481498
-- <SubjectConfirmation> [...] If the containing message is in response to an <AuthnRequest>, then
482499
-- the InResponseTo attribute MUST match the request's ID.
483500
SAML.logger SAML.Debug $ "entering verdictHandler: " <> show (fromBindCookie <$> cky, aresp, verdict)
484501
reqid <- either (throwSpar . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp
485-
format :: Maybe VerdictFormat <- wrapMonadClient $ Data.getVerdictFormat reqid
502+
format :: Maybe VerdictFormat <- wrapMonadClientSem $ AReqIDStore.getVerdictFormat reqid
486503
resp <- case format of
487504
Just (VerdictFormatWeb) ->
488505
verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb
@@ -500,7 +517,13 @@ data VerdictHandlerResult
500517
| VerifyHandlerError {_vhrLabel :: ST, _vhrMessage :: ST}
501518
deriving (Eq, Show)
502519

503-
verdictHandlerResult :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Spar r VerdictHandlerResult
520+
verdictHandlerResult ::
521+
HasCallStack =>
522+
Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
523+
Maybe BindCookie ->
524+
Maybe TeamId ->
525+
SAML.AccessVerdict ->
526+
Spar r VerdictHandlerResult
504527
verdictHandlerResult bindCky mbteam verdict = do
505528
SAML.logger SAML.Debug $ "entering verdictHandlerResult: " <> show (fromBindCookie <$> bindCky)
506529
result <- catchVerdictErrors $ verdictHandlerResultCore bindCky mbteam verdict
@@ -539,13 +562,19 @@ moveUserToNewIssuer oldUserRef newUserRef uid = do
539562
Intra.setBrigUserVeid uid (UrefOnly newUserRef)
540563
wrapMonadClientSem $ SAMLUserStore.delete uid oldUserRef
541564

542-
verdictHandlerResultCore :: HasCallStack => Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => Maybe BindCookie -> Maybe TeamId -> SAML.AccessVerdict -> Spar r VerdictHandlerResult
565+
verdictHandlerResultCore ::
566+
HasCallStack =>
567+
Members '[BindCookieStore, ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r =>
568+
Maybe BindCookie ->
569+
Maybe TeamId ->
570+
SAML.AccessVerdict ->
571+
Spar r VerdictHandlerResult
543572
verdictHandlerResultCore bindCky mbteam = \case
544573
SAML.AccessDenied reasons -> do
545574
pure $ VerifyHandlerDenied reasons
546575
SAML.AccessGranted userref -> do
547576
uid :: UserId <- do
548-
viaBindCookie <- maybe (pure Nothing) (wrapMonadClient . Data.lookupBindCookie) bindCky
577+
viaBindCookie <- maybe (pure Nothing) (wrapMonadClientSem . BindCookieStore.lookup) bindCky
549578
viaSparCassandra <- getUserIdByUref mbteam userref
550579
-- race conditions: if the user has been created on spar, but not on brig, 'getUser'
551580
-- returns 'Nothing'. this is ok assuming 'createUser', 'bindUser' (called below) are

0 commit comments

Comments
 (0)