Simplify!

[Keep this commit in the history.  If we ever need to pull metadata
directly from the IdP later, revert it.]

- NewIdP goes away entirely, replaced by IdPMetadata.  When
  registering an IdP with an SP, we just send the 'IdPMetadata'.  No
  communication between SP and IdP is expected to take place.
- IdPMetadata does not carry a self-sign cert any more.  The channel
  through which IdPMetadata is send to the SP needs to be
  authenticated elsewhere.
- No need for any mock idp service in the integration tests.  Removed
  lots of code that was at least in parts working very nicely!  m-(

Author: fisx

services/integration.yaml

@@ -34,23 +34,3 @@ provider:
   cert: test/resources/cert.pem
   botHost: https://127.0.0.1
   botPort: 9000
-
-# Used by spar-integration
-# NB: this will run on http, without SSL.  this "should" not be the
-# case in production, but according to the standard it is technically
-# legal.
-mockIdp:
-  metadataURI: https://localhost:9001/meta
-  issuer: https://localhost:9001/
-  requestURI: https://localhost:9001/resp
-  dSigCert: '<ds:KeyInfo xmlns:ds="http://www.w3.org/2000/09/xmldsig#"><ds:X509Data><ds:X509Certificate>MIIB/zCCASigAwIBAgIOEyBZjWrTHqmgBPAVkAUwDQYJKoZIhvcNAQELBQAwADAeFw0xODA4MTYxMjQzNTdaFw0zODA4MTExMjQzNTdaMAAwgd0wDQYJKoZIhvcNAQEBBQADgcsAMIHHAoHBAMHb4Ne1z2cQD1TXcVmYBy0Q1EnmQl5IncCfC6/eGrp0qpa5sqaQPlRtvS3UEczpAgf9ml+kL6aK56xEBH2Zv/mlkvBEbxASxVha3LhcIg9TNAg0vm2KJBG1pZvHx8OIKhpDCfabkSJF+MxXvtTrp0JTRfQr2BHkegZNX3hCaF5JGyGIMBinTRwEi5duDfNUsJoG5MwNq/hrd7pLdjOWgs4CLlNV6L+3rvhhYt+e0QUeh9QrZFUfhXxezlfYfP36WQIBETANBgkqhkiG9w0BAQsFAAOBwQBtZqvROSfV1znZws9h6M749g1HRpm3vub3RKAZOWfqP2Qag2ML+BjAqEIH1SAaQSZlFbKRsKM2Bp/QpG5ByshwrxoS9ausPNynulMA7dEPvWOExfqYO9Vj/0ejxwAmilseKrVfv333yvcgVRNRqP/LMxqe/8Hw3Ax+Ul83usIZLQ5m4sW9/IUVwlDLk31ddIkPVpx2USKL9eVDXjVhIl7itgJxPyG0wc0I9Ad/ZWy/Dbbilwz1tHcZSZsxSdNFW+k=</ds:X509Certificate></ds:X509Data></ds:KeyInfo>'
-
-  bind:  # what should the mock idp bind to?  (usually 0.0.0.0 or 127.0.0.1)
-    host: 127.0.0.1
-    port: 9001
-  connect:  # where should integration tests send their requests?
-    host: 127.0.0.1
-    port: 9001
-  privateKey: test-integration/resources/key.pem
-  publicKey: test-integration/resources/pubkey.pem
-  cert: test-integration/resources/cert.pem

services/spar/package.yaml

@@ -23,7 +23,6 @@ dependencies:
   - bytestring-conversion
   - case-insensitive
   - cassandra-util
-  - connection
   - containers
   - cookie
   - cryptonite
@@ -40,7 +39,7 @@ dependencies:
   - mtl
   - optparse-applicative
   - raw-strings-qq
-  - saml2-web-sso >= 0.9
+  - saml2-web-sso >= 0.11
   - scientific
   - servant
   - servant-multipart
@@ -51,7 +50,6 @@ dependencies:
   - text
   - time
   - tinylog
-  - tls
   - transformers
   - types-common
   - uri-bytestring

services/spar/schema/src/V2.hs

@@ -10,4 +10,10 @@ import Text.RawString.QQ
 migration :: Migration
 migration = Migration 2 "Add extra idp keys set" $ do
 
-    void $ schema' [r| ALTER TABLE idp ADD extra_public_keys list<blob>; |]
+    void $ schema' [r|
+        ALTER TABLE idp DROP metadata;
+    |]
+
+    void $ schema' [r|
+        ALTER TABLE idp ADD extra_public_keys list<blob>;
+    |]

