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. 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..964c2ee302 --- /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 SHA1) + -- 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, + "SHA1 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..a5af755839 --- /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; 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; 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 () +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/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/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. 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 f5f9de0d1e..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 @@ -62,6 +68,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 +115,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 +222,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, @@ -239,7 +249,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 @@ -472,7 +482,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, @@ -505,7 +515,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, @@ -519,7 +529,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, @@ -543,6 +553,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 +584,11 @@ idpDelete mbzusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (co do IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid + logIdPAction + "IdP deleted" + idp + mbzusr + (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 () @@ -626,7 +642,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 String) r, + Member (Logger (Msg -> Msg)) r, Member GalleyAccess r, Member BrigAccess r, Member ScimTokenStore r, @@ -636,13 +652,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 @@ -653,6 +670,13 @@ 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 + zUser + ( 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 @@ -670,6 +694,17 @@ idpCreate samlConfig tid uncheckedMbHost (IdPMetadataValue rawIdpMetadata idpmet when (zHost `elem` domains) $ throwSparSem SparIdPDomainInUse +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" (maybe "None" idToText zUser) + . 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 filterMultiIngressZHost (Right domainMap) (Just zHost) | (Domain zHost) `Map.member` domainMap = Just zHost @@ -678,6 +713,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, @@ -687,14 +723,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 @@ -736,7 +773,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 ) => @@ -760,8 +797,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 @@ -780,6 +817,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 +838,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 +854,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 +872,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 +894,27 @@ 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 logIdPAction + "IdP updated" + idp + zusr + ( 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 @@ -862,7 +923,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, @@ -871,7 +932,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 +965,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 @@ -919,12 +980,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 :: 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 + ]