Respond to review

Author: isovector

services/spar/spar.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 82d7ad03f637cd11a132d9237c35df9e3cc6038790f50999a27f3d287f5e02f0
+-- hash: fe28e95f2571e0a2583e7d160ff87f80422801408c265139b1cd2392a425fd72
 
 name:           spar
 version:        0.1
@@ -58,7 +58,9 @@ library
       Spar.Sem.Random
       Spar.Sem.Random.IO
       Spar.Sem.SAML2
-      Spar.Sem.SAML2.SAML2WebSso
+      Spar.Sem.SAML2.Library
+      Spar.Sem.SamlProtocolSettings
+      Spar.Sem.SamlProtocolSettings.Servant
       Spar.Sem.SAMLUserStore
       Spar.Sem.SAMLUserStore.Cassandra
       Spar.Sem.ScimExternalIdStore
@@ -67,8 +69,6 @@ library
       Spar.Sem.ScimTokenStore.Cassandra
       Spar.Sem.ScimUserTimesStore
       Spar.Sem.ScimUserTimesStore.Cassandra
-      Spar.Sem.SparRoute
-      Spar.Sem.SparRoute.Servant
   other-modules:
       Paths_spar
   hs-source-dirs:

services/spar/src/Spar/API.hs

@@ -86,12 +86,12 @@ 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
 import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore)
-import Spar.Sem.SparRoute (SparRoute)
-import qualified Spar.Sem.SparRoute as SparRoute
 import System.Logger (Msg)
 import qualified System.Logger as TinyLog
 import qualified URI.ByteString as URI
@@ -124,10 +124,9 @@ api ::
        Error SparError,
        SAML2,
        Now,
-       SparRoute,
+       SamlProtocolSettings,
        Logger String,
        Logger (Msg -> Msg),
-       Error SparError,
        -- TODO(sandy): Remove me when we get rid of runSparInSem
        Final IO
      ]
@@ -158,7 +157,7 @@ apiSSO ::
        Random,
        Error SparError,
        SAML2,
-       SparRoute,
+       SamlProtocolSettings,
        SAMLUserStore,
        -- TODO(sandy): Remove me when we get rid of runSparInSem
        Final IO
@@ -167,8 +166,8 @@ apiSSO ::
   Opts ->
   ServerT APISSO (Spar r)
 apiSSO opts =
-  (liftSem $ SAML2.meta appName (SparRoute.spIssuer Nothing) (SparRoute.responseURI Nothing))
-    :<|> (\tid -> liftSem $ SAML2.meta appName (SparRoute.spIssuer (Just tid)) (SparRoute.responseURI (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
@@ -231,7 +230,7 @@ authreq ::
        AssIDStore,
        AReqIDStore,
        SAML2,
-       SparRoute,
+       SamlProtocolSettings,
        IdPEffect.IdP
      ]
     r =>
@@ -252,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
-    liftSem $ SAML2.authReq authreqttl (SparRoute.spIssuer 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
@@ -316,7 +315,7 @@ authresp ::
        ScimTokenStore,
        IdPEffect.IdP,
        SAML2,
-       SparRoute,
+       SamlProtocolSettings,
        Error SparError,
        SAMLUserStore,
        -- TODO(sandy): Remove me when we get rid of runSparInSem
@@ -327,7 +326,7 @@ authresp ::
   Maybe ST ->
   SAML.AuthnResponseBody ->
   Spar r Void
-authresp mbtid ckyraw arbody = logErrors $ liftSem $ SAML2.authResp mbtid (SparRoute.spIssuer mbtid) (SparRoute.responseURI 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

services/spar/src/Spar/CanonicalInterpreter.hs

@@ -33,23 +33,23 @@ import Spar.Sem.Now.IO (nowToIO)
 import Spar.Sem.Random (Random)
 import Spar.Sem.Random.IO (randomToIO)
 import Spar.Sem.SAML2 (SAML2)
-import Spar.Sem.SAML2.SAML2WebSso (saml2ToSaml2WebSso)
+import Spar.Sem.SAML2.Library (saml2ToSaml2WebSso)
 import Spar.Sem.SAMLUserStore (SAMLUserStore)
 import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra)
+import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings)
+import Spar.Sem.SamlProtocolSettings.Servant (sparRouteToServant)
 import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore)
 import Spar.Sem.ScimExternalIdStore.Cassandra (scimExternalIdStoreToCassandra)
 import Spar.Sem.ScimTokenStore (ScimTokenStore)
 import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra)
 import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore)
 import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra)