services/spar/spar.integration.yaml

@@ -35,5 +35,3 @@ maxttlAuthreq: 5  # seconds.  don't set this too large, it is also the run time
 maxttlAuthresp: 7200  # seconds.  do not set this to 1h or less, as that is what the mock idp wants.
 
 logNetStrings: False # log using netstrings encoding (see http://cr.yp.to/proto/netstrings.txt)
-
-tlsDisableCertValidation: True  # only for testing!  in production, this must be set to 'False'!

services/spar/src/Spar/API.hs

@@ -32,15 +32,9 @@ module Spar.API
   , IdpDelete
   ) where
 
-import Bilge
 import Brig.Types.User as Brig
-import Control.Exception
 import Control.Monad.Except
-import Control.Monad.Reader
-import Data.Either
-import Data.EitherR (fmapL)
 import Data.Id
-import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Maybe (isJust, fromJust)
 import Data.Proxy
 import Data.String.Conversions
@@ -61,14 +55,9 @@ import Spar.Options
 import Spar.Types
 
 import qualified Data.ByteString as SBS
-import qualified Data.X509 as X509
-import qualified Network.HTTP.Client as Rq
 import qualified SAML2.WebSSO as SAML
 import qualified Spar.Data as Data
 import qualified Spar.Intra.Brig as Intra
-import qualified Text.XML as XML
-import qualified Text.XML.DSig as SAML
-import qualified Text.XML.Util as SAML
 import qualified URI.ByteString as URI
 
 
@@ -108,7 +97,7 @@ type APIAuthResp = "sso" :> "finalize-login" :> SAML.APIAuthResp
 
 type IdpGet     = Header "Z-User" UserId :> "identity-providers" :> Capture "id" SAML.IdPId :> Get '[JSON] IdP
 type IdpGetAll  = Header "Z-User" UserId :> "identity-providers" :> Get '[JSON] IdPList
-type IdpCreate  = Header "Z-User" UserId :> "identity-providers" :> ReqBody '[JSON] SAML.NewIdP :> PostCreated '[JSON] IdP
+type IdpCreate  = Header "Z-User" UserId :> "identity-providers" :> ReqBody '[SAML.XML] SAML.IdPMetadata :> PostCreated '[JSON] IdP
 type IdpDelete  = Header "Z-User" UserId :> "identity-providers" :> Capture "id" SAML.IdPId :> DeleteNoContent '[JSON] NoContent
 
 -- FUTUREWORK (thanks jschaul): In a more recent version of servant, using Header '[Strict] becomes
@@ -184,10 +173,10 @@ idpDelete zusr idpid = withDebugLog "idpDelete" (const Nothing) $ do
     return NoContent
 
 -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness.
-idpCreate :: ZUsr -> SAML.NewIdP -> Spar IdP
-idpCreate zusr newIdP = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do
+idpCreate :: ZUsr -> SAML.IdPMetadata -> Spar IdP
+idpCreate zusr idpmeta = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do
   teamid <- getZUsrOwnedTeam zusr
-  idp <- validateNewIdP newIdP teamid
+  idp <- validateNewIdP idpmeta teamid
   SAML.storeIdPConfig idp
   pure idp
 
@@ -217,17 +206,15 @@ getZUsrOwnedTeam (Just uid) = do
     Just teamid -> teamid <$ Intra.assertIsTeamOwner uid teamid
 
 
--- | FUTUREWORK: much of this function could move to the saml2-web-sso package.
+-- | FUTUREWORK: move this to the saml2-web-sso package.  (same probably goes for get, create,
+-- update, delete of idps.)
 validateNewIdP :: forall m. (HasCallStack, m ~ Spar)
-               => SAML.NewIdP -> TeamId -> m IdP
-validateNewIdP (SAML.NewIdP _idpMetadataURI metadataPublicKey) _idpeTeam = do
+               => SAML.IdPMetadata -> TeamId -> m IdP
+validateNewIdP _idpMetadata _idpeTeam = do
   _idpId <- SAML.IdPId <$> SAML.createUUID
   _idpeSPInfo <- wrapMonadClientWithEnv $ Data.getSPInfo _idpId
   let _idpExtraInfo = IdPExtra { _idpeTeam, _idpeSPInfo }
 
-  _idpMetadata :: SAML.IdPMetadata
-    <- fetchMetadata _idpMetadataURI metadataPublicKey
-
   wrapMonadClient (Data.getIdPIdByIssuer (_idpMetadata ^. SAML.edIssuer)) >>= \case
     Nothing -> pure ()
     Just _ -> throwSpar SparNewIdPAlreadyInUse
