module Test.Spar.CertFingerprintAllowlist where

import API.GalleyInternal (setTeamFeatureStatus)
import API.Spar (createIdpWithZHostV2, updateIdp)
import Control.Lens ((.~), (^.))
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.X509 (SignedCertificate)
import qualified SAML2.WebSSO.Test.Util as SAMLTest
import qualified SAML2.WebSSO.Types as SAMLTypes
import SetupHelpers
import Testlib.Certs (fingerprintHex)
import Testlib.Prelude
import qualified Text.XML.DSig as XMLDSig

testAcceptsWhenAllowlistEmpty :: (HasCallStack) => App ()
testAcceptsWhenAllowlistEmpty :: HasCallStack => App ()
testAcceptsWhenAllowlistEmpty = do
  SAMLTest.SampleIdP idpmeta _ _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  SAMLTest.SampleIdP idpmeta2 _ _ _ <- SAMLTest.makeSampleIdPMetadata
  withModifiedBackend
    def {sparCfg = withAllowlist []}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      idpId <-
        createIdpWithZHostV2 owner Nothing idpmeta `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      updateIdp owner idpId idpmeta2 >>= assertStatus 200

testCreateRejectsWhenFingerprintNotListed :: (HasCallStack) => App ()
testCreateRejectsWhenFingerprintNotListed :: HasCallStack => App ()
testCreateRejectsWhenFingerprintNotListed = do
  SAMLTest.SampleIdP idpmeta _ _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  withModifiedBackend
    def {sparCfg = withAllowlist [bogusFingerprint]}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      createIdpWithZHostV2 owner Nothing idpmeta >>= assertLabel 403 "idp-cert-not-allowed"

testAcceptsWhenFingerprintListed :: (HasCallStack) => App ()
testAcceptsWhenFingerprintListed :: HasCallStack => App ()
testAcceptsWhenFingerprintListed = do
  SAMLTest.SampleIdP meta1 _ _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  SAMLTest.SampleIdP meta2 _ _ _ <- SAMLTest.makeSampleIdPMetadata
  let fpr1 = IdPMetadata -> String
firstCertFingerprint IdPMetadata
meta1
      fpr2 = IdPMetadata -> String
firstCertFingerprint IdPMetadata
meta2
  withModifiedBackend
    def {sparCfg = withAllowlist [fpr1, fpr2]}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      idpId <-
        createIdpWithZHostV2 owner Nothing meta1 `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      updateIdp owner idpId meta2 >>= assertStatus 200

testAcceptsMultiCertWhenAllListed :: (HasCallStack) => App ()
testAcceptsMultiCertWhenAllListed :: HasCallStack => App ()
testAcceptsMultiCertWhenAllListed = do
  (metaCreate, certsCreate) <- HasCallStack =>
Int -> App (IdPMetadata, NonEmpty SignedCertificate)
Int -> App (IdPMetadata, NonEmpty SignedCertificate)
makeIdPMetaWithCerts Int
2
  (metaUpdate, certsUpdate) <- makeIdPMetaWithCerts 3
  let allCerts = NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
