diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index e91e3620308..16fb1b6cd5c 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -28,6 +28,7 @@ import qualified Network.Wai.Utilities.Error as Wai import qualified Network.Wai.Utilities.Server as Wai import qualified SAML2.WebSSO as SAML import qualified System.Logger as Log +import qualified Web.Scim.Schema.Error as Scim type SparError = SAML.Error SparCustomError @@ -77,6 +78,9 @@ data SparCustomError | SparProvisioningNoSingleIdP LT | SparProvisioningTokenLimitReached + + -- | All errors returned from SCIM handlers are wrapped into 'SparScimError' + | SparScimError Scim.ScimError deriving (Eq, Show) sparToServantErrWithLogging :: MonadIO m => Log.Logger -> SparError -> m ServantErr @@ -159,5 +163,7 @@ renderSparError (SAML.CustomError (SparNewIdPWantHttps msg)) = Rig -- Errors related to provisioning renderSparError (SAML.CustomError (SparProvisioningNoSingleIdP msg)) = Right $ Wai.Error status400 "no-single-idp" ("Team should have exactly one IdP configured: " <> msg) renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.Error status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" +-- SCIM errors +renderSparError (SAML.CustomError (SparScimError err)) = Left $ Scim.scimToServantErr err -- Other renderSparError (SAML.CustomServant err) = Left err diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index a59a8bedb93..c1a237d4d8f 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -59,7 +59,8 @@ import Data.String.Conversions (cs) import Servant import Servant.API.Generic import Spar.App (Spar(..), Env(..)) -import Spar.Error (SparError, sparToServantErrWithLogging) +import Spar.Error (SparError, SparCustomError(SparScimError), + throwSpar, sparToServantErrWithLogging) import Spar.Scim.Types import Spar.Scim.Auth import Spar.Scim.User @@ -84,46 +85,53 @@ apiScim :: ServerT APIScim Spar apiScim = hoistScim (toServant (Scim.siteServer configuration)) :<|> apiScimToken where - hoistScim = hoistServer (Proxy @(Scim.SiteAPI SparTag)) - (wrapScimErrors . toSpar) + hoistScim = hoistServer + (Proxy @(Scim.SiteAPI SparTag)) + (wrapScimErrors . Scim.fromScimHandler (throwSpar . SparScimError)) - -- Unwrap the 'ScimHandler' - toSpar :: Scim.ScimHandler Spar a -> Spar a - toSpar = Scim.fromScimHandler - (throwError . SAML.CustomServant . Scim.scimToServantErr) - - -- Wrap all errors into the format required by SCIM. + -- Wrap /all/ errors into the format required by SCIM, even server exceptions that have + -- nothing to do with SCIM. -- -- FIXME: this doesn't catch impure exceptions (e.g. thrown with 'error'). -- Let's hope that SCIM clients can handle non-SCIM-formatted errors -- properly. See -- for why it's hard to catch impure exceptions. wrapScimErrors :: Spar a -> Spar a - wrapScimErrors = over _Spar $ \act -> \env -> - try @_ @SomeException (act env) >>= \case - -- We caught an exception that's not a Spar exception. It is - -- wrapped into SCIM.serverError and rethrown. - Left someException -> pure $ - Left . SAML.CustomServant . Scim.scimToServantErr $ - Scim.serverError (cs (displayException someException)) - -- We caught a 'CustomServant' exception. It should be left as-is - -- because by now all SCIM errors have become 'CustomServant' errors - -- (thanks to 'toSpar') and we don't want to wrap them *again*. - Right (Left (SAML.CustomServant x)) -> pure $ - Left (SAML.CustomServant x) - -- We caught some other Spar exception. It should be wrapped into - -- SCIM.serverError and rethrown. + wrapScimErrors = over _Spar $ \act -> \env -> do + result :: Either SomeException (Either SparError a) <- try (act env) + + case result of + -- We caught an exception that's not a Spar exception at all. It is wrapped into + -- Scim.serverError. + Left someException -> + pure $ Left . SAML.CustomError . SparScimError $ + Scim.serverError (cs (displayException someException)) + + -- We caught a 'SparScimError' exception. It is left as-is. + Right (Left (SAML.CustomError (SparScimError x))) -> + pure $ Left (SAML.CustomError (SparScimError x)) + + -- We caught some other Spar exception. It is wrapped into Scim.serverError. + -- + -- TODO: does it have to be logged? Right (Left sparError) -> do err <- sparToServantErrWithLogging (sparCtxLogger env) sparError - pure $ Left . SAML.CustomServant . Scim.scimToServantErr $ + pure $ Left . SAML.CustomError . SparScimError $ Scim.serverError (cs (errBody err)) + -- No exceptions! Good. Right (Right x) -> pure $ Right x - -- This isomorphism unwraps the Spar stack (Spar . ReaderT . ExceptT) into a - -- newtype-less form that's easier to work with. - _Spar :: Iso' (Spar a) (Env -> IO (Either SparError a)) - _Spar = coerced +---------------------------------------------------------------------------- +-- Orphan instances instance Scim.Group.GroupDB SparTag Spar where -- TODO + +---------------------------------------------------------------------------- +-- Utilities + +-- | An isomorphism that unwraps the Spar stack (@Spar . ReaderT . ExceptT@) into a +-- newtype-less form that's easier to work with. +_Spar :: Iso' (Spar a) (Env -> IO (Either SparError a)) +_Spar = coerced