Spar Polysemy: SAML2 effect

changelog.d/5-internal/saml2-effect

@@ -0,0 +1 @@
+Add some new Spar effects, completely isolating us from saml2-web-sso interface

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 573e0f5c3d7b76dbb9fbf48aff2a535df3059af23f8375307021c6c005d98a5b
+-- hash: fe28e95f2571e0a2583e7d160ff87f80422801408c265139b1cd2392a425fd72
 
 name:           spar
 version:        0.1
@@ -22,6 +22,7 @@ library
   exposed-modules:
       Spar.API
       Spar.App
+      Spar.CanonicalInterpreter
       Spar.Data
       Spar.Data.Instances
       Spar.Error
@@ -52,8 +53,14 @@ library
       Spar.Sem.IdP.Mem
       Spar.Sem.Logger
       Spar.Sem.Logger.TinyLog
+      Spar.Sem.Now
+      Spar.Sem.Now.IO
       Spar.Sem.Random
       Spar.Sem.Random.IO
+      Spar.Sem.SAML2
+      Spar.Sem.SAML2.Library
+      Spar.Sem.SamlProtocolSettings
+      Spar.Sem.SamlProtocolSettings.Servant
       Spar.Sem.SAMLUserStore
       Spar.Sem.SAMLUserStore.Cassandra
       Spar.Sem.ScimExternalIdStore

services/spar/src/Spar/API.hs

@@ -59,6 +59,7 @@ import qualified SAML2.WebSSO as SAML
 import Servant
 import qualified Servant.Multipart as Multipart
 import Spar.App
+import Spar.CanonicalInterpreter
 import qualified Spar.Data as Data (GetIdPResult (..), Replaced (..), Replacing (..))
 import Spar.Error
 import qualified Spar.Intra.BrigApp as Brig
@@ -78,10 +79,15 @@ import qualified Spar.Sem.GalleyAccess as GalleyAccess
 import qualified Spar.Sem.IdP as IdPEffect
 import Spar.Sem.Logger (Logger)
 import qualified Spar.Sem.Logger as Logger
+import Spar.Sem.Now (Now)
 import Spar.Sem.Random (Random)
 import qualified Spar.Sem.Random as Random
+import Spar.Sem.SAML2 (SAML2)
+import qualified Spar.Sem.SAML2 as SAML2
 import Spar.Sem.SAMLUserStore (SAMLUserStore)
 import qualified Spar.Sem.SAMLUserStore as SAMLUserStore
+import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings)
+import qualified Spar.Sem.SamlProtocolSettings as SamlProtocolSettings
 import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore)
 import Spar.Sem.ScimTokenStore (ScimTokenStore)
 import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
@@ -97,7 +103,7 @@ import Wire.API.User.Saml
 app :: Env -> Application
 app ctx =
   SAML.setHttpCachePolicy $
-    serve (Proxy @API) (hoistServer (Proxy @API) (SAML.nt @SparError @(Spar _) ctx) (api $ sparCtxOpts ctx) :: Server API)
+    serve (Proxy @API) (hoistServer (Proxy @API) (runSparToHandler ctx) (api $ sparCtxOpts ctx) :: Server API)
 
 api ::
   Members
@@ -115,9 +121,14 @@ api ::
        IdPEffect.IdP,
        SAMLUserStore,
        Random,
+       Error SparError,
+       SAML2,
+       Now,
+       SamlProtocolSettings,
        Logger String,
        Logger (Msg -> Msg),
-       Error SparError
+       -- TODO(sandy): Remove me when we get rid of runSparInSem
+       Final IO
      ]
     r =>
   Opts ->
@@ -144,14 +155,19 @@ apiSSO ::
        DefaultSsoCode,
        IdPEffect.IdP,
        Random,
-       SAMLUserStore
+       Error SparError,
+       SAML2,
+       SamlProtocolSettings,
+       SAMLUserStore,
+       -- TODO(sandy): Remove me when we get rid of runSparInSem
+       Final IO
      ]
     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)))
+  (liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing))
+    :<|> (\tid -> liftSem $ SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid)))
     :<|> authreqPrecheck
     :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin
     :<|> authresp Nothing
@@ -202,7 +218,7 @@ appName = "spar"
 authreqPrecheck :: Member IdPEffect.IdP r => Maybe URI.URI -> Maybe URI.URI -> SAML.IdPId -> Spar r NoContent
 authreqPrecheck msucc merr idpid =
   validateAuthreqParams msucc merr
-    *> SAML.getIdPConfig idpid
+    *> getIdPConfig idpid
     *> return NoContent
 
 authreq ::
@@ -213,6 +229,8 @@ authreq ::
        BindCookieStore,
        AssIDStore,
        AReqIDStore,
+       SAML2,
+       SamlProtocolSettings,
        IdPEffect.IdP
      ]
     r =>
@@ -233,7 +251,7 @@ authreq authreqttl _ zusr msucc merr idpid = do
         mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . wiApiVersion) of
           WireIdPAPIV1 -> Nothing
           WireIdPAPIV2 -> Just $ idp ^. SAML.idpExtraInfo . wiTeam
-    SAML.authreq authreqttl (sparSPIssuer mbtid) idpid
+    liftSem $ SAML2.authReq authreqttl (SamlProtocolSettings.spIssuer mbtid) idpid
   wrapMonadClientSem $ AReqIDStore.storeVerdictFormat authreqttl reqid vformat
   cky <- initializeBindCookie zusr authreqttl
   liftSem $ Logger.log SAML.Debug $ "setting bind cookie: " <> show cky