certsCreate [SignedCertificate] -> [SignedCertificate] -> [SignedCertificate]
forall a. Semigroup a => a -> a -> a
<> NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty SignedCertificate
certsUpdate
  withModifiedBackend
    def {sparCfg = withAllowlist (fingerprintHex <$> allCerts)}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      idpId <-
        createIdpWithZHostV2 owner Nothing metaCreate `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      updateIdp owner idpId metaUpdate >>= assertStatus 200

testRejectsMultiCertWhenAnyMissing :: (HasCallStack) => App ()
testRejectsMultiCertWhenAnyMissing :: HasCallStack => App ()
testRejectsMultiCertWhenAnyMissing = do
  (multiMeta, _) <- HasCallStack =>
Int -> App (IdPMetadata, NonEmpty SignedCertificate)
Int -> App (IdPMetadata, NonEmpty SignedCertificate)
makeIdPMetaWithCerts Int
2
  SAMLTest.SampleIdP singleMeta _ _ _ <- SAMLTest.makeSampleIdPMetadata
  withModifiedBackend
    -- Allowlist only the first cert of multiMeta and singleMeta's cert.
    -- The second cert in multiMeta is intentionally not listed.
    def {sparCfg = withAllowlist (fingerprintHex <$> [firstCert multiMeta, firstCert singleMeta])}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      createIdpWithZHostV2 owner Nothing multiMeta >>= assertLabel 403 "idp-cert-not-allowed"
      idpId <-
        createIdpWithZHostV2 owner Nothing singleMeta `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      updateIdp owner idpId multiMeta >>= assertLabel 403 "idp-cert-not-allowed"

testUpdateRejectsWhenFingerprintNotListed :: (HasCallStack) => App ()
testUpdateRejectsWhenFingerprintNotListed :: HasCallStack => App ()
testUpdateRejectsWhenFingerprintNotListed = do
  SAMLTest.SampleIdP meta1 _ _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  SAMLTest.SampleIdP meta2 _ _ _ <- SAMLTest.makeSampleIdPMetadata
  let fpr1 = IdPMetadata -> String
firstCertFingerprint IdPMetadata
meta1
      fpr2 = IdPMetadata -> String