@@ -244,40 +231,6 @@ validateNewIdP (SAML.NewIdP _idpMetadataURI metadataPublicKey) _idpeTeam = do
 
   pure SAML.IdPConfig {..}
 
-fetchMetadata :: forall m. (HasCallStack, m ~ Spar) => URI.URI -> X509.SignedCertificate -> m SAML.IdPMetadata
-fetchMetadata metadataUrl pubkey = do
-  let fetch :: URI.URI -> (Request -> Request) -> m (Bilge.Response (Maybe LBS))
-      fetch uri modify = do
-        req <- uri2req uri
-        ntm (httpLbs req modify)
-
-      uri2req :: URI.URI -> m Request
-      uri2req = either (throwSpar . SparNewIdPBadMetaUrl . cs . show) pure
-              . Rq.parseRequest . cs . SAML.renderURI
-
-      -- natural transformation into 'm'.  needed for the http client that fetches the metadata url.
-      -- if 'IO' throws an exception, we capture it with 'try' and re-throw it inside 'm', which
-      -- yields much nicer client errors and logs.
-      ntm :: forall a. Http a -> m a
-      ntm (HttpT action) = do
-        mgr :: Manager <- getManager
-        result :: Either SomeException a <- liftIO . try $ runReaderT action mgr
-        either (throwSpar . SparNewIdPBadMetaUrl . cs . show @SomeException) pure result
-
-  metaResp :: Bilge.Response (Maybe LBS)
-    <- fetch metadataUrl (method GET . expect2xx)
-  metaBody :: LBS
-    <- maybe (throwSpar $ SparNewIdPBadMetaUrl "No body in response.") pure $ responseBody metaResp
-  when (isLeft $ do
-           creds <- SAML.certToCreds pubkey
-           SAML.verifyRoot (creds :| []) metaBody) $ do
-    throwSpar SparNewIdPBadMetaSig
-  meta :: SAML.IdPMetadata
-    <- either (throwSpar . SparNewIdPBadMetaUrl . cs) pure $ do
-         XML.Document _ el _ <- fmapL show $ XML.parseLBS XML.def metaBody
-         SAML.parseIdPMetadata el
-  pure meta
-
 
 -- | Type families to convert spar's 'API' type into an "outside-world-view" API type
 -- to expose as swagger docs intended to be used by client developers.

services/spar/src/Spar/API/Swagger.hs

@@ -121,9 +121,6 @@ instance ToSchema SAML.IdPMetadata where
 instance ToSchema IdPList where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
 
-instance ToSchema SAML.NewIdP where
-  declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
-
 instance ToSchema (SAML.ID SAML.AuthnRequest) where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
 

services/spar/src/Spar/Data.hs

@@ -170,15 +170,14 @@ getUser (SAML.UserRef tenant subject) = fmap runIdentity <$>
 ----------------------------------------------------------------------
 -- idp
 
-type IdPConfigRow = (SAML.IdPId, URI, SAML.Issuer, URI, SignedCertificate, [SignedCertificate], TeamId)
+type IdPConfigRow = (SAML.IdPId, SAML.Issuer, URI, SignedCertificate, [SignedCertificate], TeamId)
 
 storeIdPConfig :: (HasCallStack, MonadClient m) => SAML.IdPConfig IdPExtra -> m ()
 storeIdPConfig idp = retry x5 . batch $ do
   setType BatchLogged
   setConsistency Quorum
   addPrepQuery ins
     ( idp ^. SAML.idpId
-    , idp ^. SAML.idpMetadataURI
     , idp ^. SAML.idpIssuer
     , idp ^. SAML.idpRequestUri
     , NL.head (idp ^. SAML.idpPublicKeys)
@@ -196,7 +195,7 @@ storeIdPConfig idp = retry x5 . batch $ do
     )
   where
     ins :: PrepQuery W IdPConfigRow ()
-    ins = "INSERT INTO idp (idp, metadata, issuer, request_uri, public_key, extra_public_keys, team) VALUES (?, ?, ?, ?, ?, ?, ?)"
+    ins = "INSERT INTO idp (idp, issuer, request_uri, public_key, extra_public_keys, team) VALUES (?, ?, ?, ?, ?, ?)"
 
     byIssuer :: PrepQuery W (SAML.IdPId, SAML.Issuer) ()
     byIssuer = "INSERT INTO issuer_idp (idp, issuer) VALUES (?, ?)"
