Refactor NewIdP; clarify dsig cert confusion.

- NewIdP type is less redundant now.
- update `/services/integration.yaml` to account for changes in NewIdP type.
- update C* schema to allow for more than one dsig cert for
  authentication response signing.  (at least azure does this, and
  there is no way of knowing which certs will be used, so we need to
  try all of them.)  (`frozen<blob>` was rejected by C*; `blob` only
  caused runtime errors; `list<blob>` works fine, at least for the
  tests I have.)
- update validateNewIdP to account for the above changes.
- mock idp now responds with fresh issuer name on every /meta request.
- Cleanup
- haddocks
- remove test case that is no longer valid (cert list for signing authn
  responses should not contain the cert for signing metadata)

services/integration.yaml

@@ -35,18 +35,16 @@ provider:
   botHost: https://127.0.0.1
   botPort: 9000
 
-# Used by spar-integration
-newIdp:
-  metadata: https://localhost:9001/meta
-  issuer: https://localhost:9001/
-  requestUri: https://localhost:9001/resp
-  publicKey: '<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>'
-
 # 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

services/spar/package.yaml

@@ -40,7 +40,7 @@ dependencies:
   - mtl
   - optparse-applicative
   - raw-strings-qq
-  - saml2-web-sso >= 0.6
+  - saml2-web-sso >= 0.9
   - scientific
   - servant
   - servant-multipart

services/spar/schema/src/Main.hs

@@ -9,6 +9,7 @@ import Util.Options
 
 import qualified V0
 import qualified V1
+import qualified V2
 
 main :: IO ()
 main = do
@@ -19,4 +20,5 @@ main = do
     migrateSchema l o
         [ V0.migration
         , V1.migration
+        , V2.migration
         ] `finally` close l

services/spar/schema/src/V2.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module V2 (migration) where
+
+import Cassandra.Schema
+import Control.Monad (void)
+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>; |]

services/spar/src/Spar/API.hs

@@ -40,6 +40,7 @@ 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
@@ -60,6 +61,7 @@ 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
@@ -185,8 +187,7 @@ idpDelete zusr idpid = withDebugLog "idpDelete" (const Nothing) $ do
 idpCreate :: ZUsr -> SAML.NewIdP -> Spar IdP
 idpCreate zusr newIdP = withDebugLog "idpCreate" (Just . show . (^. SAML.idpId)) $ do
   teamid <- getZUsrOwnedTeam zusr
-  validateNewIdP newIdP
-  idp <- initializeIdP newIdP teamid
+  idp <- validateNewIdP newIdP teamid
   SAML.storeIdPConfig idp
   pure idp
 
@@ -215,19 +216,19 @@ getZUsrOwnedTeam (Just uid) = do
     Nothing -> throwSpar SparNotInTeam
     Just teamid -> teamid <$ Intra.assertIsTeamOwner uid teamid
 
-initializeIdP :: SAML.NewIdP -> TeamId -> Spar IdP
-initializeIdP (SAML.NewIdP _idpMetadata _idpIssuer _idpRequestUri _idpPublicKey) _idpeTeam = do
+
+-- | FUTUREWORK: much of this function could move to the saml2-web-sso package.
+validateNewIdP :: forall m. (HasCallStack, m ~ Spar)
+               => SAML.NewIdP -> TeamId -> m IdP
+validateNewIdP (SAML.NewIdP _idpMetadataURI metadataPublicKey) _idpeTeam = do
   _idpId <- SAML.IdPId <$> SAML.createUUID
   _idpeSPInfo <- wrapMonadClientWithEnv $ Data.getSPInfo _idpId
   let _idpExtraInfo = IdPExtra { _idpeTeam, _idpeSPInfo }
-  pure SAML.IdPConfig {..}
 
+  _idpMetadata :: SAML.IdPMetadata
+    <- fetchMetadata _idpMetadataURI metadataPublicKey
 
--- | FUTUREWORK: much of this function could move to the saml2-web-sso package.
-validateNewIdP :: forall m. (HasCallStack, m ~ Spar)
-               => SAML.NewIdP -> m ()
-validateNewIdP newidp = do
-  wrapMonadClient (Data.getIdPIdByIssuer (newidp ^. SAML.nidpIssuer)) >>= \case
+  wrapMonadClient (Data.getIdPIdByIssuer (_idpMetadata ^. SAML.edIssuer)) >>= \case
     Nothing -> pure ()
     Just _ -> throwSpar SparNewIdPAlreadyInUse
     -- each idp (issuer) can only be created once.  if you want to update (one of) your team's
@@ -241,15 +242,19 @@ validateNewIdP newidp = do
     -- idp to decide this for us, we would have to think of a way to prevent rogue idps from
     -- creating users in victim teams.
 
-  let uri2req :: URI.URI -> m Request
-      uri2req = either (throwSpar . SparNewIdPBadMetaUrl . cs . show) pure
-              . Rq.parseRequest . cs . SAML.renderURI
+  pure SAML.IdPConfig {..}
 
