Log IdP changes and notify via email

libs/extended/default.nix

@@ -5,11 +5,15 @@
 { mkDerivation
 , aeson
 , amqp
+, asn1-types
 , base
 , bytestring
 , cassandra-util
 , containers
+, crypton
 , crypton-connection
+, crypton-pem
+, crypton-x509
 , crypton-x509-store
 , data-default
 , errors
@@ -24,6 +28,7 @@
 , http-types
 , imports
 , lib
+, memory
 , metrics-wai
 , monad-control
 , prometheus-client
@@ -52,11 +57,14 @@ mkDerivation {
   libraryHaskellDepends = [
     aeson
     amqp
+    asn1-types
     base
     bytestring
     cassandra-util
     containers
+    crypton
     crypton-connection
+    crypton-x509
     crypton-x509-store
     data-default
     errors
@@ -67,6 +75,7 @@ mkDerivation {
     http-client-tls
     http-types
     imports
+    memory
     metrics-wai
     monad-control
     prometheus-client
@@ -89,6 +98,9 @@ mkDerivation {
   testHaskellDepends = [
     aeson
     base
+    bytestring
+    crypton-pem
+    crypton-x509
     hspec
     imports
     string-conversions

libs/extended/extended.cabal

@@ -20,6 +20,7 @@ library
   -- cabal-fmt: expand src
   exposed-modules:
     Data.Time.Clock.DiffTime
+    Data.X509.Extended
     Hasql.Pool.Extended
     Network.AMQP.Extended
     Network.RabbitMqAdmin
@@ -80,11 +81,14 @@ library
   build-depends:
       aeson
     , amqp
+    , asn1-types
     , base
     , bytestring
     , cassandra-util
     , containers
+    , crypton
     , crypton-connection
+    , crypton-x509
     , crypton-x509-store
     , data-default
     , errors
@@ -95,6 +99,7 @@ library
     , http-client-tls
     , http-types
     , imports
+    , memory
     , metrics-wai
     , monad-control
     , prometheus-client
@@ -121,6 +126,7 @@ test-suite extended-tests
   main-is:            Spec.hs
   other-modules:
     Paths_extended
+    Test.Data.X509.ExtendedSpec
     Test.System.Logger.ExtendedSpec
 
   hs-source-dirs:     test
@@ -176,6 +182,9 @@ test-suite extended-tests
   build-depends:
       aeson
     , base
+    , bytestring
+    , crypton-pem
+    , crypton-x509
     , extended
     , hspec
     , imports

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

@@ -0,0 +1,53 @@
+module Data.X509.Extended (certToString) where
+
+import Crypto.Hash
+import Data.ASN1.OID
+import Data.ASN1.Types
+import Data.ByteArray.Encoding qualified as BAE
+import Data.Map qualified as Map
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.X509
+import Imports
+
+certToString :: SignedCertificate -> String
+certToString 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 SHA256)
+      -- Split into pairs and join with ':'
+      fingerprintStr =
+        let hex = (T.decodeUtf8 fingerprint)
+            pairs = T.unpack <$> T.chunksOf 2 hex
+         in map toUpper (intercalate ":" pairs)
+   in mconcat . intersperse "; " $
+        [ "Issuer: " <> issuer,
+          "Subject: " <> subject,
+          "SHA256 Fingerprint: " <> fingerprintStr
+        ]
+
+dnToString :: DistinguishedName -> String
+dnToString (getDistinguishedElements -> es) =
+  let a :: [String] = mapMaybe distinguishedElementString es
+   in mconcat $ intersperse "," a
+  where
+    distinguishedElementString :: (OID, ASN1CharacterString) -> Maybe String
+    distinguishedElementString (oid, aSN1CharacterString) = do
+      (_element, desc) <- Map.lookup oid dnElementMap
+      val <- asn1CharacterToString aSN1CharacterString
+      pure $ desc <> "=" <> val
+
+    dnElementMap :: Map OID (DnElement, String)
+    dnElementMap =
+      Map.fromList
+        [ (mkEntry DnCommonName "CN"),
+          (mkEntry DnCountry "Country"),
+          (mkEntry DnOrganization "O"),
+          (mkEntry DnOrganizationUnit "OU"),
+          (mkEntry DnEmailAddress "Email Address")
+        ]
+      where
+        mkEntry :: DnElement -> String -> (OID, (DnElement, String))
+        mkEntry e s = (getObjectID e, (e, s))

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

@@ -0,0 +1,36 @@
+module Test.Data.X509.ExtendedSpec where
+
+import Data.ByteString qualified as BS
+import Data.PEM
+import Data.String.Conversions
+import Data.X509
+import Data.X509.Extended
+import Imports
+import Test.Hspec
+
+spec :: Spec
+spec =
+  describe "Data.X509.Extended" $ do
+    describe "certToString" $ do
+      it "should render a representing string of a certificate from stars' Keyloak" $ do
+        let pemFilePath = "test/data/" <> "sven-test.pem"
+            expected = "Issuer: CN=sven-test; Subject: CN=sven-test; SHA256 Fingerprint: 84:73:C5:D1:5A:36:7B:E7:00:3F:C5:1B:F6:84:90:5B:21:77:DA:22:FC:3D:8B:94:A2:97:0D:C1:8F:26:F7:6B"
+        checkDecodingWithPEMFile pemFilePath expected
+
+      it "should render a representing string of a certificate from unit test data (saml2-web-sso)" $ do
+        let pemFilePath = "test/data/" <> "test-cert.pem"
+            expected = "Issuer: CN=accounts.accesscontrol.windows.net; Subject: CN=accounts.accesscontrol.windows.net; SHA256 Fingerprint: A5:0B:76:1A:A3:11:8E:78:CF:2C:75:95:6B:6A:59:D1:85:4E:EA:DE:20:7C:C4:AF:48:B7:7F:A7:90:48:33:DB"
+        checkDecodingWithPEMFile pemFilePath expected
+
+checkDecodingWithPEMFile :: FilePath -> String -> IO ()
+checkDecodingWithPEMFile pemFilePath expected = 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

libs/extended/test/data/sven-test.pem

@@ -0,0 +1,3 @@
+-----BEGIN CERTIFICATE-----
+MIICoTCCAYkCBgGaxY9gbjANBgkqhkiG9w0BAQsFADAUMRIwEAYDVQQDDAlzdmVuLXRlc3QwHhcNMjUxMTI3MTM0MzE5WhcNMzUxMTI3MTM0NDU5WjAUMRIwEAYDVQQDDAlzdmVuLXRlc3QwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCVkM30EqGkdEIjF6ZDzS7mEMtsHmEXXT6bzkrOddzz8fKmle2tb6Rn7uI/pkfbTdMXKlaPQohDSed5907xn3v8TAHc/FA9lf3Mo+o7pl/aQlEHm9RedNnm1DRiuH/zZx60e6ctVFqYu4sTwJxGnM81ojrrQRXU+u4FEnAh0p1aUvXG+3iCz0NHRErYxzYLvnLSziQg70yO1qlxy/K+M04gNKe7ZGxeZbu56ysllWUhrysvGg4/rp3iu4OTb8N5U+iH0ZSDcrUUeOJP2sSNRVYr4cgkcLDI+npr8WmqfqWgc+yRQ9iPAuNYi+nE9aB4ZXf7SyAGs5gmJtT6Cm4hoUa5AgMBAAEwDQYJKoZIhvcNAQELBQADggEBAGfKx/PeiFgLStaPlN+9n7+hW/iy50qhLDtEPuXA3m1XnBLO8sB7ebyJVL1QvO33A3MQdJi1E8R1uQd7ompuQ0+62vAe/bX/EZEzbwMHyM26F+r18BJKf3Dla6ot1CKnVIJuocc9qbuhkeTaeCkFF1HyvnlN/i/oMa+KwK0OP6GRkFG/m53biq9p+jbdKK2/fVvDklt5Vma6sp6KG1HhFJQMaeL/hGGelzS84qL7H9+eSBu5krCZBLfx4L88poDiY3JudM0tS6Kzj8IFDNspXRxHy8sacWn/8ulMVXGEQhw3+u5jN/yCxkxogFg7bE9uR5JhbkZ4J7X6J9uEaU/Sobo=
+-----END CERTIFICATE-----

libs/extended/test/data/test-cert.pem

@@ -0,0 +1,4 @@
+-----BEGIN CERTIFICATE-----
+MIIDBTCCAe2gAwIBAgIQev76BWqjWZxChmKkGqoAfDANBgkqhkiG9w0BAQsFADAtMSswKQYDVQQDEyJhY2NvdW50cy5hY2Nlc3Njb250cm9sLndpbmRvd3MubmV0MB4XDTE4MDIxODAwMDAwMFoXDTIwMDIxOTAwMDAwMFowLTErMCkGA1UEAxMiYWNjb3VudHMuYWNjZXNzY29udHJvbC53aW5kb3dzLm5ldDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMgmGiRfLh6Fdi99XI2VA3XKHStWNRLEy5Aw/gxFxchnh2kPdk/bejFOs2swcx7yUWqxujjCNRsLBcWfaKUlTnrkY7i9x9noZlMrijgJy/Lk+HH5HX24PQCDf+twjnHHxZ9G6/8VLM2e5ZBeZm+t7M3vhuumEHG3UwloLF6cUeuPdW+exnOB1U1fHBIFOG8ns4SSIoq6zw5rdt0CSI6+l7b1DEjVvPLtJF+zyjlJ1Qp7NgBvAwdiPiRMU4l8IRVbuSVKoKYJoyJ4L3eXsjczoBSTJ6VjV2mygz96DC70MY3avccFrk7tCEC6ZlMRBfY1XPLyldT7tsR3EuzjecSa1M8CAwEAAaMhMB8wHQYDVR0OBBYEFIks1srixjpSLXeiR8zES5cTY6fBMA0GCSqGSIb3DQEBCwUAA4IBAQCKthfK4C31DMuDyQZVS3F7+4Evld3hjiwqu2uGDK+qFZas/D/eDunxsFpiwqC01RIMFFN8yvmMjHphLHiBHWxcBTS+tm7AhmAvWMdxO5lzJLS+UWAyPF5ICROe8Mu9iNJiO5JlCo0Wpui9RbB1C81Xhax1gWHK245ESL6k7YWvyMYWrGqr1NuQcNS0B/AIT1Nsj1WY7efMJQOmnMHkPUTWryVZlthijYyd7P2Gz6rY5a81DAFqhDNJl2pGIAE6HWtSzeUEh3jCsHEkoglKfm4VrGJEuXcALmfCMbdfTvtu4rlsaP2hQad+MG/KJFlenoTK34EMHeBPDCpqNDz8UVNk
+-----END CERTIFICATE-----
+

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