IdP change notification emails

changelog.d/2-features/send-email-on-idp-change

@@ -0,0 +1,3 @@
+Send an email to team admins and owners when an IdP is changed via API (create,
+update, delete). This behaviour is for now only enabled for multi-ingress
+setups.

libs/extended/src/Data/X509/Extended.hs

@@ -1,4 +1,6 @@
-module Data.X509.Extended (certToString) where
+{-# LANGUAGE RecordWildCards #-}
+
+module Data.X509.Extended (certToString, certDescription, CertDescription (..)) where
 
 import Crypto.Hash
 import Data.ASN1.OID
@@ -12,21 +14,36 @@ import Imports
 
 certToString :: SignedCertificate -> String
 certToString signedCert =
+  let desc = certDescription signedCert
+   in -- Split into pairs and join with ':'
+      mconcat . intersperse "; " $
+        [ "Issuer: " <> desc.issuer,
+          "Subject: " <> desc.subject,
+          desc.fingerprintAlgorithm <> " Fingerprint: " <> desc.fingerprint
+        ]
+
+data CertDescription = CertDescription
+  { fingerprintAlgorithm :: String,
+    fingerprint :: String,
+    subject :: String,
+    issuer :: String
+  }
+  deriving (Eq, Show)
+
+-- | Extract structured certificate description information
+certDescription :: SignedCertificate -> CertDescription
+certDescription signedCert =
   let cert = getCertificate signedCert
       issuer = dnToString $ certIssuerDN cert
       subject = dnToString $ certSubjectDN cert
       der = encodeSignedObject signedCert
-      fingerprint :: ByteString = BAE.convertToBase BAE.Base16 (hash der :: Digest SHA1)
-      -- Split into pairs and join with ':'
-      fingerprintStr =
-        let hex = (T.decodeUtf8 fingerprint)
+      fingerprintBS :: ByteString = BAE.convertToBase BAE.Base16 (hash der :: Digest SHA1)
+      fingerprint =
+        let hex = (T.decodeUtf8 fingerprintBS)
             pairs = T.unpack <$> T.chunksOf 2 hex
          in map toUpper (intercalate ":" pairs)
-   in mconcat . intersperse "; " $
-        [ "Issuer: " <> issuer,
-          "Subject: " <> subject,
-          "SHA1 Fingerprint: " <> fingerprintStr
-        ]
+      fingerprintAlgorithm = "SHA1"
+   in CertDescription {..}
 
 dnToString :: DistinguishedName -> String
 dnToString (getDistinguishedElements -> es) =

libs/extended/test/Test/Data/X509/ExtendedSpec.hs

@@ -22,15 +22,47 @@ spec =
             expected = "Issuer: CN=accounts.accesscontrol.windows.net; Subject: CN=accounts.accesscontrol.windows.net; SHA1 Fingerprint: 15:28:A6:B8:5A:C5:36:80:B4:B0:95:C6:9A:FD:77:9C:D6:5C:78:37"
         checkDecodingWithPEMFile pemFilePath expected
 
+    describe "certDescription" $ do
+      it "should extract certificate description from stars' Keycloak certificate" $ do
+        let pemFilePath = "test/data/" <> "sven-test.pem"
+            expected =
+              CertDescription
+                { fingerprintAlgorithm = "SHA1",
+                  fingerprint = "F4:A2:73:D7:B7:2E:EA:66:E1:CB:81:E9:58:BC:1A:E9:CF:3C:95:C4",
+                  subject = "CN=sven-test",
+                  issuer = "CN=sven-test"
+                }
+        checkCertDescriptionWithPEMFile pemFilePath expected
+
+      it "should extract certificate description from unit test data (saml2-web-sso)" $ do
+        let pemFilePath = "test/data/" <> "test-cert.pem"
+            expected =
+              CertDescription
+                { fingerprintAlgorithm = "SHA1",
+                  fingerprint = "15:28:A6:B8:5A:C5:36:80:B4:B0:95:C6:9A:FD:77:9C:D6:5C:78:37",
+                  subject = "CN=accounts.accesscontrol.windows.net",
+                  issuer = "CN=accounts.accesscontrol.windows.net"
+                }
+        checkCertDescriptionWithPEMFile pemFilePath expected
+
 checkDecodingWithPEMFile :: FilePath -> String -> IO ()
 checkDecodingWithPEMFile pemFilePath expected = do
+  cert <- loadSignedCertificate pemFilePath
+  certToString cert `shouldBe` expected
+
+checkCertDescriptionWithPEMFile :: FilePath -> CertDescription -> IO ()
+checkCertDescriptionWithPEMFile pemFilePath expected = do
+  cert <- loadSignedCertificate pemFilePath
+  certDescription cert `shouldBe` expected
+
+-- | Load and decode a SignedCertificate from a PEM file
+loadSignedCertificate :: FilePath -> IO SignedCertificate
+loadSignedCertificate pemFilePath = do
   -- sanity check if the file even exists
   exists <- doesFileExist pemFilePath
   exists `shouldBe` True
 
   file <- BS.readFile pemFilePath
-  let decoded :: SignedCertificate = either error id $ do
-        pemBS <- pemContent . fromMaybe (error "Empty PEM list") . listToMaybe <$> pemParseBS file
-        decodeSignedCertificate pemBS
-
-  certToString decoded `shouldBe` expected
+  pure . either error id $ do
+    pemBS <- pemContent . fromMaybe (error "Empty PEM list") . listToMaybe <$> pemParseBS file
+    decodeSignedCertificate pemBS

libs/saml2-web-sso/default.nix

@@ -48,6 +48,7 @@
 , memory
 , mtl
 , network-uri
+, openapi3
 , pretty-show
 , process
 , QuickCheck
@@ -127,6 +128,7 @@ mkDerivation {
     memory
     mtl
     network-uri
+    openapi3
     pretty-show
     process
     QuickCheck

libs/saml2-web-sso/saml2-web-sso.cabal

@@ -121,6 +121,7 @@ library
     , memory                >=0.14.18
     , mtl                   >=2.2.2
     , network-uri           >=2.6.1.0
+    , openapi3
     , pretty-show           >=1.9.5
     , process               >=1.6.5.0
     , QuickCheck            >=2.13.2

libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs

@@ -24,6 +24,7 @@ import Control.Lens hiding (Level, element, enum, (.=))
 import Control.Monad (when)
 import Data.Aeson qualified as A
 import Data.Domain
+import Data.Either
 import Data.Map
 import Data.Map qualified as Map
 import Data.Schema
@@ -68,6 +69,9 @@ data MultiIngressDomainConfig = MultiIngressDomainConfig
   deriving (Eq, Show, Generic)
   deriving (A.ToJSON, A.FromJSON) via Schema MultiIngressDomainConfig
 
+isMultiIngressConfig :: Config -> Bool
+isMultiIngressConfig = isRight . _cfgDomainConfigs
+
 ----------------------------------------------------------------------
 -- schema-profunctor
 

libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs

@@ -11,10 +11,10 @@ import Data.Aeson
 import Data.ByteString
 import Data.ByteString.Builder
 import Data.Schema as Schema
-import Data.String.Conversions
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Text.Lazy qualified as TL
 import Data.X509 as X509
 import Data.Yaml.Aeson qualified as A
 import SAML2.Util (normURI, parseURI', renderURI)
@@ -37,11 +37,18 @@ instance ToHttpApiData URI where
 instance FromHttpApiData URI where
   parseUrlPiece = either (Left . Text.pack) pure . parseURI' <=< parseUrlPiece
 
-instance FromJSON X509.SignedCertificate where
-  parseJSON = withText "KeyInfo element" $ either fail pure . parseKeyInfo False . cs
+instance Schema.ToSchema SignedCertificate where
+  schema = serialize Schema..= Schema.parsedText "SignedCertificate" parse
+    where
+      parse :: Text.Text -> Either String SignedCertificate
+      parse = parseKeyInfo False . TL.fromStrict
+
+      serialize :: SignedCertificate -> Text.Text
+      serialize = TL.toStrict . renderKeyInfo
+
+deriving via (Schema.Schema SignedCertificate) instance FromJSON SignedCertificate
 
-instance ToJSON X509.SignedCertificate where
-  toJSON = String . cs . renderKeyInfo
+deriving via (Schema.Schema SignedCertificate) instance ToJSON SignedCertificate
 
 -- This can unfortunately not live in wire-api, because wire-api depends on
 -- saml2-web-sso.
@@ -69,3 +76,14 @@ instance ToSchema Level where
 deriving instance Enum Level
 
 deriving instance Bounded Level
+
+-- | Used in tests to have no @extra@ in @IdPConfig extra@
+instance Schema.ToSchema () where
+  schema = Schema.named "unit" $ Schema.null_
+
+-- | Used in tests to have JSON as @extra@ in @IdPConfig extra@
+instance Schema.ToSchema A.Value where
+  schema =
+    Schema.named (Text.pack "Value") $
+      id
+        Schema..= Schema.jsonValue

libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs

@@ -161,7 +161,6 @@ module SAML2.WebSSO.Types
 where
 
 import Control.Lens
-import Control.Monad ((<=<))
 import Control.Monad.Except
 import Data.Aeson
 import Data.Aeson.TH
@@ -171,6 +170,7 @@ import Data.List qualified as L
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List.NonEmpty qualified as NL
 import Data.Maybe
+import Data.OpenApi qualified as S
 import Data.Schema qualified as Schema
 import Data.String.Conversions (ST, cs)
 import Data.Text (Text)
@@ -230,14 +230,15 @@ data UserRef = UserRef {_uidTenant :: Issuer, _uidSubject :: NameID}
 -- | More correctly, an 'Issuer' is a 'NameID', but we only support 'URI'.
 newtype Issuer = Issuer {_fromIssuer :: URI}
   deriving (Eq, Ord, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema.Schema Issuer
 
-instance FromJSON Issuer where
-  parseJSON = withText "Issuer" $ \uri -> case parseURI' uri of
-    Right i -> pure $ Issuer i
-    Left msg -> fail $ "Issuer: " <> show msg
-
-instance ToJSON Issuer where
-  toJSON = toJSON . renderURI . _fromIssuer
+instance Schema.ToSchema Issuer where
+  schema =
+    Issuer
+      <$> _fromIssuer Schema..= uriSchema
+    where
+      uriSchema :: Schema.ValueSchema Schema.NamedSwaggerDoc URI
+      uriSchema = renderURI Schema..= Schema.parsedText "URI" parseURI'
 
 ----------------------------------------------------------------------
 -- meta [4/2.3.2]
@@ -307,11 +308,33 @@ data IdPMetadata = IdPMetadata
     _edCertAuthnResponse :: NonEmpty X509.SignedCertificate
   }
   deriving (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema.Schema IdPMetadata)
+
+instance Schema.ToSchema IdPMetadata where
+  schema =
+    Schema.object "IdPMetadata" $
+      IdPMetadata
+        <$> (_edIssuer Schema..= Schema.field "issuer" Schema.schema)
+        <*> (_edRequestURI Schema..= Schema.field "requestURI" Schema.schema)
+        <*> (_edCertAuthnResponse Schema..= Schema.field "certAuthnResponse" (Schema.nonEmptyArray Schema.schema))
 
 ----------------------------------------------------------------------
 -- idp info
 
-newtype IdPId = IdPId {fromIdPId :: UUID} deriving (Eq, Show, Generic, Ord)
+newtype IdPId = IdPId {fromIdPId :: UUID}
+  deriving (Eq, Show, Generic, Ord)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema.Schema IdPId
+
+instance Schema.ToSchema IdPId where
+  schema =
+    IdPId
+      <$> fromIdPId Schema..= idpIdSchema
+    where
+      idpIdSchema :: Schema.ValueSchema Schema.NamedSwaggerDoc UUID
+      idpIdSchema = UUID.toText Schema..= Schema.parsedText "URI" parseUUID
+
+      parseUUID :: Text -> Either String UUID
+      parseUUID = maybe (Left "Cannot parse UUID") Right . UUID.fromText
 
 type IdPConfig_ = IdPConfig ()
 
@@ -321,6 +344,15 @@ data IdPConfig extra = IdPConfig
     _idpExtraInfo :: extra
   }
   deriving (Eq, Show, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema.Schema (IdPConfig extra))
+
+instance (Schema.ToSchema extra) => Schema.ToSchema (IdPConfig extra) where
+  schema =
+    Schema.object "IdPConfig" $
+      IdPConfig
+        <$> (_idpId Schema..= Schema.field "id" Schema.schema)
+        <*> (_idpMetadata Schema..= Schema.field "metadata" Schema.schema)
+        <*> (_idpExtraInfo Schema..= Schema.field "extraInfo" Schema.schema)
 
 ----------------------------------------------------------------------
 -- request, response
@@ -721,18 +753,6 @@ makePrisms ''Statement
 
 makePrisms ''UnqualifiedNameID
 
-deriveJSON deriveJSONOptions ''IdPMetadata
-
-deriveJSON deriveJSONOptions ''IdPConfig
-
-instance FromJSON IdPId where
-  parseJSON value = ((maybe unerror (pure . IdPId) . UUID.fromText) <=< parseJSON) value
-    where
-      unerror = fail ("could not parse config: " <> (show value))
-
-instance ToJSON IdPId where
-  toJSON = toJSON . UUID.toText . fromIdPId
-
 idPIdToST :: IdPId -> ST
 idPIdToST = UUID.toText . fromIdPId
 

libs/saml2-web-sso/test/Test/SAML2/WebSSO/RoundtripSpec.hs

@@ -32,6 +32,7 @@ import Hedgehog
 import Hedgehog.Gen as Gen
 import SAML2.Core qualified as HS
 import SAML2.WebSSO
+import SAML2.WebSSO.Orphans ()
 import SAML2.WebSSO.Test.Arbitrary
 import SAML2.WebSSO.Test.Util
 import Servant