Rework

wireapp · Apr 8, 2019 · 76061e9 · 76061e9
1 parent e0bed1e
commit 76061e9
Show file tree

Hide file tree

Showing 2 changed files with 42 additions and 28 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
@@ -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 <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 ->
-        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