In SCIM, formar Spar errors using SCIM error schema

wireapp · Apr 8, 2019 · 31cd368 · 31cd368
1 parent cab111c
commit 31cd368
Show file tree

Hide file tree

Showing 3 changed files with 63 additions and 6 deletions.
diff --git 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
@@ -51,10 +51,16 @@ module Spar.Scim
     ) where
 
 import Imports
+
+import Control.Lens
+import Control.Monad.Catch (try)
 import Control.Monad.Except
+import Data.String.Conversions (cs)
 import Servant
 import Servant.API.Generic
-import Spar.App (Spar)
+import Spar.App (Spar(..), Env(..))
+import Spar.Error (SparError, SparCustomError(SparScimError),
+                   throwSpar, sparToServantErrWithLogging)
 import Spar.Scim.Types
 import Spar.Scim.Auth
 import Spar.Scim.User
@@ -79,9 +85,53 @@ apiScim :: ServerT APIScim Spar
 apiScim = hoistScim (toServant (Scim.siteServer configuration))
      :<|> apiScimToken
   where
-    hoistScim = hoistServer (Proxy @(Scim.SiteAPI SparTag))
-                            (Scim.fromScimHandler fromError)
-    fromError = throwError . SAML.CustomServant . Scim.scimToServantErr
+    hoistScim = hoistServer
+        (Proxy @(Scim.SiteAPI SparTag))
+        (wrapScimErrors . Scim.fromScimHandler (throwSpar . SparScimError))
+
+    -- 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 <https://github.com/haskell-servant/servant/issues/1022>
+    -- for why it's hard to catch impure exceptions.
+    wrapScimErrors :: Spar a -> Spar a
+    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.CustomError . SparScimError $
+                    Scim.serverError (cs (errBody err))
+
+            -- No exceptions! Good.
+            Right (Right x) -> pure $ Right x
+
+----------------------------------------------------------------------------
+-- 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
diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs
@@ -525,7 +525,7 @@ toScimEmail (Email eLocal eDomain) =
 -- Note [error handling]
 -- ~~~~~~~~~~~~~~~~~
 --
--- There are two problems with error handling here:
+-- FUTUREWORK: There are two problems with error handling here:
 --
 -- 1. We want all errors originating from SCIM handlers to be thrown as SCIM
 --    errors, not as Spar errors. Currently errors thrown from things like
@@ -534,4 +534,5 @@ toScimEmail (Email eLocal eDomain) =
 --    on what is expected by apps that use the SCIM interface.
 --
 -- 2. We want generic error descriptions in response bodies, while still
---    logging nice error messages internally.
+--    logging nice error messages internally. The current messages might
+--    be giving too many internal details away.