-import Spar.Sem.SparRoute (SparRoute)
-import Spar.Sem.SparRoute.Servant (sparRouteToServant)
 import qualified System.Logger as TinyLog
 import Wire.API.User.Saml
 
 type CanonicalEffs =
   '[ SAML2,
-     SparRoute,
+     SamlProtocolSettings,
      BindCookieStore,
      AssIDStore,
      AReqIDStore,

services/spar/src/Spar/Error.hs

@@ -100,6 +100,7 @@ data SparCustomError
   | SparIdPIssuerInUse
   | SparProvisioningMoreThanOneIdP LT
   | SparProvisioningTokenLimitReached
+  | SparInternalError LT
   | -- | All errors returned from SCIM handlers are wrapped into 'SparScimError'
     SparScimError Scim.ScimError
   deriving (Eq, Show)
@@ -184,6 +185,7 @@ renderSparError (SAML.CustomError (SparProvisioningMoreThanOneIdP msg)) = Right
 renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.mkError status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached"
 -- SCIM errors
 renderSparError (SAML.CustomError (SparScimError err)) = Left $ Scim.scimToServerError err
+renderSparError (SAML.CustomError (SparInternalError err)) = Right $ Wai.mkError status500 "server-error" ("Internal error: " <> err)
 -- Other
 renderSparError (SAML.CustomServant err) = Left err
 

services/spar/src/Spar/Sem/SAML2/SAML2WebSso.hs renamed to services/spar/src/Spar/Sem/SAML2/Library.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
 
-module Spar.Sem.SAML2.SAML2WebSso (saml2ToSaml2WebSso) where
+module Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) where
 
 import qualified Control.Monad.Catch as Catch
 import Control.Monad.Except
@@ -15,7 +16,7 @@ import Polysemy.Internal.Tactics
 import SAML2.WebSSO hiding (Error)
 import qualified SAML2.WebSSO as SAML hiding (Error)
 import qualified Spar.App as App
-import Spar.Error (SparCustomError (SparCassandraError), SparError)
+import Spar.Error (SparCustomError (..), SparError)
 import Spar.Sem.AReqIDStore (AReqIDStore)
 import qualified Spar.Sem.AReqIDStore as AReqIDStore
 import Spar.Sem.AssIDStore (AssIDStore)
@@ -131,6 +132,6 @@ inspectOrBomb ::
 inspectOrBomb ins get_a = do
   fa <- SPImpl $ saml2ToSaml2WebSso get_a
   maybe
-    (error "saml2ToSaml2WebSso called with an uninspectable weaving functor")
+    (SPImpl . throw @SparError $ SAML.CustomError $ SparInternalError "saml2ToSaml2WebSso called with an uninspectable weaving functor")
     pure
     $ inspect ins fa

services/spar/src/Spar/Sem/SamlProtocolSettings.hs

@@ -0,0 +1,13 @@
+module Spar.Sem.SamlProtocolSettings where
+
+import Data.Id (TeamId)
+import Imports
+import Polysemy
+import qualified SAML2.WebSSO.Types as SAML
+import qualified URI.ByteString as URI
+
+data SamlProtocolSettings m a where
+  SpIssuer :: Maybe TeamId -> SamlProtocolSettings m SAML.Issuer
+  ResponseURI :: Maybe TeamId -> SamlProtocolSettings m URI.URI
+
+makeSem ''SamlProtocolSettings

services/spar/src/Spar/Sem/SparRoute/Servant.hs renamed to services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs

@@ -1,18 +1,18 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Spar.Sem.SparRoute.Servant where
+module Spar.Sem.SamlProtocolSettings.Servant where
 
 import Imports
 import Polysemy
 import qualified SAML2.WebSSO as SAML
-import Spar.Sem.SparRoute
+import Spar.Sem.SamlProtocolSettings
 import Wire.API.Routes.Public.Spar
 
 -- TODO(sandy): Why is this instance not provided by SAML? Very rude!
 instance SAML.HasConfig ((->) SAML.Config) where
   getConfig = id
 
-sparRouteToServant :: SAML.Config -> Sem (SparRoute ': r) a -> Sem r a
+sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a
 sparRouteToServant cfg = interpret $ \x -> case x of
   SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg
   ResponseURI mitlt -> pure $ sparResponseURI mitlt cfg