-      fetch :: URI.URI -> (Request -> Request) -> m (Bilge.Response (Maybe LBS))
+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.
@@ -260,19 +265,18 @@ validateNewIdP newidp = do
         either (throwSpar . SparNewIdPBadMetaUrl . cs . show @SomeException) pure result
 
   metaResp :: Bilge.Response (Maybe LBS)
-    <- fetch (newidp ^. SAML.nidpMetadata) (method GET . expect2xx)
+    <- fetch metadataUrl (method GET . expect2xx)
   metaBody :: LBS
     <- maybe (throwSpar $ SparNewIdPBadMetaUrl "No body in response.") pure $ responseBody metaResp
   when (isLeft $ do
-           creds <- SAML.certToCreds $ newidp ^. SAML.nidpPublicKey
-           SAML.verifyRoot creds metaBody) $ do
+           creds <- SAML.certToCreds pubkey
+           SAML.verifyRoot (creds :| []) metaBody) $ do
     throwSpar SparNewIdPBadMetaSig
-  meta :: SAML.IdPDesc
+  meta :: SAML.IdPMetadata
     <- either (throwSpar . SparNewIdPBadMetaUrl . cs) pure $ do
          XML.Document _ el _ <- fmapL show $ XML.parseLBS XML.def metaBody
-         SAML.parseIdPDesc el
-  when (newidp ^. SAML.nidpPublicKey `notElem` meta ^. SAML.edPublicKeys) $
-    throwSpar SparNewIdPPubkeyMismatch
+         SAML.parseIdPMetadata el
+  pure meta
 
 
 -- | Type families to convert spar's 'API' type into an "outside-world-view" API type

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

@@ -115,6 +115,9 @@ instance ToSchema IdPExtra where
 instance ToSchema a => ToSchema (SAML.IdPConfig a) where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
 
+instance ToSchema SAML.IdPMetadata where
+  declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
+
 instance ToSchema IdPList where
   declareNamedSchema = genericDeclareNamedSchema samlSchemaOptions
 

services/spar/src/Spar/Data.hs

@@ -34,6 +34,7 @@ import Spar.Options as Options
 import Spar.Types
 import URI.ByteString
 
+import qualified Data.List.NonEmpty as NL
 import qualified Data.UUID as UUID
 import qualified SAML2.WebSSO as SAML
 import qualified Data.ByteString.Char8 as BSC
@@ -169,18 +170,20 @@ getUser (SAML.UserRef tenant subject) = fmap runIdentity <$>
 ----------------------------------------------------------------------
 -- idp
 
-type IdPConfigRow = (SAML.IdPId, URI, SAML.Issuer, URI, SignedCertificate, TeamId)
+type IdPConfigRow = (SAML.IdPId, URI, 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.idpMetadata
+    , idp ^. SAML.idpMetadataURI
     , idp ^. SAML.idpIssuer
     , idp ^. SAML.idpRequestUri
-    , idp ^. SAML.idpPublicKey
+    , NL.head (idp ^. SAML.idpPublicKeys)
+    , NL.tail (idp ^. SAML.idpPublicKeys)
+      -- (the 'List1' is split up into head and tail to make migration from one-element-only easier.)
     , idp ^. SAML.idpExtraInfo . idpeTeam
     )
   addPrepQuery byIssuer
@@ -193,7 +196,7 @@ storeIdPConfig idp = retry x5 . batch $ do
     )
   where
     ins :: PrepQuery W IdPConfigRow ()
-    ins = "INSERT INTO idp (idp, metadata, issuer, request_uri, public_key, team) VALUES (?, ?, ?, ?, ?, ?)"
+    ins = "INSERT INTO idp (idp, metadata, 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 (?, ?)"
@@ -214,19 +217,23 @@ getIdPConfig idpid =
   where
     toIdp :: IdPConfigRow -> m IdP
     toIdp ( _idpId
-          , _idpMetadata
-          , _idpIssuer
-          , _idpRequestUri
-          , _idpPublicKey
+          , _idpMetadataURI
+          -- metadata
+          , _edIssuer
+          , _edRequestURI
+          , certsHead
+          , certsTail
           -- extras
           , _idpeTeam
           ) = do
       _idpeSPInfo <- getSPInfo _idpId
-      let _idpExtraInfo = IdPExtra { _idpeTeam, _idpeSPInfo }
+      let _edCertAuthnResponse = certsHead NL.:| certsTail
+          _idpMetadata = SAML.IdPMetadata {..}
+          _idpExtraInfo = IdPExtra { _idpeTeam, _idpeSPInfo }
       pure $ SAML.IdPConfig {..}
 
     sel :: PrepQuery R (Identity SAML.IdPId) IdPConfigRow
-    sel = "SELECT idp, metadata, issuer, request_uri, public_key, team FROM idp WHERE idp = ?"
+    sel = "SELECT idp, metadata, issuer, request_uri, public_key, extra_public_keys, team FROM idp WHERE idp = ?"
 
 getIdPConfigByIssuer
   :: (HasCallStack, MonadClient m, MonadReader Env m)