@@ -217,7 +216,6 @@ getIdPConfig idpid =
   where
     toIdp :: IdPConfigRow -> m IdP
     toIdp ( _idpId
-          , _idpMetadataURI
           -- metadata
           , _edIssuer
           , _edRequestURI
@@ -233,7 +231,7 @@ getIdPConfig idpid =
       pure $ SAML.IdPConfig {..}
 
     sel :: PrepQuery R (Identity SAML.IdPId) IdPConfigRow
-    sel = "SELECT idp, metadata, issuer, request_uri, public_key, extra_public_keys, team FROM idp WHERE idp = ?"
+    sel = "SELECT idp, issuer, request_uri, public_key, extra_public_keys, team FROM idp WHERE idp = ?"
 
 getIdPConfigByIssuer
   :: (HasCallStack, MonadClient m, MonadReader Env m)

services/spar/src/Spar/Options.hs

@@ -38,7 +38,6 @@ data Opts = Opts
     , maxttlAuthresp :: !(TTL "authresp")
     , discoUrl       :: !(Maybe Text) -- Wire/AWS specific; optional; used to discover cassandra instance IPs using describe-instances
     , logNetStrings  :: !Bool
-    , tlsDisableCertValidation :: !Bool -- always set to 'False' in production!  see 'sparManager'.
     -- , optSettings   :: !Settings  -- (nothing yet; see other services for what belongs in here.)
     }
   deriving (Show, Generic)

services/spar/src/Spar/Run.hs

@@ -25,7 +25,6 @@ import Data.Metrics (metrics)
 import Data.String.Conversions
 import Data.String (fromString)
 import Lens.Micro
-import Network.HTTP.Client (responseTimeoutMicro)
 import Network.Wai (Application)
 import Network.Wai.Utilities.Request (lookupRequestId)
 import Spar.API
@@ -41,9 +40,6 @@ import Util.Options (epHost, epPort)
 
 import qualified Cassandra.Schema as Cas
 import qualified Cassandra.Settings as Cas
-import qualified Network.Connection as TLS
-import qualified Network.HTTP.Client.TLS as TLS
-import qualified Network.TLS.Extra.Cipher as TLS
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Utilities.Server as WU
 import qualified SAML2.WebSSO as SAML
@@ -99,7 +95,7 @@ runServer sparCtxOpts = do
   let settings = Warp.defaultSettings
         & Warp.setHost (fromString $ sparCtxOpts ^. to saml . SAML.cfgSPHost)
         . Warp.setPort (sparCtxOpts ^. to saml . SAML.cfgSPPort)
-  sparCtxHttpManager <- sparManager (tlsDisableCertValidation sparCtxOpts)
+  sparCtxHttpManager <- newManager defaultManagerSettings
   let sparCtxHttpBrig = Bilge.host (sparCtxOpts ^. to brig . epHost . to cs)
                       . Bilge.port (sparCtxOpts ^. to brig . epPort)
                       $ Bilge.empty
@@ -113,26 +109,6 @@ runServer sparCtxOpts = do
         $ \sparCtxRequestId -> app Env {..}
   WU.runSettingsWithShutdown settings wrappedApp 5
 
--- | Create a TLS-capabable manager for fetching metadata from IdPs.
---
--- NB: In integration tests, we turn certificate validation off.  This is not ideal, but the
--- alternative would be to register a mock certificate with the production spar service, which is
--- not trivial and thus not risk-free either:
---
--- * https://stackoverflow.com/questions/25833305/accepting-specific-certificate-with-http-client-tls-or-tls
--- * https://stackoverflow.com/questions/40081508/how-to-provide-a-client-certificate-to-http-client-tls#40082394
-sparManager :: Bool -> IO Manager
-sparManager disableCertificateValidation = newManager (TLS.mkManagerSettings tlss Nothing)
-  { managerResponseTimeout = responseTimeoutMicro (10 * 1000 * 1000)
-  }
-  where
-    tlss = TLS.TLSSettingsSimpleWithCiphers
-      { TLS.settingDisableCertificateValidation = disableCertificateValidation
-      , TLS.settingSupportedCiphers = TLS.ciphersuite_default  -- this is why we are pinned to https://github.com/vincenthz/hs-connection/pull/36
-      , TLS.settingDisableSession = False
-      , TLS.settingUseServerName = False
-      }
-
 lookupRequestIdMiddleware :: (RequestId -> Application) -> Application
 lookupRequestIdMiddleware mkapp req cont = do
   let reqid = maybe mempty RequestId $ lookupRequestId req