firstCertFingerprint IdPMetadata
meta2
  fpr1 `shouldNotMatch` fpr2
  withModifiedBackend
    def {sparCfg = withAllowlist [fpr1]}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      idpId <-
        createIdpWithZHostV2 owner Nothing meta1 `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      updateIdp owner idpId meta2 >>= assertLabel 403 "idp-cert-not-allowed"

-- | SAML finalize-login succeeds when the IdP cert is on the allowlist.
-- The negative case (cert removed from allowlist after IdP creation) is
-- covered by unit tests in Test.Spar.Saml.IdPSpec: dynamic backends use
-- isolated Cassandra keyspaces so the two configs cannot share IdP state.
testFinalizeLoginSucceedsWhenCertAllowlisted :: (HasCallStack) => App ()
testFinalizeLoginSucceedsWhenCertAllowlisted :: HasCallStack => App ()
testFinalizeLoginSucceedsWhenCertAllowlisted = do
  SAMLTest.SampleIdP idpmeta privCreds _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  let fpr = IdPMetadata -> String
firstCertFingerprint IdPMetadata
idpmeta
  withModifiedBackend
    def {sparCfg = withAllowlist [fpr]}
    $ \String
domain -> do
      (owner, tid, _) <- String -> Int -> App (Value, String, [Value])
forall domain.
(HasCallStack, MakesValue domain) =>
domain -> Int -> App (Value, String, [Value])
createTeam String
domain Int
1
      void $ setTeamFeatureStatus owner tid "sso" "enabled"
      idpId <-
        createIdpWithZHostV2 owner Nothing idpmeta `bindResponse` \Response
resp -> do
          Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
201
          Response
resp.json Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"id" App Value -> (Value -> App String) -> App String
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString
      subject <- nextSubject
      (mUid, _) <- loginWithSamlWithZHost Nothing domain True tid subject (idpId, (idpmeta, privCreds))
      void $ assertJust "expected user id in SAML login response" mUid

-- | 20 zero bytes — valid hex, no real cert matches.
bogusFingerprint :: String
bogusFingerprint :: String
bogusFingerprint = String
"0000000000000000000000000000000000000000"

-- | First cert in the descriptor's @AuthnResponse@ cert list.
firstCert :: SAMLTypes.IdPMetadata -> SignedCertificate
firstCert :: IdPMetadata -> SignedCertificate
firstCert IdPMetadata
meta = NonEmpty SignedCertificate -> SignedCertificate
forall a. NonEmpty a -> a
NE.head (NonEmpty SignedCertificate -> SignedCertificate)
-> NonEmpty SignedCertificate -> SignedCertificate
forall a b. (a -> b) -> a -> b
$ IdPMetadata
meta IdPMetadata
-> Getting
     (NonEmpty SignedCertificate)
     IdPMetadata
     (NonEmpty SignedCertificate)
-> NonEmpty SignedCertificate
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty SignedCertificate)
  IdPMetadata
  (NonEmpty SignedCertificate)
Lens' IdPMetadata (NonEmpty SignedCertificate)
SAMLTypes.edCertAuthnResponse

-- | First cert's SHA-1, canonical @AA:BB:..@ form.
firstCertFingerprint :: SAMLTypes.IdPMetadata -> String
firstCertFingerprint :: IdPMetadata -> String
firstCertFingerprint = SignedCertificate -> String
fingerprintHex (SignedCertificate -> String)
-> (IdPMetadata -> SignedCertificate) -> IdPMetadata -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdPMetadata -> SignedCertificate
firstCert

-- | Sample IdP metadata with @n@ distinct certs in its @AuthnResponse@ cert
-- list (@n >= 1@). Returns the metadata and the certs (in the same order as
-- they appear in the metadata).
makeIdPMetaWithCerts :: (HasCallStack) => Int -> App (SAMLTypes.IdPMetadata, NonEmpty SignedCertificate)
makeIdPMetaWithCerts :: HasCallStack =>
Int -> App (IdPMetadata, NonEmpty SignedCertificate)
makeIdPMetaWithCerts Int
n = do
  SAMLTest.SampleIdP meta _ _ _ <- App SampleIdP
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadRandom m) =>
m SampleIdP
SAMLTest.makeSampleIdPMetadata
  extra <- liftIO $ replicateM (n - 1) genCert
  let certs = NonEmpty SignedCertificate -> SignedCertificate
forall a. NonEmpty a -> a
NE.head (IdPMetadata
meta IdPMetadata
-> Getting
     (NonEmpty SignedCertificate)
     IdPMetadata
     (NonEmpty SignedCertificate)
-> NonEmpty SignedCertificate
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty SignedCertificate)
  IdPMetadata
  (NonEmpty SignedCertificate)
Lens' IdPMetadata (NonEmpty SignedCertificate)
SAMLTypes.edCertAuthnResponse) SignedCertificate
-> [SignedCertificate] -> NonEmpty SignedCertificate
forall a. a -> [a] -> NonEmpty a
:| [SignedCertificate]
extra
  pure (meta & SAMLTypes.edCertAuthnResponse .~ certs, certs)
  where
    genCert :: IO SignedCertificate
genCert = (\(SignPrivCreds
_, SignCreds
_, SignedCertificate
c) -> SignedCertificate
c) ((SignPrivCreds, SignCreds, SignedCertificate)
 -> SignedCertificate)
-> IO (SignPrivCreds, SignCreds, SignedCertificate)
-> IO SignedCertificate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DateTime
-> Int -> IO (SignPrivCreds, SignCreds, SignedCertificate)
forall (m :: * -> *).
(MonadRandom m, MonadIO m) =>
Maybe DateTime
-> Int -> m (SignPrivCreds, SignCreds, SignedCertificate)
XMLDSig.mkSignCredsWithCert Maybe DateTime
forall a. Maybe a
Nothing Int
96

-- | Patch sparCfg to set the allowlist to the given hex strings.
withAllowlist :: [String] -> Value -> App Value
withAllowlist :: [String] -> Value -> App Value
withAllowlist [String]
xs = String -> Value -> Value -> App Value
forall a b.
(HasCallStack, MakesValue a, ToJSON b) =>
String -> b -> a -> App Value
setField String
"idpCertFingerprintAllowlist" ([String] -> Value
forall a. ToJSON a => a -> Value
toJSON [String]
xs)