@@ -243,7 +261,14 @@ authreq authreqttl _ zusr msucc merr idpid = do
 -- 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 ::
-  Members '[Random, Input Opts, Logger String, BindCookieStore] r =>
+  Members
+    '[ Random,
+       SAML2,
+       Input Opts,
+       Logger String,
+       BindCookieStore
+     ]
+    r =>
   Maybe UserId ->
   NominalDiffTime ->
   Spar r SetBindCookie
@@ -253,7 +278,7 @@ initializeBindCookie zusr authreqttl = do
     if isJust zusr
       then liftSem $ Just . cs . ES.encode <$> Random.bytes 32
       else pure Nothing
-  cky <- fmap SetBindCookie . SAML.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret
+  cky <- fmap SetBindCookie . liftSem . SAML2.toggleCookie derivedOptsBindCookiePath $ (,authreqttl) <$> msecret
   forM_ zusr $ \userid -> wrapMonadClientSem $ BindCookieStore.insert cky userid authreqttl
   pure cky
 
@@ -289,28 +314,33 @@ authresp ::
        AReqIDStore,
        ScimTokenStore,
        IdPEffect.IdP,
-       SAMLUserStore
+       SAML2,
+       SamlProtocolSettings,
+       Error SparError,
+       SAMLUserStore,
+       -- TODO(sandy): Remove me when we get rid of runSparInSem
+       Final IO
      ]
     r =>
   Maybe TeamId ->
   Maybe ST ->
   SAML.AuthnResponseBody ->
   Spar r Void
-authresp mbtid ckyraw arbody = logErrors $ SAML.authresp mbtid (sparSPIssuer mbtid) (sparResponseURI mbtid) go arbody
+authresp mbtid ckyraw arbody = logErrors $ liftSem $ SAML2.authResp mbtid (SamlProtocolSettings.spIssuer mbtid) (SamlProtocolSettings.responseURI mbtid) go arbody
   where
     cky :: Maybe BindCookie
     cky = ckyraw >>= bindCookieFromHeader
 
-    go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Spar r Void
+    go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Sem r Void
     go resp verdict = do
-      result :: SAML.ResponseVerdict <- verdictHandler cky mbtid resp verdict
-      throwError $ SAML.CustomServant result
+      result :: SAML.ResponseVerdict <- runSparInSem $ verdictHandler cky mbtid resp verdict
+      throw @SparError $ SAML.CustomServant result
 
     logErrors :: Spar r Void -> Spar r Void
-    logErrors = flip catchError $ \case
-      e@(SAML.CustomServant _) -> throwError e
+    logErrors action = liftSem . catch @SparError (runSparInSem action) $ \case
+      e@(SAML.CustomServant _) -> throw e
       e -> do
-        throwError . SAML.CustomServant $
+        throw @SparError . SAML.CustomServant $
           errorPage
             e
             (Multipart.inputs (SAML.authnResponseBodyRaw arbody))
@@ -337,7 +367,7 @@ idpGet ::
   SAML.IdPId ->
   Spar r IdP
 idpGet zusr idpid = withDebugLog "idpGet" (Just . show . (^. SAML.idpId)) $ do
-  idp <- SAML.getIdPConfig idpid
+  idp <- getIdPConfig idpid
   _ <- liftSem $ authorizeIdP zusr idp
   pure idp
 
@@ -347,7 +377,7 @@ idpGetRaw ::
   SAML.IdPId ->
   Spar r RawIdPMetadata
 idpGetRaw zusr idpid = do
-  idp <- SAML.getIdPConfig idpid
+  idp <- getIdPConfig idpid
   _ <- liftSem $ authorizeIdP zusr idp
   wrapMonadClientSem (IdPEffect.getRawMetadata idpid) >>= \case
     Just txt -> pure $ RawIdPMetadata txt
@@ -396,7 +426,7 @@ idpDelete ::
   Maybe Bool ->
   Spar r NoContent
 idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (const Nothing) $ do
-  idp <- SAML.getIdPConfig idpid
+  idp <- getIdPConfig idpid
   _ <- liftSem $ authorizeIdP zusr idp
   let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
       team = idp ^. SAML.idpExtraInfo . wiTeam
@@ -491,7 +521,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive
   assertNoScimOrNoIdP teamid
   idp <- validateNewIdP apiversion idpmeta teamid mReplaces
   wrapMonadClientSem $ IdPEffect.storeRawMetadata (idp ^. SAML.idpId) raw
-  SAML.storeIdPConfig idp
+  storeIdPConfig idp
   forM_ mReplaces $ \replaces -> wrapMonadClientSem $ do
     IdPEffect.setReplacedBy (Data.Replaced replaces) (Data.Replacing (idp ^. SAML.idpId))
   pure idp
@@ -539,7 +569,7 @@ validateNewIdP ::
   Maybe SAML.IdPId ->
   m IdP
 validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validateNewIdP" (Just . show . (^. SAML.idpId)) $ do
-  _idpId <- SAML.IdPId <$> SAML.createUUID
+  _idpId <- SAML.IdPId <$> liftSem Random.uuid
   oldIssuers :: [SAML.Issuer] <- case mReplaces of
     Nothing -> pure []
     Just replaces -> do
@@ -616,7 +646,7 @@ idpUpdateXML zusr raw idpmeta idpid = withDebugLog "idpUpdate" (Just . show . (^
   -- (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
   -- try again, which would clean up cassandra state.)
-  SAML.storeIdPConfig idp
+  storeIdPConfig idp
   pure idp
 
 -- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in