services/spar/test-integration/Test/Spar/APISpec.hs

@@ -29,6 +29,7 @@ import SAML2.WebSSO.Test.Credentials
 import SAML2.WebSSO.Test.MockResponse
 import Spar.Types
 import Text.XML
+import URI.ByteString as URI
 import URI.ByteString.QQ (uri)
 import Util
 
@@ -236,7 +237,7 @@ spec = do
         context "some idps are registered" $ do
           it "returns a non-empty empty list" $ do
             env <- ask
-            newidp <- makeTestNewIdP
+            (newidp, _) <- makeTestNewIdP
             (owner, _, _) <- createTestIdPFrom newidp (env ^. teMgr) (env ^. teBrig) (env ^. teGalley) (env ^. teSpar)
             callIdpGetAll (env ^. teSpar) (Just owner)
               `shouldRespondWith` (not . null . _idplProviders)
@@ -299,13 +300,13 @@ spec = do
           --
           -- spar will request the metadata url; validate the metadata received from the mock idp we
           -- just loaded here; and return the expected error (or not).
-          createIdpMockErr :: HasCallStack => Maybe (NewIdP -> IO [Node]) -> TestErrorLabel -> ReaderT TestEnv IO ()
-          createIdpMockErr metadata errlabel = do
+          createIdpMockErr :: HasCallStack => Maybe (Issuer -> URI -> IO [Node]) -> TestErrorLabel -> ReaderT TestEnv IO ()
+          createIdpMockErr mkMetadata errlabel = do
             env <- ask
-            newidp <- makeTestNewIdP
-            case metadata of
+            (newidp, IdPMetadata issuer requri _certs) <- makeTestNewIdP
+            case mkMetadata of
               Nothing -> pure ()
-              Just mk -> liftIO $ mk newidp >>= atomically . writeTChan (env ^. teIdPChan)
+              Just mk -> liftIO $ mk issuer requri >>= atomically . writeTChan (env ^. teIdPChan)
             callIdpCreate' (env ^. teSpar) (Just (env ^. teUserId)) newidp
               `shouldRespondWith` checkErr (== 400) errlabel
 
@@ -316,7 +317,7 @@ spec = do
       context "bad metadata answer" $ do
         it "rejects" $ do
           createIdpMockErr
-            (Just . const . pure $ [NodeElement (Element "bloo" mempty mempty)])
+            (Just $ \_ _ -> pure [NodeElement (Element "bloo" mempty mempty)])
             "invalid-signature"  -- well, this is just what it checks first...
 
       context "invalid metadata signature" $ do
@@ -325,29 +326,34 @@ spec = do
             (Just $ sampleIdPMetadata' sampleIdPPrivkey2 sampleIdPCert)
             "invalid-signature"
 
-      context "pubkey in IdPConfig does not match the one provided in metadata url" $ do
-        it "rejects" $ do
-          createIdpMockErr
-            (Just $ sampleIdPMetadata' sampleIdPPrivkey sampleIdPCert2)
-            "key-mismatch"
-
       context "idp (identified by issuer) is in use by other team" $ do
         it "rejects" $ do
           env <- ask
+          let newidp = env ^. teNewIdP
+              requri = env ^. teTstOpts . to cfgMockIdp . to mockidpRequestURI
+          resetMeta <- do
+            issuer <- makeIssuer
+            metadata <- sampleIdPMetadata newidp issuer requri
+            pure . liftIO . atomically $ writeTChan (env ^. teIdPChan) metadata
+
           (uid1, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley)
           (uid2, _) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley)
-          newidp    <- makeTestNewIdP
+          resetMeta
           resp1     <- call $ callIdpCreate' (env ^. teSpar) (Just uid1) newidp
-          resp2     <- call $ callIdpCreate' (env ^. teSpar) (Just uid2) newidp
+          resetMeta
+          resp2     <- call $ callIdpCreate' (env ^. teSpar) (Just uid1) newidp
+          resetMeta
+          resp3     <- call $ callIdpCreate' (env ^. teSpar) (Just uid2) newidp
           liftIO $ do
             statusCode resp1 `shouldBe` 201
             statusCode resp2 `shouldBe` 400
+            statusCode resp3 `shouldBe` 400
             responseJSON resp2 `shouldBe` Right (TestErrorLabel "idp-already-in-use")
 
       context "everything in order" $ do
         it "responds with 2xx; makes IdP available for GET /identity-providers/" $ do
           env <- ask
-          newidp <- makeTestNewIdP
+          (newidp, _) <- makeTestNewIdP
           idp <- call $ callIdpCreate (env ^. teSpar) (Just (env ^. teUserId)) newidp
           idp' <- call $ callIdpGet (env ^. teSpar) (Just (env ^. teUserId)) (idp ^. idpId)
           liftIO $ idp `shouldBe` idp'