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 qualified Data.Text as T
import Data.X509 (SignedCertificate)
import qualified Data.X509.Extended as X509E
import qualified SAML2.WebSSO.Test.Util as SAMLTest
import qualified SAML2.WebSSO.Types as SAMLTypes
import SetupHelpers
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

-- | Cert's SHA-1 fingerprint in canonical @AA:BB:..@ hex form.
fingerprintHex :: SignedCertificate -> String
fingerprintHex :: SignedCertificate -> String
fingerprintHex = Text -> String
T.unpack (Text -> String)
-> (SignedCertificate -> Text) -> SignedCertificate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fingerprint -> Text
X509E.renderFingerprintHex (Fingerprint -> Text)
-> (SignedCertificate -> Fingerprint) -> SignedCertificate -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Fingerprint
X509E.certSha1Fingerprint

-- | 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)