From 1d49f227c6ed98683abc81c39f1b4391a7f4de64 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 6 Jan 2026 17:19:42 +0100 Subject: [PATCH 1/9] Log SAML IdP changes Log all changes to SAML IdPs that are triggered via the IdP REST API in Spar. --- libs/extended/default.nix | 12 +++++ libs/extended/extended.cabal | 9 ++++ libs/extended/src/Data/X509/Extended.hs | 53 +++++++++++++++++++ .../test/Test/Data/X509/ExtendedSpec.hs | 36 +++++++++++++ libs/extended/test/data/sven-test.pem | 3 ++ libs/extended/test/data/test-cert.pem | 4 ++ services/spar/src/Spar/API.hs | 51 ++++++++++++++++-- 7 files changed, 165 insertions(+), 3 deletions(-) create mode 100644 libs/extended/src/Data/X509/Extended.hs create mode 100644 libs/extended/test/Test/Data/X509/ExtendedSpec.hs create mode 100644 libs/extended/test/data/sven-test.pem create mode 100644 libs/extended/test/data/test-cert.pem diff --git a/libs/extended/default.nix b/libs/extended/default.nix index 4090a02a77..3ec398e8d1 100644 --- a/libs/extended/default.nix +++ b/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 diff --git a/libs/extended/extended.cabal b/libs/extended/extended.cabal index 3828324caa..980338c38a 100644 --- a/libs/extended/extended.cabal +++ b/libs/extended/extended.cabal @@ -28,6 +28,7 @@ library -- cabal-fmt: expand src exposed-modules: Data.Time.Clock.DiffTime + Data.X509.Extended Hasql.Pool.Extended Network.AMQP.Extended Network.RabbitMqAdmin @@ -88,11 +89,14 @@ library build-depends: aeson , amqp + , asn1-types , base , bytestring , cassandra-util , containers + , crypton , crypton-connection + , crypton-x509 , crypton-x509-store , data-default , errors @@ -103,6 +107,7 @@ library , http-client-tls , http-types , imports + , memory , metrics-wai , monad-control , prometheus-client @@ -129,6 +134,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 @@ -186,6 +192,9 @@ test-suite extended-tests build-depends: aeson , base + , bytestring + , crypton-pem + , crypton-x509 , extended , hspec , imports diff --git a/libs/extended/src/Data/X509/Extended.hs b/libs/extended/src/Data/X509/Extended.hs new file mode 100644 index 0000000000..31f5738dc1 --- /dev/null +++ b/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 dess :: [String] = mapMaybe distinguishedElementString es + in mconcat $ intersperse "," dess + 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)) diff --git a/libs/extended/test/Test/Data/X509/ExtendedSpec.hs b/libs/extended/test/Test/Data/X509/ExtendedSpec.hs new file mode 100644 index 0000000000..46a0914c83 --- /dev/null +++ b/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 representative 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 representative 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 diff --git a/libs/extended/test/data/sven-test.pem b/libs/extended/test/data/sven-test.pem new file mode 100644 index 0000000000..cabff31960 --- /dev/null +++ b/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----- diff --git a/libs/extended/test/data/test-cert.pem b/libs/extended/test/data/test-cert.pem new file mode 100644 index 0000000000..ff32fa8028 --- /dev/null +++ b/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----- + diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index f5f9de0d1e..81a55666b8 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -62,6 +62,8 @@ import Data.Text.Encoding.Error import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding import Data.Time +import qualified Data.UUID as UUID +import Data.X509.Extended import Imports import Network.Wai (Request, requestHeaders) import Network.Wai.Utilities.Request @@ -107,6 +109,7 @@ import qualified Spar.Sem.ScimUserTimesStore as ScimUserTimesStore import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore import System.Logger (Msg) +import qualified System.Logger as Log import qualified URI.ByteString as URI import Wire.API.Routes.Internal.Spar import Wire.API.Routes.Named @@ -213,6 +216,7 @@ apiSSO opts = apiIDP :: ( Member Random r, Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member ScimTokenStore r, @@ -543,6 +547,7 @@ idpDelete :: forall r. ( Member Random r, Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member ScimTokenStore r, @@ -573,6 +578,7 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co do IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid + logIdPAction "IdP deleted" idp Nothing pure NoContent where assertEmptyOrPurge :: TeamId -> Cas.Page (SAML.UserRef, UserId) -> Sem r () @@ -626,6 +632,7 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co -- (internal) https://wearezeta.atlassian.net/wiki/spaces/PAD/pages/1107001440/2024-03-27+scim+user+provisioning+and+saml2+sso+associating+scim+peers+and+saml2+idps idpCreate :: ( Member Random r, + Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member GalleyAccess r, Member BrigAccess r, @@ -653,6 +660,7 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet IdPConfigStore.insertConfig idp forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) + logIdPAction "IdP created" idp mReplaces pure idp where -- Ensure that the domain is not in use by an existing IDP @@ -670,6 +678,17 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet when (zHost `elem` domains) $ throwSparSem SparIdPDomainInUse +logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> Maybe SAML.IdPId -> Sem r () +logIdPAction msg idp mReplaces = + Logger.info $ + Log.msg (msg) + . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText) + . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) + . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') + . Log.field "replaces" (maybe "None" (UUID.toString . SAML.fromIdPId) mReplaces) + . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) + . Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList)) + -- | Only return a ZHost when multi-ingress is configured and the host value is a configured domain filterMultiIngressZHost :: Either SAML.MultiIngressDomainConfig (Map Domain SAML.MultiIngressDomainConfig) -> Maybe ZHostValue -> Maybe ZHostValue filterMultiIngressZHost (Right domainMap) (Just zHost) | (Domain zHost) `Map.member` domainMap = Just zHost @@ -678,6 +697,7 @@ filterMultiIngressZHost _ _ = Nothing idpCreateV7 :: ( Member Random r, Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member ScimTokenStore r, @@ -780,6 +800,7 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idpDomain idHandle = wit -- 'IdPMetadataInfo' directly where convenient. idpUpdate :: ( Member Random r, + Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member GalleyAccess r, Member BrigAccess r, @@ -800,6 +821,7 @@ idpUpdate samlConfig zusr uncheckedMbHost (IdPMetadataValue raw xml) = idpUpdateXML :: ( Member Random r, + Member (Logger (Msg -> Msg)) r, Member (Logger String) r, Member GalleyAccess r, Member BrigAccess r, @@ -815,7 +837,7 @@ idpUpdateXML :: Maybe (Range 1 32 Text) -> Sem r IdP idpUpdateXML zusr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML" (Just . show . (^. SAML.idpId)) $ do - (teamid, idp) <- validateIdPUpdate zusr idpmeta idpid + (teamid, idp, previousIdP) <- validateIdPUpdate zusr idpmeta idpid GalleyAccess.assertSSOEnabled teamid guardMultiIngressDuplicateDomain teamid mDomain idpid IdPRawMetadataStore.store (idp ^. SAML.idpId) raw @@ -833,6 +855,7 @@ idpUpdateXML zusr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML WireIdPAPIV1 -> Nothing WireIdPAPIV2 -> Just teamid forM_ (idp'' ^. SAML.idpExtraInfo . oldIssuers) (flip IdPConfigStore.deleteIssuer mbteamid) + logIdPUpdate idp'' previousIdP pure idp'' where -- Ensure that the domain is not in use by an existing IDP @@ -854,6 +877,28 @@ idpUpdateXML zusr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML when otherIdpsOnSameDomain $ throwSparSem SparIdPDomainInUse + logIdPUpdate idp previousIdP = + let (removedCerts, newCerts) = + compareNonEmpty + (previousIdP ^. SAML.idpMetadata . SAML.edCertAuthnResponse) + (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse) + in Logger.info $ + Log.msg ("IdP updated" :: String) + . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText) + . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) + . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') + . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) + . Log.field "new-certificates" ((intercalate ";; " . map certToString . toList) removedCerts) + . Log.field "removed-certificates" ((intercalate ";; " . map certToString . toList) newCerts) + + compareNonEmpty :: (Eq a) => NonEmpty a -> NonEmpty a -> ([a], [a]) + compareNonEmpty xs ys = + let l = nub . toList $ xs + r = nub . toList $ ys + onlyL = l \\ r + onlyR = r \\ l + in (onlyL, onlyR) + -- | Check that: idp id is valid; calling user is admin in that idp's home team; team id in -- new metainfo doesn't change; new issuer (if changed) is not in use anywhere else (except as -- an earlier IdP under the same ID); request uri is https. Keep track of old issuer in extra @@ -871,7 +916,7 @@ validateIdPUpdate :: Maybe UserId -> SAML.IdPMetadata -> SAML.IdPId -> - m (TeamId, IdP) + m (TeamId, IdP, IdP) validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (Just . show . (_2 %~ (^. SAML.idpId))) $ do previousIdP <- IdPConfigStore.getConfig _idpId (_, teamId) <- authorizeIdP zusr previousIdP @@ -904,7 +949,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (J let requri = _idpMetadata ^. SAML.edRequestURI enforceHttps requri - pure (teamId, SAML.IdPConfig {..}) + pure (teamId, SAML.IdPConfig {..}, previousIdP) where -- If the new issuer was previously used, it has to be removed from the list of old issuers, -- to prevent it from getting deleted in a later step From 7e998c6155f8dce473bbe905142e775361098436 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 6 Jan 2026 18:23:15 +0100 Subject: [PATCH 2/9] Unify log functions --- services/spar/src/Spar/API.hs | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 81a55666b8..0344e7524c 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -578,7 +578,10 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co do IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid - logIdPAction "IdP deleted" idp Nothing + logIdPAction + "IdP deleted" + idp + (Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList))) pure NoContent where assertEmptyOrPurge :: TeamId -> Cas.Page (SAML.UserRef, UserId) -> Sem r () @@ -660,7 +663,12 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet IdPConfigStore.insertConfig idp forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) - logIdPAction "IdP created" idp mReplaces + logIdPAction + "IdP created" + idp + ( Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList)) + . Log.field "replaces" (maybe "None" (UUID.toString . SAML.fromIdPId) mReplaces) + ) pure idp where -- Ensure that the domain is not in use by an existing IDP @@ -678,16 +686,15 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet when (zHost `elem` domains) $ throwSparSem SparIdPDomainInUse -logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> Maybe SAML.IdPId -> Sem r () -logIdPAction msg idp mReplaces = +logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> (Msg -> Msg) -> Sem r () +logIdPAction msg idp additionalFields = Logger.info $ Log.msg (msg) . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText) . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') - . Log.field "replaces" (maybe "None" (UUID.toString . SAML.fromIdPId) mReplaces) . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) - . Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList)) + . additionalFields -- | Only return a ZHost when multi-ingress is configured and the host value is a configured domain filterMultiIngressZHost :: Either SAML.MultiIngressDomainConfig (Map Domain SAML.MultiIngressDomainConfig) -> Maybe ZHostValue -> Maybe ZHostValue @@ -882,14 +889,12 @@ idpUpdateXML zusr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML compareNonEmpty (previousIdP ^. SAML.idpMetadata . SAML.edCertAuthnResponse) (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse) - in Logger.info $ - Log.msg ("IdP updated" :: String) - . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText) - . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) - . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') - . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) - . Log.field "new-certificates" ((intercalate ";; " . map certToString . toList) removedCerts) - . Log.field "removed-certificates" ((intercalate ";; " . map certToString . toList) newCerts) + in logIdPAction + "IdP updated" + idp + ( Log.field "new-certificates" ((intercalate ";; " . map certToString . toList) removedCerts) + . Log.field "removed-certificates" ((intercalate ";; " . map certToString . toList) newCerts) + ) compareNonEmpty :: (Eq a) => NonEmpty a -> NonEmpty a -> ([a], [a]) compareNonEmpty xs ys = From 30e7ae21bc95d02d84f1d8c4f033113c61341ef2 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 6 Jan 2026 18:31:57 +0100 Subject: [PATCH 3/9] Use shorter SHA1 fingerprint --- libs/extended/src/Data/X509/Extended.hs | 4 ++-- libs/extended/test/Test/Data/X509/ExtendedSpec.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libs/extended/src/Data/X509/Extended.hs b/libs/extended/src/Data/X509/Extended.hs index 31f5738dc1..964c2ee302 100644 --- a/libs/extended/src/Data/X509/Extended.hs +++ b/libs/extended/src/Data/X509/Extended.hs @@ -16,7 +16,7 @@ certToString signedCert = issuer = dnToString $ certIssuerDN cert subject = dnToString $ certSubjectDN cert der = encodeSignedObject signedCert - fingerprint :: ByteString = BAE.convertToBase BAE.Base16 (hash der :: Digest SHA256) + fingerprint :: ByteString = BAE.convertToBase BAE.Base16 (hash der :: Digest SHA1) -- Split into pairs and join with ':' fingerprintStr = let hex = (T.decodeUtf8 fingerprint) @@ -25,7 +25,7 @@ certToString signedCert = in mconcat . intersperse "; " $ [ "Issuer: " <> issuer, "Subject: " <> subject, - "SHA256 Fingerprint: " <> fingerprintStr + "SHA1 Fingerprint: " <> fingerprintStr ] dnToString :: DistinguishedName -> String diff --git a/libs/extended/test/Test/Data/X509/ExtendedSpec.hs b/libs/extended/test/Test/Data/X509/ExtendedSpec.hs index 46a0914c83..a5af755839 100644 --- a/libs/extended/test/Test/Data/X509/ExtendedSpec.hs +++ b/libs/extended/test/Test/Data/X509/ExtendedSpec.hs @@ -14,12 +14,12 @@ spec = describe "certToString" $ do it "should render a representative 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" + expected = "Issuer: CN=sven-test; Subject: CN=sven-test; SHA1 Fingerprint: F4:A2:73:D7:B7:2E:EA:66:E1:CB:81:E9:58:BC:1A:E9:CF:3C:95:C4" checkDecodingWithPEMFile pemFilePath expected it "should render a representative 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" + 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 checkDecodingWithPEMFile :: FilePath -> String -> IO () From 542211d9691ada05f4d0e91131a2fb7a32b4625a Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 6 Jan 2026 19:02:03 +0100 Subject: [PATCH 4/9] Add changelog --- changelog.d/2-features/log-saml-idp-changes | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/2-features/log-saml-idp-changes diff --git a/changelog.d/2-features/log-saml-idp-changes b/changelog.d/2-features/log-saml-idp-changes new file mode 100644 index 0000000000..130a4281a1 --- /dev/null +++ b/changelog.d/2-features/log-saml-idp-changes @@ -0,0 +1 @@ +Log changes to IdP configurations made via the IdP REST API to syslog. From bbe785171a19b7429d589a12799821d07632839b Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Tue, 6 Jan 2026 19:21:18 +0100 Subject: [PATCH 5/9] Log the initiating user as well I.e. "Wo did it?" --- libs/wire-api/src/Wire/API/Routes/Public/Spar.hs | 4 ++-- services/spar/src/Spar/API.hs | 16 +++++++++++----- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs index 642b9dc522..5390149a7c 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Spar.hs @@ -135,8 +135,8 @@ type APIIDP = Named "idp-get" (ZOptUser :> IdpGet) :<|> Named "idp-get-raw" (ZOptUser :> IdpGetRaw) :<|> Named "idp-get-all" (ZOptUser :> IdpGetAll) - :<|> Named "idp-create@v7" (Until 'V8 :> AuthProtect "TeamAdmin" :> IdpCreate) -- (change is semantic, see handler) - :<|> Named "idp-create" (From 'V8 :> AuthProtect "TeamAdmin" :> ZHostOpt :> IdpCreate) + :<|> Named "idp-create@v7" (Until 'V8 :> AuthProtect "TeamAdmin" :> ZOptUser :> IdpCreate) -- (change is semantic, see handler) + :<|> Named "idp-create" (From 'V8 :> AuthProtect "TeamAdmin" :> ZOptUser :> ZHostOpt :> IdpCreate) :<|> Named "idp-update" (ZOptUser :> ZHostOpt :> IdpUpdate) :<|> Named "idp-delete" (ZOptUser :> IdpDelete) diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 0344e7524c..dc9f9f3316 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -581,6 +581,7 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co logIdPAction "IdP deleted" idp + mbzusr (Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList))) pure NoContent where @@ -646,13 +647,14 @@ idpCreate :: ) => SAML.Config -> TeamId -> + Maybe UserId -> Maybe ZHostValue -> IdPMetadataInfo -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Maybe (Range 1 32 Text) -> Sem r IdP -idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do +idpCreate samlConfig tid zUser uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmeta) mReplaces (fromMaybe defWireIdPAPIVersion -> apiversion) mHandle = withDebugLog "idpCreateXML" (Just . show . (^. SAML.idpId)) $ do let mbHost = filterMultiIngressZHost (samlConfig._cfgDomainConfigs) uncheckedMbHost GalleyAccess.assertSSOEnabled tid guardMultiIngressDuplicateDomain tid mbHost @@ -666,6 +668,7 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet logIdPAction "IdP created" idp + zUser ( Log.field "certificates" (idp ^. SAML.idpMetadata . SAML.edCertAuthnResponse . to (intercalate ";; " . map certToString . toList)) . Log.field "replaces" (maybe "None" (UUID.toString . SAML.fromIdPId) mReplaces) ) @@ -686,14 +689,15 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet when (zHost `elem` domains) $ throwSparSem SparIdPDomainInUse -logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> (Msg -> Msg) -> Sem r () -logIdPAction msg idp additionalFields = +logIdPAction :: (Member (Logger (Msg -> Msg)) r) => String -> IdP -> Maybe UserId -> (Msg -> Msg) -> Sem r () +logIdPAction msg idp zUser additionalFields = Logger.info $ Log.msg (msg) . Log.field "team" (idp ^. SAML.idpExtraInfo . team . to idToText) . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) + . Log.field "user" (fromMaybe "None" (idToText <$> zUser)) . additionalFields -- | Only return a ZHost when multi-ingress is configured and the host value is a configured domain @@ -714,14 +718,15 @@ idpCreateV7 :: ) => SAML.Config -> TeamId -> + Maybe UserId -> IdPMetadataInfo -> Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Maybe (Range 1 32 Text) -> Sem r IdP -idpCreateV7 samlConfig tid idpmeta mReplaces mApiversion mHandle = do +idpCreateV7 samlConfig tid zUser idpmeta mReplaces mApiversion mHandle = do assertNoScimOrNoIdP - idpCreate samlConfig tid Nothing idpmeta mReplaces mApiversion mHandle + idpCreate samlConfig tid zUser Nothing idpmeta mReplaces mApiversion mHandle where -- In teams with a scim access token, only one IdP is allowed. The reason is that scim user -- data contains no information about the idp issuer, only the user name, so no valid saml @@ -892,6 +897,7 @@ idpUpdateXML zusr mDomain raw idpmeta idpid mHandle = withDebugLog "idpUpdateXML in logIdPAction "IdP updated" idp + zusr ( Log.field "new-certificates" ((intercalate ";; " . map certToString . toList) removedCerts) . Log.field "removed-certificates" ((intercalate ";; " . map certToString . toList) newCerts) ) From 41d45c5a507fbd8fda5e7cc6218589ac73d3558c Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Wed, 7 Jan 2026 16:12:59 +0100 Subject: [PATCH 6/9] Use better function --- services/spar/src/Spar/API.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index dc9f9f3316..68fc7c02c7 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -697,7 +697,7 @@ logIdPAction msg idp zUser additionalFields = . Log.field "idpId" (idp ^. SAML.idpId . to SAML.fromIdPId . to UUID.toString) . Log.field "issuer" (idp ^. SAML.idpMetadata . SAML.edIssuer . SAML.fromIssuer . to URI.serializeURIRef') . Log.field "domain" (idp ^. SAML.idpExtraInfo . domain . to (fromMaybe "None")) - . Log.field "user" (fromMaybe "None" (idToText <$> zUser)) + . Log.field "user" (maybe "None" idToText zUser) . additionalFields -- | Only return a ZHost when multi-ingress is configured and the host value is a configured domain From d7fa3ffa4b4309248b0acd801a26dc3bdf6e20f9 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Wed, 7 Jan 2026 17:58:34 +0100 Subject: [PATCH 7/9] Unify logging effects One is enough - The more general one. --- services/spar/src/Spar/API.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 68fc7c02c7..88cae5db1d 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -243,7 +243,7 @@ apiINTERNAL :: Member (Error SparError) r, Member SAMLUserStore r, Member ScimUserTimesStore r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member Random r, Member GalleyAccess r, Member BrigAccess r @@ -476,7 +476,7 @@ authContext e = authHandler e :. EmptyContext idpGet :: ( Member Random r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member IdPConfigStore r, @@ -509,7 +509,7 @@ idpGetRaw zusr idpid = do idpGetAll :: ( Member Random r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member IdPConfigStore r, @@ -523,7 +523,7 @@ idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do idpGetAllByTeamId :: ( Member Random r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member IdPConfigStore r, @@ -637,7 +637,6 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co idpCreate :: ( Member Random r, Member (Logger (Msg -> Msg)) r, - Member (Logger String) r, Member GalleyAccess r, Member BrigAccess r, Member ScimTokenStore r, @@ -768,7 +767,7 @@ validateNewIdP :: forall m r. (HasCallStack, m ~ Sem r) => ( Member Random r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member IdPConfigStore r, Member (Error SparError) r ) => @@ -792,8 +791,8 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces idpDomain idHandle = wit mbIdp <- case apiversion of WireIdPAPIV1 -> IdPConfigStore.getIdPByIssuerV1Maybe (_idpMetadata ^. SAML.edIssuer) WireIdPAPIV2 -> IdPConfigStore.getIdPByIssuerV2Maybe (_idpMetadata ^. SAML.edIssuer) teamId - Logger.log Logger.Debug $ show (apiversion, _idpMetadata, teamId, mReplaces) - Logger.log Logger.Debug $ show (_idpId, oldIssuersList, mbIdp) + Logger.log Logger.Debug . Log.msg $ show (apiversion, _idpMetadata, teamId, mReplaces) + Logger.log Logger.Debug . Log.msg $ show (_idpId, oldIssuersList, mbIdp) let failWithIdPClash :: m () failWithIdPClash = throwSparSem . SparNewIdPAlreadyInUse $ case apiversion of @@ -918,7 +917,7 @@ validateIdPUpdate :: forall m r. (HasCallStack, m ~ Sem r) => ( Member Random r, - Member (Logger String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member IdPConfigStore r, @@ -975,12 +974,12 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateIdPUpdate" (J . URI.serializeURIRef uri = _idpMetadata ^. SAML.edIssuer . SAML.fromIssuer -withDebugLog :: (Member (Logger String) r) => String -> (a -> Maybe String) -> Sem r a -> Sem r a +withDebugLog :: (Member (Logger (Msg -> Msg)) r) => String -> (a -> Maybe String) -> Sem r a -> Sem r a withDebugLog msg showval action = do - Logger.log Logger.Debug $ "entering " ++ msg + Logger.log Logger.Debug . Log.msg $ "entering " ++ msg val <- action let mshowedval = showval val - Logger.log Logger.Debug $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] + Logger.log Logger.Debug . Log.msg $ "leaving " ++ msg ++ mconcat [": " ++ fromJust mshowedval | isJust mshowedval] pure val authorizeIdP :: From 9b515d42d57d1f6d0ad2bb71e6d09c6262e102fa Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Thu, 8 Jan 2026 09:07:45 +0100 Subject: [PATCH 8/9] Add lenses for IdPMetadataInfo Useful to tweak test data. --- libs/wire-api/src/Wire/API/User/IdentityProvider.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs index b6ffbd7129..8d591ad798 100644 --- a/libs/wire-api/src/Wire/API/User/IdentityProvider.hs +++ b/libs/wire-api/src/Wire/API/User/IdentityProvider.hs @@ -164,9 +164,14 @@ deriveJSON (defaultOptsDropChar '_') ''IdPList -- implement @{"uri": , "cert": }@. check both the certificate we get -- from the server against the pinned one and the metadata url in the metadata against the one -- we fetched the xml from, but it's unclear what the benefit would be.) -data IdPMetadataInfo = IdPMetadataValue Text SAML.IdPMetadata +data IdPMetadataInfo = IdPMetadataValue + { _rawIdpMetadataText :: Text, + _idpMetadataRecord :: SAML.IdPMetadata + } deriving (Eq, Show, Generic) +makeLenses ''IdPMetadataInfo + -- | We want to store the raw xml text from the registration request in the database for -- trouble shooting, but @SAML.XML@ only gives us access to the xml tree, not the raw text. -- 'RawXML' helps with that. From b840dbcf21be17c0290c19f51c990062a9e5548b Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Wed, 7 Jan 2026 18:30:29 +0100 Subject: [PATCH 9/9] WIP: IdPSpec --- services/spar/spar.cabal | 1 + services/spar/src/Spar/API.hs | 6 ++ services/spar/test/Test/Spar/Saml/IdPSpec.hs | 106 +++++++++++++++++++ 3 files changed, 113 insertions(+) create mode 100644 services/spar/test/Test/Spar/Saml/IdPSpec.hs diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 6d26c0d0f0..b6175253cb 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -562,6 +562,7 @@ test-suite spec Test.Spar.DataSpec Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString + Test.Spar.Saml.IdPSpec Test.Spar.Scim.UserSpec Test.Spar.ScimSpec Test.Spar.Sem.DefaultSsoCodeSpec diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 88cae5db1d..a66158aab2 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -42,6 +42,12 @@ module Spar.API IdpGetAll, IdpCreate, IdpDelete, + + -- * published to enable testing + + -- FUTUREWORK: This module should be split into two: Servant handler + -- subtilities and the functions that do the actual work. + idpCreate, ) where diff --git a/services/spar/test/Test/Spar/Saml/IdPSpec.hs b/services/spar/test/Test/Spar/Saml/IdPSpec.hs new file mode 100644 index 0000000000..b4837c4d32 --- /dev/null +++ b/services/spar/test/Test/Spar/Saml/IdPSpec.hs @@ -0,0 +1,106 @@ +module Test.Spar.Saml.IdPSpec where + +import Arbitrary () +import Data.Range +import Imports +import Polysemy +import qualified Polysemy.Error +import Polysemy.TinyLog +import SAML2.WebSSO +import Spar.API (idpCreate) +import Spar.Error +import Spar.Sem.BrigAccess +import Spar.Sem.GalleyAccess +import Spar.Sem.IdPConfigStore +import Spar.Sem.IdPConfigStore.Mem +import Spar.Sem.IdPRawMetadataStore +import Spar.Sem.IdPRawMetadataStore.Mem +import Spar.Sem.SAMLUserStore +import Spar.Sem.SAMLUserStore.Mem +import Spar.Sem.ScimTokenStore +import Spar.Sem.ScimTokenStore.Mem +import System.Logger (Msg) +import System.Logger.Class (Level (..)) +import Test.Hspec +import Test.QuickCheck +import URI.ByteString.QQ (uri) +import Wire.API.User.IdentityProvider (WireIdPAPIVersion (..), idPMetadataToInfo) +import Wire.Sem.Logger.TinyLog (LogRecorder (..), newLogRecorder, recordLogs) +import Wire.Sem.Random +import Wire.Sem.Random.Null + +spec :: Spec +spec = describe "SAML IdP change logging" $ do + describe "idp-create" $ do + it "should log IdP creation" $ do + tid <- generate arbitrary + zUser <- Just <$> generate arbitrary + idPMetadataInfo <- generate arbitrary + let samlConfig = + Config + { _cfgLogLevel = Debug, + _cfgSPHost = "localhost", + _cfgSPPort = 8081, + _cfgDomainConfigs = + Left + MultiIngressDomainConfig + { _cfgSPAppURI = [uri|https://example-sp.com/landing|], + _cfgSPSsoURI = [uri|https://example-sp.com/sso|], + _cfgContacts = [fallbackContact] + } + } + host = Just "backend.example.com" + idpHandle = Just $ unsafeRange "some-idp" + apiVersion = Just WireIdPAPIV2 + + interpretWithLoggingMock (idpCreate samlConfig tid zUser host idPMetadataInfo Nothing apiVersion idpHandle) + True `shouldBe` True + +type LogLine = (Level, LByteString) + +interpretWithLoggingMock :: + Sem (Effs) a -> + IO ([LogLine], a) +interpretWithLoggingMock action = do + lr <- newLogRecorder + a <- + runFinal + . embedToFinal @IO + . Polysemy.Error.errorToIOFinal + . recordLogs lr + . ignoringState idpRawMetadataStoreToMem + . ignoringState idPToMem + . ignoringState scimTokenStoreToMem + . brigAccessMock + . galleyAccessMock + . ignoringState samlUserStoreToMem + . randomToNull + $ action + logs <- readIORef lr.recordedLogs + -- TODO: Better error handling + pure (logs, either (error . show) id a) + +-- TODO: Is this general enough to extract it and provide it for other tests? +galleyAccessMock :: Sem (GalleyAccess ': r) a -> Sem r a +galleyAccessMock = todo + +-- TODO: Is this general enough to extract it and provide it for other tests? +brigAccessMock :: Sem (BrigAccess ': r) a -> Sem r a +brigAccessMock = todo + +ignoringState :: (Functor f) => (a -> f (c, b)) -> a -> f b +ignoringState f = fmap snd . f + +type Effs = + '[ Random, + SAMLUserStore, + GalleyAccess, + BrigAccess, + ScimTokenStore, + IdPConfigStore, + IdPRawMetadataStore, + Logger (Msg -> Msg), + Polysemy.Error.Error SparError, + Embed IO, + Final IO + ]