From 0900aa8b0558e980b55d1cf9e1648f83a0432807 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 10:20:50 +0200 Subject: [PATCH 01/13] bloop From 5b3abb8c9c85bd8919d8d133eadd6230783bd308 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 10:43:08 +0200 Subject: [PATCH 02/13] Give some tests top-level functions; tweak names. --- .../integration/Test/Federator/IngressSpec.hs | 72 +++++++++---------- .../integration/Test/Federator/InwardSpec.hs | 44 +++++------- .../unit/Test/Federator/ExternalServer.hs | 6 +- 3 files changed, 55 insertions(+), 67 deletions(-) diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 62b4f1b7401..2679b27fb5f 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -73,45 +73,43 @@ spec env = do responseStatusCode resp `shouldBe` HTTP.status200 actualProfile `shouldBe` Just [expectedProfile] - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- This test was primarily intended to test that federator is using the API right (header - -- name etc.), but it is also effectively testing that federator rejects clients without - -- certificates that have been validated by ingress. - -- - -- We can't test end-to-end here: the TLS termination happens in k8s, and would have to be - -- tested there (and with a good emulation of the concrete configuration of the prod - -- system). - it "rejectRequestsWithoutClientCertIngress" $ - runTestFederator env $ do - brig <- view teBrig <$> ask - user <- randomUser brig - hdl <- randomHandle - _ <- putHandle brig (userId user) hdl + it "testRejectRequestsWithoutClientCertIngress" (testRejectRequestsWithoutClientCertIngress env) - settings <- view teSettings - sslCtxWithoutCert <- - either (throwM @_ @FederationSetupError) pure - <=< runM - . runEmbedded (liftIO @(TestFederator IO)) - . runError - $ mkSSLContextWithoutCert settings - runTestSem $ do - r <- - runError @RemoteError $ - inwardBrigCallViaIngressWithSettings - sslCtxWithoutCert - "get-user-by-handle" - (Aeson.fromEncoding (Aeson.toEncoding hdl)) - liftToCodensity . embed $ case r of - Right _ -> expectationFailure "Expected client certificate error, got response" - Left (RemoteError {}) -> - expectationFailure "Expected client certificate error, got remote error" - Left (RemoteErrorResponse _ _ status _) -> status `shouldBe` HTTP.status400 +-- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 +-- +-- This test was primarily intended to test that federator is using the API right (header +-- name etc.), but it is also effectively testing that federator rejects clients without +-- certificates that have been validated by ingress. +-- +-- We can't test end-to-end here: the TLS termination happens in k8s, and would have to be +-- tested there (and with a good emulation of the concrete configuration of the prod +-- system). +testRejectRequestsWithoutClientCertIngress :: TestEnv -> IO () +testRejectRequestsWithoutClientCertIngress env = runTestFederator env $ do + brig <- view teBrig <$> ask + user <- randomUser brig + hdl <- randomHandle + _ <- putHandle brig (userId user) hdl --- FUTUREWORK: ORMOLU_DISABLE --- @END --- ORMOLU_ENABLE + settings <- view teSettings + sslCtxWithoutCert <- + either (throwM @_ @FederationSetupError) pure + <=< runM + . runEmbedded (liftIO @(TestFederator IO)) + . runError + $ mkSSLContextWithoutCert settings + runTestSem $ do + r <- + runError @RemoteError $ + inwardBrigCallViaIngressWithSettings + sslCtxWithoutCert + "get-user-by-handle" + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + liftToCodensity . embed $ case r of + Right _ -> expectationFailure "Expected client certificate error, got response" + Left (RemoteError {}) -> + expectationFailure "Expected client certificate error, got remote error" + Left (RemoteErrorResponse _ _ status _) -> status `shouldBe` HTTP.status400 liftToCodensity :: Member (Embed (Codensity IO)) r => Sem (Embed IO ': r) a -> Sem r a liftToCodensity = runEmbedded @IO @(Codensity IO) lift diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index 33cd7e89c92..85980f8948c 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -79,14 +79,7 @@ spec env = liftIO $ bdy `shouldBe` [expectedProfile] - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- This test is covered by the unit tests 'validateDomainCertWrongDomain' because - -- the domain matching is checked on certificate validation. - it "shouldRejectMissmatchingOriginDomainInward" $ - runTestFederator env $ - pure () - -- @END + it "testShouldRejectMissmatchingOriginDomainInward" (testShouldRejectMissmatchingOriginDomainInward env) it "should be able to call cargohold" $ runTestFederator env $ do @@ -117,23 +110,24 @@ spec env = inwardCall "/i/users" (encode o) !!! const 404 === statusCode - -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 - -- - -- See related tests in unit tests (for matching client certificates against domain names) - -- and "IngressSpec". - it "rejectRequestsWithoutClientCertInward" $ - runTestFederator env $ do - originDomain <- originDomain <$> view teTstOpts - hdl <- randomHandle - inwardCallWithHeaders - "federation/brig/get-user-by-handle" - [(originDomainHeaderName, toByteString' originDomain)] - (encode hdl) - !!! const 400 === statusCode - --- TODO: ORMOLU_DISABLE --- @END --- ORMOLU_ENABLE + it "testRejectRequestsWithoutClientCertInward" (testRejectRequestsWithoutClientCertInward env) + +-- This test is covered by the unit tests 'validateDomainCertWrongDomain' because +-- the domain matching is checked on certificate validation. +testShouldRejectMissmatchingOriginDomainInward :: TestEnv -> IO () +testShouldRejectMissmatchingOriginDomainInward env = runTestFederator env $ pure () + +-- See related tests in unit tests (for matching client certificates against domain names) +-- and "IngressSpec". +testRejectRequestsWithoutClientCertInward :: TestEnv -> IO () +testRejectRequestsWithoutClientCertInward env = runTestFederator env $ do + originDomain <- originDomain <$> view teTstOpts + hdl <- randomHandle + inwardCallWithHeaders + "federation/brig/get-user-by-handle" + [(originDomainHeaderName, toByteString' originDomain)] + (encode hdl) + !!! const 400 === statusCode inwardCallWithHeaders :: (MonadIO m, MonadHttp m, MonadReader TestEnv m, HasCallStack) => diff --git a/services/federator/test/unit/Test/Federator/ExternalServer.hs b/services/federator/test/unit/Test/Federator/ExternalServer.hs index ec0b0438e24..7e499e3bc56 100644 --- a/services/federator/test/unit/Test/Federator/ExternalServer.hs +++ b/services/federator/test/unit/Test/Federator/ExternalServer.hs @@ -247,11 +247,9 @@ requestNoCertificate = assertEqual "no calls to any service should be made" [] serviceCalls pure Wai.ResponseReceived --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 --- Reject request if the client certificate for federator is invalid requestInvalidCertificate :: TestTree requestInvalidCertificate = - testCase "should fail with a 404 when an invalid certificate is given" $ do + testCase "testRequestInvalidCertificate - should fail with a 404 when an invalid certificate is given" $ do request <- testRequest def @@ -267,8 +265,6 @@ requestInvalidCertificate = assertEqual "no calls to any service should be made" [] serviceCalls pure Wai.ResponseReceived --- @END - testInvalidPaths :: TestTree testInvalidPaths = do let invalidPaths = From 9446cba6fba8a6cfb005eb8f058f8912fb220d9f Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 7 May 2024 08:50:08 +0000 Subject: [PATCH 03/13] wip add test name to test description --- libs/zauth/test/ZAuth.hs | 2 +- .../brig/test/integration/API/User/Account.hs | 10 +-- .../brig/test/integration/API/User/Auth.hs | 10 +-- .../brig/test/integration/API/User/Client.hs | 63 ++++++++++--------- .../brig/test/integration/API/User/Handles.hs | 2 +- 5 files changed, 44 insertions(+), 43 deletions(-) diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 80545f884ae..8cebb7ba2d0 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -56,7 +56,7 @@ tests = do ], testGroup "Signing and Verifying" - [ testCase "expired" (runCreate z 1 $ testExpired v), + [ testCase "testExpired - expired" (runCreate z 1 $ testExpired v), testCase "not expired" (runCreate z 2 $ testNotExpired v), testCase "signed access-token is valid" (runCreate z 3 $ testSignAndVerify v) ], diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1ea564fcbb5..1d882a2f02d 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -102,17 +102,17 @@ tests _ at opts p b c ch g aws userJournalWatcher = testGroup "account" [ test p "post /register - 201 (with preverified)" $ testCreateUserWithPreverified opts b userJournalWatcher, - test p "post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, + test p "testCreateUserWithInvalidVerificationCode - post /register - 400 (with preverified)" $ testCreateUserWithInvalidVerificationCode b, test p "post /register - 201" $ testCreateUser b g, test p "post /register - 201 + no email" $ testCreateUserNoEmailNoPassword b, test p "post /register - 201 anonymous" $ testCreateUserAnon b g, - test p "post /register - 400 empty name" $ testCreateUserEmptyName b, - test p "post /register - 400 name too long" $ testCreateUserLongName b, + test p "testCreateUserEmptyName - post /register - 400 empty name" $ testCreateUserEmptyName b, + test p "testCreateUserLongName - post /register - 400 name too long" $ testCreateUserLongName b, test p "post /register - 201 anonymous expiry" $ testCreateUserAnonExpiry b, test p "post /register - 201 pending" $ testCreateUserPending opts b, test p "post /register - 201 existing activation" $ testCreateAccountPendingActivationKey opts b, - test p "post /register - 409 conflict" $ testCreateUserConflict opts b, - test p "post /register - 400 invalid input" $ testCreateUserInvalidEmailOrPhone opts b, + test p "testCreateUserConflict - post /register - 409 conflict" $ testCreateUserConflict opts b, + test p "testCreateUserInvalidEmailOrPhone - post /register - 400 invalid input" $ testCreateUserInvalidEmailOrPhone opts b, test p "post /register - 403 blacklist" $ testCreateUserBlacklist opts b aws, test p "post /register - 400 external-SSO" $ testCreateUserExternalSSO b, test p "post /register - 403 restricted user creation" $ testRestrictedUserCreation opts b, diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index a52cd738b41..f0e394dfb40 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -100,9 +100,9 @@ tests conf m z db b g n = test m "handle" (testHandleLogin b), test m "email-untrusted-domain" (testLoginUntrustedDomain b), test m "send-phone-code" (testSendLoginCode b), - test m "failure" (testLoginFailure b), + test m "testLoginFailure - failure" (testLoginFailure b), test m "throttle" (testThrottleLogins conf b), - test m "limit-retry" (testLimitRetries conf b), + test m "testLimitRetries - limit-retry" (testLimitRetries conf b), test m "login with 6 character password" (testLoginWith6CharPassword b db), testGroup "sso-login" @@ -129,8 +129,8 @@ tests conf m z db b g n = ], testGroup "refresh /access" - [ test m "invalid-cookie" (testInvalidCookie @ZAuth.User z b), - test m "invalid-cookie legalhold" (testInvalidCookie @ZAuth.LegalHoldUser z b), + [ test m "testInvalidCookie - invalid-cookie" (testInvalidCookie @ZAuth.User z b), + test m "testInvalidCookie - invalid-cookie legalhold" (testInvalidCookie @ZAuth.LegalHoldUser z b), test m "invalid-token" (testInvalidToken z b), test m "missing-cookie" (testMissingCookie @ZAuth.User @ZAuth.Access z b), test m "missing-cookie legalhold" (testMissingCookie @ZAuth.LegalHoldUser @ZAuth.LegalHoldAccess z b), @@ -161,7 +161,7 @@ tests conf m z db b g n = [ test m "list" (testListCookies b), test m "remove-by-label" (testRemoveCookiesByLabel b), test m "remove-by-label-id" (testRemoveCookiesByLabelAndId b), - test m "limit" (testTooManyCookies conf b), + test m "testTooManyCookies - limit" (testTooManyCookies conf b), test m "logout" (testLogout b) ], testGroup diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 0fb44b9063f..68922872db6 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -108,27 +108,27 @@ tests _cl _at opts p db n b c g = testGroup "post /clients - verification code" [ test p "success" $ testAddGetClientVerificationCode db b g, - test p "missing code" $ testAddGetClientMissingCode b g, - test p "wrong code" $ testAddGetClientWrongCode b g, - test p "expired code" $ testAddGetClientCodeExpired db opts b g + test p "testAddGetClientMissingCode - missing code" $ testAddGetClientMissingCode b g, + test p "testAddGetClientWrongCode - wrong code" $ testAddGetClientWrongCode b g, + test p "testAddGetClientCodeExpired - expired code" $ testAddGetClientCodeExpired db opts b g ], test p "post /clients - 201 (with mls keys)" $ testAddGetClient def {addWithMLSKeys = True} b c, test p "post /clients - 403" $ testClientReauthentication b, test p "get /clients - 200" $ testListClients b, test p "get /clients/:client/prekeys - 200" $ testListPrekeyIds b, - test p "post /clients - 400" $ testTooManyClients opts b, - test p "client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b, - test p "lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b, - test p "lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b, - test p "delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c, - test p "delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c, - test p "delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b, - test p "delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b, + test p "testTooManyClients - post /clients - 400" $ testTooManyClients opts b, + test p "testPrekeysNotEmptyRandomPrekeys - client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b, + test p "testRegularPrekeysCannotBeSentAsLastPrekeys - lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b, + test p "testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate - lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b, + test p "testRemoveClient - delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c, + test p "testRemoveClient - delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c, + test p "testRemoveClientShortPwd - delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b, + test p "testRemoveClientIncorrectPwd - delete /clients/:client - 403 (incorrect pwd)" $ testRemoveClientIncorrectPwd b, test p "put /clients/:client - 200" $ testUpdateClient opts b, test p "put /clients/:client - 200 (mls keys)" $ testMLSPublicKeyUpdate b, test p "get /clients/:client - 404" $ testMissingClient b, test p "get /clients/:client - 200" $ testMLSClient b, - test p "post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g c, + test p "testAddMultipleTemporary - post /clients - 200 multiple temporary" $ testAddMultipleTemporary b g c, test p "client/prekeys/race" $ testPreKeyRace b, test p "get/head nonce/clients" $ testNewNonce b, testGroup @@ -903,6 +903,7 @@ testMultiUserGetPrekeysQualifiedV4 brig opts = do const 200 === statusCode const (Right $ expectedUserClientMap) === responseJsonEither +-- TODO(leif): check if all tests should be included -- The testTooManyClients test conforms to the following testing standards: -- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- @@ -937,25 +938,25 @@ testPrekeysNotEmptyRandomPrekeys :: Opt.Opts -> Brig -> Http () testPrekeysNotEmptyRandomPrekeys opts brig = do -- Run the test for randomPrekeys (not dynamoDB locking) let newOpts = opts {Opt.randomPrekeys = Just True} - ensurePrekeysNotEmpty newOpts brig - -ensurePrekeysNotEmpty :: Opt.Opts -> Brig -> Http () -ensurePrekeysNotEmpty opts brig = withSettingsOverrides opts $ do - lgr <- Log.new Log.defSettings - uid <- userId <$> randomUser brig - -- Create a client with 1 regular prekey and 1 last resort prekey - c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10)) - -- Claim the first regular one - _rs1 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs2 - liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2 - liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again...")) - -- Claim again; this should (again) give the last resort one - rs3 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs3 - liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3 + ensurePrekeysNotEmpty newOpts + where + ensurePrekeysNotEmpty :: Opt.Opts -> Http () + ensurePrekeysNotEmpty newOpts = withSettingsOverrides newOpts $ do + lgr <- Log.new Log.defSettings + uid <- userId <$> randomUser brig + -- Create a client with 1 regular prekey and 1 last resort prekey + c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10)) + -- Claim the first regular one + _rs1 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs2 + liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2 + liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again...")) + -- Claim again; this should (again) give the last resort one + rs3 <- getPreKey brig uid uid (clientId c) responseJsonMaybe rs3 + liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3 testRegularPrekeysCannotBeSentAsLastPrekeys :: Brig -> Http () testRegularPrekeysCannotBeSentAsLastPrekeys brig = do diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index d8bb4ac98ce..71864b17c96 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -56,7 +56,7 @@ tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon tests _cl _at conf p b c g = testGroup "handles" - [ test p "handles/update" $ testHandleUpdate b c, + [ test p "testHandleUpdate - handles/update" $ testHandleUpdate b c, test p "handles/race" $ testHandleRace b, test p "handles/query" $ testHandleQuery conf b, test p "handles/query - team-search-visibility SearchVisibilityStandard" $ testHandleQuerySearchVisibilityStandard conf b, From 65f39abebc0b19cf4206f3271b283df76ced5ba4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 10:51:50 +0200 Subject: [PATCH 04/13] Give one more test a top-level function. --- .../test/unit/Test/Federator/Options.hs | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 1530489e0f5..bece8365ab0 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -139,29 +139,7 @@ testSettings = <> show e Right _ -> assertFailure "expected failure for non-existing client certificate, got success", - -- @SF.Federation @TSFI.Federate @S3 @S7 - testCase "failToStartWithInvalidServerCredentials" $ do - let settings = - defRunSettings - "test/resources/unit/invalid.pem" - "test/resources/unit/localhost-key.pem" - assertParsesAs settings . B8.pack $ - [QQ.i| - useSystemCAStore: true - tcpConnectionTimeout: 1000 - federationStrategy: - allowAll: null - clientCertificate: test/resources/unit/invalid.pem - clientPrivateKey: test/resources/unit/localhost-key.pem|] - try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case - Left (InvalidClientCertificate _) -> pure () - Left e -> - assertFailure $ - "expected invalid client certificate exception, got: " - <> show e - Right _ -> - assertFailure "expected failure for invalid client certificate, got success", - -- @END + testCase "failToStartWithInvalidServerCredentials" failToStartWithInvalidServerCredentials, testCase "fail on invalid private key" $ do let settings = defRunSettings @@ -185,6 +163,29 @@ testSettings = assertFailure "expected failure for invalid private key, got success" ] +failToStartWithInvalidServerCredentials :: IO () +failToStartWithInvalidServerCredentials = do + let settings = + defRunSettings + "test/resources/unit/invalid.pem" + "test/resources/unit/localhost-key.pem" + assertParsesAs settings . B8.pack $ + [QQ.i| + useSystemCAStore: true + tcpConnectionTimeout: 1000 + federationStrategy: + allowAll: null + clientCertificate: test/resources/unit/invalid.pem + clientPrivateKey: test/resources/unit/localhost-key.pem|] + try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case + Left (InvalidClientCertificate _) -> pure () + Left e -> + assertFailure $ + "expected invalid client certificate exception, got: " + <> show e + Right _ -> + assertFailure "expected failure for invalid client certificate, got success" + assertParsesAs :: (HasCallStack, Eq a, FromJSON a, Show a) => a -> ByteString -> Assertion assertParsesAs v bs = assertEqual "YAML parsing" (Right v) $ From 132ce80f4d048c4f85bc48dbfcbc439e6fdb5b30 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Tue, 7 May 2024 09:06:16 +0000 Subject: [PATCH 05/13] update test descriptions --- .../unit/Test/Federator/InternalServer.hs | 2 +- .../test/unit/Test/Federator/Remote.hs | 2 +- .../test/unit/Test/Federator/Validation.hs | 6 ++-- services/galley/test/integration/API.hs | 28 +++++++++---------- .../galley/test/integration/API/Federation.hs | 2 +- services/galley/test/integration/API/Teams.hs | 8 +++--- 6 files changed, 24 insertions(+), 24 deletions(-) diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 3fb41d2d869..13d545027d6 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -112,7 +112,7 @@ federatedRequestSuccess = -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. federatedRequestFailureAllowList :: TestTree federatedRequestFailureAllowList = - testCase "should not make a call when target domain not in the allow list" $ do + testCase "federatedRequestFailureAllowList - should not make a call when target domain not in the allow list" $ do let settings = noClientCertSettings let targetDomain = Domain "target.example.com" headers = [(originDomainHeaderName, "origin.example.com")] diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 43be50b23d1..c2ec6353313 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -138,7 +138,7 @@ testValidatesCertificateSuccess = testValidatesCertificateWrongHostname :: TestTree testValidatesCertificateWrongHostname = testGroup - "refuses to connect with server" + "testValidatesCertificateWrongHostname - refuses to connect with server" [ testCase "when the server's certificate doesn't match the hostname" $ withMockServer certForWrongDomain $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 4086567271b..3a414c5dfc0 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -120,7 +120,7 @@ federateWithAllowListFail = -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. validateDomainAllowListFail :: TestTree validateDomainAllowListFail = - testCase "allow list validation" $ do + testCase "validateDomainAllowListFail - allow list validation" $ do Right exampleCert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" let settings = noClientCertSettings res <- @@ -157,7 +157,7 @@ validateDomainAllowListSuccess = -- domain in the `Wire-origin-domain` header. validateDomainCertWrongDomain :: TestTree validateDomainCertWrongDomain = - testCase "should fail if the client certificate has a wrong domain" $ do + testCase "validateDomainCertWrongDomain - should fail if the client certificate has a wrong domain" $ do Right exampleCert <- decodeCertificate <$> BS.readFile "test/resources/unit/localhost.example.com.pem" res <- runM @@ -257,7 +257,7 @@ validateDomainNonIdentitySRV = -- Reject request if the client certificate for federator is invalid validateDomainCertInvalid :: TestTree validateDomainCertInvalid = - testCase "should fail if the client certificate is invalid" $ do + testCase "validateDomainCertInvalid - should fail if the client certificate is invalid" $ do let res = decodeCertificate "not a certificate" res @?= Left "no certificate found" diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index fbf625a5138..3c9a0c74ad3 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -209,27 +209,27 @@ tests s = test s "conversation receipt mode update" putReceiptModeOk, test s "remote conversation receipt mode update" putRemoteReceiptModeOk, test s "leave connect conversation" leaveConnectConversation, - test s "post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, - test s "post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson, - test s "post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto, + test s "postCryptoMessageVerifyMsgSentAndRejectIfMissingClient - post conversations/:cnv/otr/message: message delivery and missing clients" postCryptoMessageVerifyMsgSentAndRejectIfMissingClient, + test s "postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson - post conversations/:cnv/otr/message: mismatch and prekey fetching" postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson, + test s "postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto - post conversations/:cnv/otr/message: mismatch with protobuf" postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto, test s "post conversations/:cnv/otr/message: unknown sender client" postCryptoMessageNotAuthorizeUnknownClient, - test s "post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam, - test s "post message qualified - local owning backend - missing clients" postMessageQualifiedLocalOwningBackendMissingClients, + test s "postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam - post conversations/:cnv/otr/message: ignore_missing and report_missing" postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam, + test s "postMessageQualifiedLocalOwningBackendMissingClients - post message qualified - local owning backend - missing clients" postMessageQualifiedLocalOwningBackendMissingClients, test s "post message qualified - local owning backend - redundant and deleted clients" postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients, - test s "post message qualified - local owning backend - ignore missing" postMessageQualifiedLocalOwningBackendIgnoreMissingClients, + test s "postMessageQualifiedLocalOwningBackendIgnoreMissingClients - post message qualified - local owning backend - ignore missing" postMessageQualifiedLocalOwningBackendIgnoreMissingClients, test s "post message qualified - local owning backend - failed to send clients" postMessageQualifiedLocalOwningBackendFailedToSendClients, test s "post message qualified - local owning backend - failed to fetch clients" postMessageQualifiedFailedToSendFetchingClients, test s "post message qualified - remote owning backend - federation failure" postMessageQualifiedRemoteOwningBackendFailure, test s "post message qualified - remote owning backend - success" postMessageQualifiedRemoteOwningBackendSuccess, test s "join conversation" postJoinConvOk, test s "get code-access conversation information" testJoinCodeConv, - test s "join code-access conversation - no password" postJoinCodeConvOk, + test s "postJoinCodeConvOk - join code-access conversation - no password" postJoinCodeConvOk, test s "join code-access conversation - password" postJoinCodeConvWithPassword, test s "convert invite to code-access conversation" postConvertCodeConv, test s "convert code to team-access conversation" postConvertTeamConv, test s "team member can't join via guest link if access role removed" testTeamMemberCantJoinViaGuestLinkIfAccessRoleRemoved, test s "cannot join private conversation" postJoinConvFail, - test s "revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, + test s "testJoinTeamConvGuestLinksDisabled - revoke guest links for team conversation" testJoinTeamConvGuestLinksDisabled, test s "revoke guest links for non-team conversation" testJoinNonTeamConvGuestLinksDisabled, test s "get code rejected if guest links disabled" testGetCodeRejectedIfGuestLinksDisabled, test s "post code rejected if guest links disabled" testPostCodeRejectedIfGuestLinksDisabled, @@ -242,8 +242,8 @@ tests s = ], test s "remove user with only local convs" removeUserNoFederation, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests, - test s "post message - reject if missing client" postMessageRejectIfMissingClients, - test s "post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg, + test s "postMessageRejectIfMissingClients - post message - reject if missing client" postMessageRejectIfMissingClients, + test s "postMessageClientNotInGroupDoesNotReceiveMsg - post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg, test s "get guest links status from foreign team conversation" getGuestLinksStatusFromForeignTeamConv, testGroup "Typing indicators" @@ -503,8 +503,8 @@ postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do -- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behavior of the the JSON endpoint. -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson :: TestM () -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do (alice, ac) <- randomUserWithClient (head someLastPrekeys) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) @@ -531,8 +531,8 @@ postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysJson = do -- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behaviour of the protobuf endpoint. -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto :: TestM () -postCryptoMessageVerifyRejectMissingClientAndRepondMissingPrekeysProto = do +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto :: TestM () +postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do (alice, ac) <- randomUserWithClient (head someLastPrekeys) (bob, bc) <- randomUserWithClient (someLastPrekeys !! 1) (eve, ec) <- randomUserWithClient (someLastPrekeys !! 2) diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index e6bd8eea883..4fc71a761d5 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -69,7 +69,7 @@ tests s = testGroup "federation" [ test s "POST /federation/get-conversations : All Found" getConversationsAllFound, - test s "POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, + test s "getConversationsNotPartOf - POST /federation/get-conversations : Conversations user is not a part of are excluded from result" getConversationsNotPartOf, test s "POST /federation/on-conversation-created : Add local user to remote conversation" onConvCreated, test s "POST /federation/on-conversation-updated : Add local user to remote conversation" addLocalUser, test s "POST /federation/on-conversation-updated : Add only unconnected local users to remote conversation" addUnconnectedUsersOnly, diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index dc5fffe2731..6ca62a5a8db 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -144,14 +144,14 @@ tests s = testGroup "delete team - verification code" [ test s "success" testDeleteTeamVerificationCodeSuccess, - test s "wrong code" testDeleteTeamVerificationCodeWrongCode, - test s "missing code" testDeleteTeamVerificationCodeMissingCode, - test s "expired code" testDeleteTeamVerificationCodeExpiredCode + test s "testDeleteTeamVerificationCodeWrongCode - wrong code" testDeleteTeamVerificationCodeWrongCode, + test s "testDeleteTeamVerificationCodeMissingCode - missing code" testDeleteTeamVerificationCodeMissingCode, + test s "testDeleteTeamVerificationCodeExpiredCode - expired code" testDeleteTeamVerificationCodeExpiredCode ], test s "delete team conversation" testDeleteTeamConv, test s "update team data" testUpdateTeam, test s "update team data icon validation" testUpdateTeamIconValidation, - test s "update team member" testUpdateTeamMember, + test s "testUpdateTeamMember - update team member" testUpdateTeamMember, test s "update team status" testUpdateTeamStatus, test s "send billing events to owners even in large teams" testBillingInLargeTeam, testGroup "broadcast" $ From 82b8097b3350da699891fae5041868c987fcace9 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 11:09:21 +0200 Subject: [PATCH 06/13] Give some tests top-level functions; tweak names. --- .../test-integration/Test/Spar/APISpec.hs | 197 +++++++++--------- .../Test/Spar/Scim/AuthSpec.hs | 10 +- .../Test/Spar/Scim/UserSpec.hs | 7 +- 3 files changed, 103 insertions(+), 111 deletions(-) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 52d502da6fc..3e63e2b7abf 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -214,30 +214,8 @@ specInitiateLogin = do specFinalizeLogin :: SpecWith TestEnv specFinalizeLogin = do describe "POST /sso/finalize-login" $ do - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Send authentication error and no cookie if response from SSO IdP was rejected - context "rejectsSAMLResponseSayingAccessNotGranted" $ do - it "responds with a very peculiar 'forbidden' HTTP response" $ do - (user, tid) <- callCreateUserWithTeam - (idp, (_, privcreds)) <- registerTestIdPWithMeta user - authnreq <- negotiateAuthnRequest idp - spmeta <- getTestSPMetadata tid - authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False - sparresp <- submitAuthnResponse tid authnresp - liftIO $ do - statusCode sparresp `shouldBe` 200 - let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) - bdy `shouldContain` "" - bdy `shouldContain` "" - bdy `shouldContain` "wire:sso:error:forbidden" - bdy `shouldContain` "window.opener.postMessage({" - bdy `shouldContain` "\"type\":\"AUTH_ERROR\"" - bdy `shouldContain` "\"payload\":{" - bdy `shouldContain` "\"label\":\"forbidden\"" - bdy `shouldContain` "}, receiverOrigin)" - hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" - - -- @END + context "not granted" $ do + it "testRejectsSAMLResponseSayingAccessNotGranted - responds with a very peculiar 'forbidden' HTTP response" $ do context "access granted" $ do let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () @@ -441,80 +419,10 @@ specFinalizeLogin = do g (c : s) = c : g s g "" = "" - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is for unknown issuer - it "rejectsSAMLResponseFromWrongIssuer" $ do - let mkareq = negotiateAuthnRequest - mkaresp privcreds idp spmeta authnreq = - mkAuthnResponse - privcreds - (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) - spmeta - authnreq - True - submitaresp = submitAuthnResponse - checkresp sparresp = do - statusCode sparresp `shouldBe` 404 - -- body should contain the error label in the title, the verbatim haskell error, and the request: - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)" - (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is signed with wrong key - it "rejectsSAMLResponseSignedWithWrongKey" $ do - (ownerid, _teamid) <- callCreateUserWithTeam - (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid - let mkareq = negotiateAuthnRequest - mkaresp _ idp spmeta authnreq = - mkAuthnResponse - badprivcreds - idp - spmeta - authnreq - True - submitaresp = submitAuthnResponse - checkresp sparresp = statusCode sparresp `shouldBe` 400 - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response has no corresponding request anymore - it "rejectsSAMLResponseIfRequestIsStale" $ do - let mkareq idp = do - req <- negotiateAuthnRequest idp - runSpar $ AReqIDStore.unStore (req ^. SAML.rqID) - pure req - mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True - submitaresp = submitAuthnResponse - checkresp sparresp = do - statusCode sparresp `shouldBe` 200 - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" - (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" - check mkareq mkaresp submitaresp checkresp - - -- @END - - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 - -- Do not authenticate if SSO IdP response is gone missing - it "rejectsSAMLResponseIfResponseIsStale" $ do - let mkareq = negotiateAuthnRequest - mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True - submitaresp teamid authnresp = do - _ <- submitAuthnResponse teamid authnresp - submitAuthnResponse teamid authnresp - checkresp sparresp = do - statusCode sparresp `shouldBe` 200 - (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" - check mkareq mkaresp submitaresp checkresp - - -- {- ORMOLU_DISABLE -} -- FUTUREWORK: try a newer release of ormolu? - -- @END - -- {- ORMOLU_ENABLE -} + it "testRejectsSAMLResponseFromWrongIssuer" testRejectsSAMLResponseFromWrongIssuer + it "testRejectsSAMLResponseSignedWithWrongKey" testRejectsSAMLResponseSignedWithWrongKey + it "testRejectsSAMLResponseIfRequestIsStale" testRejectsSAMLResponseIfRequestIsStale + it "testRejectsSAMLResponseIfResponseIsStale" testRejectsSAMLResponseIfResponseIsStale context "IdP changes response format" $ do it "treats NameId case-insensitively" $ do @@ -1787,3 +1695,96 @@ specReAuthSsoUserWithPassword = payload = RequestBodyLBS . encode . object . maybeToList $ fmap ("password" .=) pw + +---------------------------------------------------------------------- +-- tests for bsi audit + +testRejectsSAMLResponseSayingAccessNotGranted :: SpecWith TestEnv +testRejectsSAMLResponseSayingAccessNotGranted = do + (user, tid) <- callCreateUserWithTeam + (idp, (_, privcreds)) <- registerTestIdPWithMeta user + authnreq <- negotiateAuthnRequest idp + spmeta <- getTestSPMetadata tid + authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp spmeta authnreq False + sparresp <- submitAuthnResponse tid authnresp + liftIO $ do + statusCode sparresp `shouldBe` 200 + let bdy = maybe "" (cs @LByteString @String) (responseBody sparresp) + bdy `shouldContain` "" + bdy `shouldContain` "" + bdy `shouldContain` "wire:sso:error:forbidden" + bdy `shouldContain` "window.opener.postMessage({" + bdy `shouldContain` "\"type\":\"AUTH_ERROR\"" + bdy `shouldContain` "\"payload\":{" + bdy `shouldContain` "\"label\":\"forbidden\"" + bdy `shouldContain` "}, receiverOrigin)" + hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" + +-- Do not authenticate if SSO IdP response is for unknown issuer +testRejectsSAMLResponseFromWrongIssuer :: SpecWith Env +testRejectsSAMLResponseFromWrongIssuer = do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = + mkAuthnResponse + privcreds + (idp & idpMetadata . edIssuer .~ Issuer [uri|http://unknown-issuer/|]) + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 404 + -- body should contain the error label in the title, the verbatim haskell error, and the request: + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)" + (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" + check + mkareq + mkaresp + submitaresp + checkresp + +-- Do not authenticate if SSO IdP response is signed with wrong key +testRejectsSAMLResponseSignedWithWrongKey :: SpecWith TestEnv +testRejectsSAMLResponseSignedWithWrongKey = do + (ownerid, _teamid) <- callCreateUserWithTeam + (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid + let mkareq = negotiateAuthnRequest + mkaresp _ idp spmeta authnreq = + mkAuthnResponse + badprivcreds + idp + spmeta + authnreq + True + submitaresp = submitAuthnResponse + checkresp sparresp = statusCode sparresp `shouldBe` 400 + check mkareq mkaresp submitaresp checkresp + +-- Do not authenticate if SSO IdP response has no corresponding request anymore +testRejectsSAMLResponseIfRequestIsStale :: TestEnv +testRejectsSAMLResponseIfRequestIsStale = do + let mkareq idp = do + req <- negotiateAuthnRequest idp + runSpar $ AReqIDStore.unStore (req ^. SAML.rqID) + pure req + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp = submitAuthnResponse + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" + check mkareq mkaresp submitaresp checkresp + +-- Do not authenticate if SSO IdP response is gone missing +testRejectsSAMLResponseIfResponseIsStale :: TestEnv +testRejectsSAMLResponseIfResponseIsStale = do + let mkareq = negotiateAuthnRequest + mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True + submitaresp teamid authnresp = do + _ <- submitAuthnResponse teamid authnresp + submitAuthnResponse teamid authnresp + checkresp sparresp = do + statusCode sparresp `shouldBe` 200 + (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" + check mkareq mkaresp submitaresp checkresp diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index e646e8e2a57..3519a720df9 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -63,7 +63,7 @@ spec = do specDeleteToken specListTokens describe "Miscellaneous" $ do - it "doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded + it "testAuthIsNeeded - doesn't allow SCIM operations with invalid or missing SCIM token" testAuthIsNeeded ---------------------------------------------------------------------------- -- Token creation @@ -74,9 +74,9 @@ specCreateToken = describe "POST /auth-tokens" $ do it "works" testCreateToken it "respects the token limit" testTokenLimit it "requires the team to have no more than one IdP" testNumIdPs - it "authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins + it "testCreateTokenAuthorizesOnlyAdmins - authorizes only admins and owners" testCreateTokenAuthorizesOnlyAdmins it "requires a password" testCreateTokenRequiresPassword - it "works with verification code" testCreateTokenWithVerificationCode + it "testCreateTokenWithVerificationCode - works with verification code" testCreateTokenWithVerificationCode -- FUTUREWORK: we should also test that for a password-less user, e.g. for an SSO user, -- reauthentication is not required. We currently (2019-03-05) can't test that because @@ -106,8 +106,6 @@ testCreateToken = do listUsers_ (Just token) (Just fltr) (env ^. teSpar) !!! const 200 === statusCode --- @SF.Channel @TSFI.RESTfulAPI @S2 --- -- Test positive case but also that a SCIM token cannot be created with wrong -- or missing second factor email verification code when this feature is enabled testCreateTokenWithVerificationCode :: TestSpar () @@ -223,7 +221,6 @@ testNumIdPs = do createToken_ owner (CreateScimToken "drei" (Just defPassword) Nothing) (env ^. teSpar) !!! checkErr 400 (Just "more-than-one-idp") --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- Test that a token can only be created as a team owner testCreateTokenAuthorizesOnlyAdmins :: TestSpar () testCreateTokenAuthorizesOnlyAdmins = do @@ -456,7 +453,6 @@ testDeletedTokensAreUnlistable = do ---------------------------------------------------------------------------- -- Miscellaneous tests --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- This test verifies that the SCIM API responds with an authentication error -- and can't be used if it receives an invalid secret token -- or if no token is provided at all diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 5d23f93a9be..1ff2bdb2584 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -490,7 +490,7 @@ specCreateUser = describe "POST /Users" $ do it "set locale to hr and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage (Just (Locale (Language HR) Nothing)) Nothing it "set locale to default and update to default" $ testCreateUserWithSamlIdPWithPreferredLanguage Nothing Nothing it "requires externalId to be present" $ testExternalIdIsRequired - it "rejects invalid handle" $ testCreateRejectsInvalidHandle + it "testCreateRejectsInvalidHandle - rejects invalid handle" $ testCreateRejectsInvalidHandle it "rejects occupied handle" $ testCreateRejectsTakenHandle it "rejects occupied externalId (uref)" $ testCreateRejectsTakenExternalId True it "rejects occupied externalId (email)" $ testCreateRejectsTakenExternalId False @@ -840,9 +840,6 @@ testExternalIdIsRequired = do createUser_ (Just tok) user' (env ^. teSpar) !!! const 400 === statusCode --- The next line contains a mapping from this test to the following test standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 --- -- Test that user creation fails if handle is invalid testCreateRejectsInvalidHandle :: TestSpar () testCreateRejectsInvalidHandle = do @@ -853,8 +850,6 @@ testCreateRejectsInvalidHandle = do createUser_ (Just tok) (user {Scim.User.userName = "#invalid name"}) (env ^. teSpar) !!! const 400 === statusCode --- @END - -- | Test that user creation fails if handle is already in use (even on different team). testCreateRejectsTakenHandle :: TestSpar () testCreateRejectsTakenHandle = do From e3f533d7e4557218834d4ad7a8c1b9d56565ed73 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 11:12:29 +0200 Subject: [PATCH 07/13] rm TODO. --- services/brig/test/integration/API/User/Client.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 68922872db6..724401b5978 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -903,7 +903,6 @@ testMultiUserGetPrekeysQualifiedV4 brig opts = do const 200 === statusCode const (Right $ expectedUserClientMap) === responseJsonEither --- TODO(leif): check if all tests should be included -- The testTooManyClients test conforms to the following testing standards: -- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- @@ -986,8 +985,6 @@ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate brig = do !!! const 400 === statusCode --- @END - -- The testRemoveClient test conforms to the following testing standards: -- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- From 031559bcdff5f9dc367ba036bc41114ad74ea056 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 11:18:17 +0200 Subject: [PATCH 08/13] rm bsi audit tags. These will be provided by QA from elsewhere in the future. --- integration/test/Test/AccessUpdate.hs | 2 -- integration/test/Test/Login.hs | 6 ------ libs/zauth/test/ZAuth.hs | 2 -- .../brig/test/integration/API/User/Account.hs | 10 ---------- .../brig/test/integration/API/User/Auth.hs | 8 -------- .../brig/test/integration/API/User/Client.hs | 15 -------------- .../brig/test/integration/API/User/Handles.hs | 2 -- .../integration/Test/Federator/IngressSpec.hs | 1 - .../unit/Test/Federator/InternalServer.hs | 2 -- .../test/unit/Test/Federator/Remote.hs | 2 -- .../test/unit/Test/Federator/Validation.hs | 6 ------ services/galley/test/integration/API.hs | 20 ------------------- .../galley/test/integration/API/Federation.hs | 2 -- services/galley/test/integration/API/Teams.hs | 8 -------- .../test-integration/Test/Spar/APISpec.hs | 2 -- .../Test/Spar/Scim/AuthSpec.hs | 3 --- 16 files changed, 91 deletions(-) diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index 0152c6e63e6..19ebd9fa2f4 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -38,7 +38,6 @@ testBaz :: HasCallStack => App () testBaz = pure () -} --- | @SF.Federation @SF.Separation @TSFI.RESTfulAPI @S2 -- -- The test asserts that, among others, remote users are removed from a -- conversation when an access update occurs that disallows guests from @@ -74,7 +73,6 @@ testAccessUpdateGuestRemoved = do res.status `shouldMatchInt` 200 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob --- @END testAccessUpdateGuestRemovedUnreachableRemotes :: HasCallStack => App () testAccessUpdateGuestRemovedUnreachableRemotes = do diff --git a/integration/test/Test/Login.hs b/integration/test/Test/Login.hs index 1617e8b3a0f..6f403021feb 100644 --- a/integration/test/Test/Login.hs +++ b/integration/test/Test/Login.hs @@ -23,7 +23,6 @@ testLoginVerify6DigitEmailCodeSuccess = do bindResponse (loginWith2ndFactor owner email defPassword code) $ \resp -> do resp.status `shouldMatchInt` 200 --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login fails with wrong second factor email verification code testLoginVerify6DigitWrongCodeFails :: HasCallStack => App () @@ -39,9 +38,7 @@ testLoginVerify6DigitWrongCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login without verification code fails if SndFactorPasswordChallenge feature is enabled in team testLoginVerify6DigitMissingCodeFails :: HasCallStack => App () @@ -54,9 +51,7 @@ testLoginVerify6DigitMissingCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-required" --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that login fails with expired second factor email verification code testLoginVerify6DigitExpiredCodeFails :: HasCallStack => App () @@ -80,7 +75,6 @@ testLoginVerify6DigitExpiredCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" --- @END testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: HasCallStack => App () testLoginVerify6DigitResendCodeSuccessAndRateLimiting = do diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 8cebb7ba2d0..3f22f9c3879 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -94,7 +94,6 @@ testNotExpired p = do liftIO $ assertBool "testNotExpired: validation failed" (isRight x) -- The testExpired test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 @S3 -- -- Using an expired access token should fail testExpired :: V.Env -> Create () @@ -105,7 +104,6 @@ testExpired p = do x <- liftIO $ runValidate p $ check t liftIO $ Left Expired @=? x --- @END testSignAndVerify :: V.Env -> Create () testSignAndVerify p = do diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 1d882a2f02d..5c9d493f86d 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -172,7 +172,6 @@ tests _ at opts p b c ch g aws userJournalWatcher = ] -- The testCreateUserWithInvalidVerificationCode test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Registering with an invalid verification code and valid account details should fail. testCreateUserWithInvalidVerificationCode :: Brig -> Http () @@ -197,7 +196,6 @@ testCreateUserWithInvalidVerificationCode brig = do ] postUserRegister' regEmail brig !!! const 404 === statusCode --- @END testUpdateUserEmailByTeamOwner :: Opt.Opts -> Brig -> Http () testUpdateUserEmailByTeamOwner opts brig = do @@ -336,7 +334,6 @@ assertOnlySelfConversations galley uid = do liftIO $ cnvType conv @?= SelfConv -- The testCreateUserEmptyName test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- An empty name is not allowed on registration testCreateUserEmptyName :: Brig -> Http () @@ -348,10 +345,8 @@ testCreateUserEmptyName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode --- @END -- The testCreateUserLongName test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- a name with > 128 characters is not allowed. testCreateUserLongName :: Brig -> Http () @@ -364,7 +359,6 @@ testCreateUserLongName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode --- @END testCreateUserAnon :: Brig -> Galley -> Http () testCreateUserAnon brig galley = do @@ -443,7 +437,6 @@ testCreateUserNoEmailNoPassword brig = do !!! (const 202 === statusCode) -- The testCreateUserConflict test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- email address must not be taken on @/register@. testCreateUserConflict :: Opt.Opts -> Brig -> Http () @@ -475,10 +468,8 @@ testCreateUserConflict _ brig = do const 409 === statusCode const (Just "key-exists") === fmap Error.label . responseJsonMaybe --- @END -- The testCreateUserInvalidEmailOrPhone test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Test to make sure a new user cannot be created with an invalid email address or invalid phone number. testCreateUserInvalidEmailOrPhone :: Opt.Opts -> Brig -> Http () @@ -508,7 +499,6 @@ testCreateUserInvalidEmailOrPhone _ brig = do post (brig . path "/register" . contentJson . body reqPhone) !!! const 400 === statusCode --- @END testCreateUserBlacklist :: Opt.Opts -> Brig -> AWS.Env -> Http () testCreateUserBlacklist (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index f0e394dfb40..ca0a42062fc 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -423,7 +423,6 @@ testSendLoginCode brig = do liftIO $ assertEqual "timeout" (Just (Code.Timeout 600)) _timeout -- The testLoginFailure test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- Test that trying to log in with a wrong password or non-existent email fails. testLoginFailure :: Brig -> Http () @@ -446,7 +445,6 @@ testLoginFailure brig = do PersistentCookie !!! const 403 === statusCode --- @END testThrottleLogins :: Opts.Opts -> Brig -> Http () testThrottleLogins conf b = do @@ -473,7 +471,6 @@ testThrottleLogins conf b = do login b (defEmailLogin e) SessionCookie !!! const 200 === statusCode -- The testLimitRetries test conforms to the following testing standards: --- @SF.Channel @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- The following test tests the login retries. It checks that a user can make -- only a prespecified number of attempts to log in with an invalid password, @@ -528,7 +525,6 @@ testLimitRetries conf brig = do liftIO $ threadDelay (1000000 * 2) login brig (defEmailLogin email) SessionCookie !!! const 200 === statusCode --- @END ------------------------------------------------------------------------------- -- LegalHold Login @@ -656,7 +652,6 @@ testNoUserSsoLogin brig = do -- Token Refresh -- The testInvalidCookie test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @TSFI.NTP @S2 -- -- Test that invalid and expired tokens do not work. testInvalidCookie :: forall u. ZAuth.UserTokenLike u => ZAuth.Env -> Brig -> Http () @@ -674,7 +669,6 @@ testInvalidCookie z b = do const 403 === statusCode const (Just "expired") =~= responseBody --- @END testInvalidToken :: ZAuth.Env -> Brig -> Http () testInvalidToken z b = do @@ -1188,7 +1182,6 @@ testRemoveCookiesByLabelAndId b = do listCookies b (userId u) >>= liftIO . ([lbl] @=?) . map cookieLabel -- The testTooManyCookies test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test asserts that there is an upper limit for the number of user cookies -- per cookie type. It does that by concurrently attempting to create more @@ -1238,7 +1231,6 @@ testTooManyCookies config b = do ) xxx -> error ("Unexpected status code when logging in: " ++ show xxx) --- @END testLogout :: Brig -> Http () testLogout b = do diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 724401b5978..50a3b46d5ca 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -161,7 +161,6 @@ testAddGetClientVerificationCode db brig galley = do const 200 === statusCode const (Just c) === responseJsonMaybe --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with missing second factor email verification code when this feature is enabled testAddGetClientMissingCode :: Brig -> Galley -> Http () @@ -178,9 +177,7 @@ testAddGetClientMissingCode brig galley = do const 403 === statusCode const (Just "code-authentication-required") === fmap Error.label . responseJsonMaybe --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with wrong second factor email verification code when this feature is enabled testAddGetClientWrongCode :: Brig -> Galley -> Http () @@ -198,9 +195,7 @@ testAddGetClientWrongCode brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that device cannot be added with expired second factor email verification code when this feature is enabled testAddGetClientCodeExpired :: DB.ClientState -> Opt.Opts -> Brig -> Galley -> Http () @@ -225,7 +220,6 @@ testAddGetClientCodeExpired db opts brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe --- @END data AddGetClient = AddGetClient { addWithPassword :: Bool, @@ -904,7 +898,6 @@ testMultiUserGetPrekeysQualifiedV4 brig opts = do const (Right $ expectedUserClientMap) === responseJsonEither -- The testTooManyClients test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test validates the upper bound on the number of permanent clients per -- user. It does so by trying to create one permanent client more than allowed. @@ -986,7 +979,6 @@ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate brig = do === statusCode -- The testRemoveClient test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- This test validates creating and deleting a client. A client is created and -- consequently deleted. Deleting a second time yields response 404 not found. @@ -1032,10 +1024,8 @@ testRemoveClient hasPwd brig cannon = do newClientCookie = Just defCookieLabel } --- @END -- The testRemoveClientShortPwd test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test checks if a client can be deleted by providing a too short password. -- This is done by using a single-character password, whereas the minimum is 6 @@ -1068,10 +1058,8 @@ testRemoveClientShortPwd brig = do newClientCookie = Just defCookieLabel } --- @END -- The testRemoveClientIncorrectPwd test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test checks if a client can be deleted by providing a syntax-valid, but -- incorrect password. The client deletion attempt fails with a 403 error @@ -1104,7 +1092,6 @@ testRemoveClientIncorrectPwd brig = do newClientCookie = Just defCookieLabel } --- @END testUpdateClient :: Opt.Opts -> Brig -> Http () testUpdateClient opts brig = do @@ -1298,7 +1285,6 @@ testMissingClient brig = do . responseHeaders -- The testAddMultipleTemporary test conforms to the following testing standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- Legacy (galley) -- -- Add temporary client, check that all services (both galley and @@ -1356,7 +1342,6 @@ testAddMultipleTemporary brig galley cannon = do . zUser u pure $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r) --- @END testPreKeyRace :: Brig -> Http () testPreKeyRace brig = do diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 71864b17c96..b9ac682f25b 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -69,7 +69,6 @@ tests _cl _at conf p b c g = ] -- The next line contains a mapping from the testHandleUpdate test to the following test standards: --- @SF.Provisioning @TSFI.RESTfulAPI @S2 -- -- The test validates various updates to the user's handle. First, it attempts -- to set invalid handles. This fails. Then it successfully sets a valid handle. @@ -140,7 +139,6 @@ testHandleUpdate brig cannon = do put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! const 200 === statusCode --- @END testHandleRace :: Brig -> Http () testHandleRace brig = do diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 2679b27fb5f..f28fca1bdf1 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -75,7 +75,6 @@ spec env = do it "testRejectRequestsWithoutClientCertIngress" (testRejectRequestsWithoutClientCertIngress env) --- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 -- -- This test was primarily intended to test that federator is using the API right (header -- name etc.), but it is also effectively testing that federator rejects clients without diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 13d545027d6..3a51df051e2 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -107,7 +107,6 @@ federatedRequestSuccess = body <- Wai.lazyResponseBody res body @?= "\"bar\"" --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. federatedRequestFailureAllowList :: TestTree @@ -151,4 +150,3 @@ federatedRequestFailureAllowList = $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) --- @END diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index c2ec6353313..972acdb2469 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -129,7 +129,6 @@ testValidatesCertificateSuccess = Right _ -> assertFailure "Congratulations, you fixed a known issue!" ] --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 -- -- This is a group of test cases where refusing to connect with the server is -- checked. The second test case refuses to connect with a server when the @@ -155,7 +154,6 @@ testValidatesCertificateWrongHostname = Right _ -> assertFailure "Expected connection with the server to fail" ] --- @END testConnectionError :: TestTree testConnectionError = testCase "connection failures are reported correctly" $ do diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index 3a414c5dfc0..ccffeb984e0 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -115,7 +115,6 @@ federateWithAllowListFail = $ ensureCanFederateWith (Domain "hello.world") assertBool "federating should not be allowed" (isLeft eith) --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- -- Refuse to send outgoing request to non-included domain when AllowDynamic is configured. validateDomainAllowListFail :: TestTree @@ -133,7 +132,6 @@ validateDomainAllowListFail = $ validateDomain exampleCert (Domain "localhost.example.com") res @?= Left (FederationDenied (Domain "localhost.example.com")) --- @END validateDomainAllowListSuccess :: TestTree validateDomainAllowListSuccess = @@ -151,7 +149,6 @@ validateDomainAllowListSuccess = $ validateDomain exampleCert domain assertEqual "validateDomain should give 'localhost.example.com' as domain" domain res --- @SF.Federation @TSFI.Federate @TSFI.DNS @S3 @S7 -- -- Reject request if the infrastructure domain in the client cert does not match the backend -- domain in the `Wire-origin-domain` header. @@ -169,7 +166,6 @@ validateDomainCertWrongDomain = $ validateDomain exampleCert (Domain "foo.example.com") res @?= Left (AuthenticationFailure (pure [X509.NameMismatch "foo.example.com"])) --- @END validateDomainCertCN :: TestTree validateDomainCertCN = @@ -253,7 +249,6 @@ validateDomainNonIdentitySRV = $ validateDomain exampleCert domain res @?= domain --- @SF.Federation @TSFI.Federate @TSFI.DNS @S2 @S3 @S7 -- Reject request if the client certificate for federator is invalid validateDomainCertInvalid :: TestTree validateDomainCertInvalid = @@ -261,4 +256,3 @@ validateDomainCertInvalid = let res = decodeCertificate "not a certificate" res @?= Left "no certificate found" --- @END diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 3c9a0c74ad3..e9a2d0ccd29 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -410,7 +410,6 @@ postConvWithUnreachableRemoteUsers rbs = do groupConvs WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies whether a message actually gets sent all the way to -- cannon. postCryptoMessageVerifyMsgSentAndRejectIfMissingClient :: TestM () @@ -499,9 +498,7 @@ postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do liftIO $ assertBool "unexpected equal clients" (bc /= bc2) assertNoMsg wsB2 (wsAssertOtr qconv qalice ac bc cipher) --- @END --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behavior of the the JSON endpoint. postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson :: TestM () postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do @@ -527,9 +524,7 @@ postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- @END --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies basic mismatch behaviour of the protobuf endpoint. postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto :: TestM () postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do @@ -557,7 +552,6 @@ postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] --- @END -- | This test verifies behaviour when an unknown client posts the message. Only -- tests the Protobuf endpoint. @@ -574,7 +568,6 @@ postCryptoMessageNotAuthorizeUnknownClient = do postProtoOtrMessage alice (ClientId 0x172618352518396) conv m !!! const 403 === statusCode --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies the following scenario. -- A client sends a message to all clients of a group and one more who is not part of the group. -- The server must not send this message to client ids not part of the group. @@ -600,9 +593,7 @@ postMessageClientNotInGroupDoesNotReceiveMsg = do checkEveGetsMsg checkChadDoesNotGetMsg --- @END --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies that when a client sends a message not to all clients of a group then the server should reject the message and sent a notification to the sender (412 Missing clients). -- The test is somewhat redundant because this is already tested as part of other tests already. This is a stand alone test that solely tests the behavior described above. postMessageRejectIfMissingClients :: TestM () @@ -630,9 +621,7 @@ postMessageRejectIfMissingClients = do mkMsg :: ByteString -> (UserId, ClientId) -> (UserId, ClientId, Text) mkMsg text (uid, clientId) = (uid, clientId, toBase64Text text) --- @END --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies behaviour under various values of ignore_missing and -- report_missing. Only tests the JSON endpoint. postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam :: TestM () @@ -690,9 +679,7 @@ postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam = do where listToByteString = BS.intercalate "," . map toByteString' --- @END --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will not be sent. @@ -753,7 +740,6 @@ postMessageQualifiedLocalOwningBackendMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] --- @END -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message, it is expected that message will @@ -845,7 +831,6 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do -- Wait less for no message WS.assertNoEvent (1 # Second) [wsNonMember] --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will be sent except when it is specifically @@ -972,7 +957,6 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] --- @END postMessageQualifiedLocalOwningBackendFailedToSendClients :: TestM () postMessageQualifiedLocalOwningBackendFailedToSendClients = do @@ -1203,7 +1187,6 @@ testPostCodeRejectedIfGuestLinksDisabled = do setStatus Public.FeatureStatusEnabled checkPostCode 200 --- @SF.Separation @TSFI.RESTfulAPI @S2 -- Check if guests cannot join anymore if guest invite feature was disabled on team level testJoinTeamConvGuestLinksDisabled :: TestM () testJoinTeamConvGuestLinksDisabled = do @@ -1261,7 +1244,6 @@ testJoinTeamConvGuestLinksDisabled = do postJoinCodeConv bob' cCode !!! const 200 === statusCode checkFeatureStatus Public.FeatureStatusEnabled --- @END testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do @@ -1286,7 +1268,6 @@ testJoinNonTeamConvGuestLinksDisabled = do const (Right (ConversationCoverView convId (Just convName) False)) === responseJsonEither const 200 === statusCode --- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test case covers a negative check that if access code of a guest link is revoked no further -- people can join the group conversation. Additionally it covers: -- Random users can use invite link @@ -1341,7 +1322,6 @@ postJoinCodeConvOk = do putQualifiedAccessUpdate alice qconv noCodeAccess !!! const 200 === statusCode postJoinCodeConv dave payload !!! const 404 === statusCode --- @END postJoinCodeConvWithPassword :: TestM () postJoinCodeConvWithPassword = do diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 4fc71a761d5..11dacfcafd6 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -159,7 +159,6 @@ getConversationsAllFound = do (Just (sort [bob, qUnqualified carlQ])) (fmap (sort . map (qUnqualified . omQualifiedId) . (.members.others)) c2) --- @SF.Federation @TSFI.RESTfulAPI @S2 -- -- The test asserts that via a federation client a user cannot fetch -- conversation details of a conversation they are not part of: they get an @@ -188,7 +187,6 @@ getConversationsNotPartOf = do GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs --- @END onConvCreated :: TestM () onConvCreated = do diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 6ca62a5a8db..a81e48d216a 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1044,7 +1044,6 @@ testDeleteTeamVerificationCodeSuccess = do const 202 === statusCode assertTeamDelete 10 "team delete, should be there" tid --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with missing second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeMissingCode :: TestM () @@ -1066,9 +1065,7 @@ testDeleteTeamVerificationCodeMissingCode = do const 403 === statusCode const "code-authentication-required" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with expired second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeExpiredCode :: TestM () @@ -1093,9 +1090,7 @@ testDeleteTeamVerificationCodeExpiredCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END --- @SF.Channel @TSFI.RESTfulAPI @S2 -- -- Test that team cannot be deleted with wrong second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeWrongCode :: TestM () @@ -1118,7 +1113,6 @@ testDeleteTeamVerificationCodeWrongCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") --- @END setFeatureLockStatus :: forall cfg. (KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> Public.LockStatus -> TestM () setFeatureLockStatus tid status = do @@ -1397,7 +1391,6 @@ testBillingInLargeTeam = do assertTeamUpdate ("delete fanoutLimit + 3rd billing member: " <> show ownerFanoutPlusThree) team (fanoutLimit + 2) (allOwnersBeforeFanoutLimit <> [ownerFanoutPlusTwo]) refreshIndex --- | @SF.Management @TSFI.RESTfulAPI @S2 -- This test covers: -- Promotion, demotion of team roles. -- Demotion by superior roles is allowed. @@ -1464,7 +1457,6 @@ testUpdateTeamMember = do e ^. eventTeam @?= tid e ^. eventData @?= EdMemberUpdate uid mPerm --- @END testUpdateTeamStatus :: TestM () testUpdateTeamStatus = do diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 3e63e2b7abf..00ad86136a5 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -292,7 +292,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponse privcreds idp3 spmeta authnreq True loginSuccess =<< submitAuthnResponse tid3 authnresp - -- @SF.Channel @TSFI.RESTfulAPI @S2 @S3 -- Do not authenticate if SSO IdP response is for different team context "rejectsSAMLResponseInWrongTeam" $ do it "fails" $ do @@ -319,7 +318,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp2 spmeta authnreq True loginFailure =<< submitAuthnResponse tid2 authnresp - -- @END context "user is created once, then deleted in team settings, then can login again." $ do it "responds with 'allowed'" $ do diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 3519a720df9..51c50d30f68 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -141,7 +141,6 @@ testCreateTokenWithVerificationCode = do call $ post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email)) --- @END unlockFeature :: GalleyReq -> TeamId -> TestSpar () unlockFeature galley tid = @@ -253,7 +252,6 @@ testCreateTokenAuthorizesOnlyAdmins = do (mkUser RoleAdmin >>= createToken') !!! const 200 === statusCode --- @END -- | Test that for a user with a password, token creation requires reauthentication (i.e. the -- field @"password"@ should be provided). @@ -465,4 +463,3 @@ testAuthIsNeeded = do -- Try to do @GET /Users@ without a token and check that it fails listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing --- @END From 34c729fb731d2088cd67db1a2e83b830c426fce0 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 11:21:54 +0200 Subject: [PATCH 09/13] Changelog. --- .../5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit diff --git a/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit b/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit new file mode 100644 index 00000000000..63c5cb9df02 --- /dev/null +++ b/changelog.d/5-internal/wpb8628-clean-up-syntax-of-tests-from-bsi-audit @@ -0,0 +1 @@ +Clean up syntax of test cases that occur in BSI audit. \ No newline at end of file From 496c739f0ff8c7bbd0cec6c155051f43a9cd75f1 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 12:00:41 +0200 Subject: [PATCH 10/13] ormolu --- integration/test/Test/AccessUpdate.hs | 1 - integration/test/Test/Login.hs | 3 --- libs/zauth/test/ZAuth.hs | 1 - services/brig/test/integration/API/User/Account.hs | 5 ----- services/brig/test/integration/API/User/Auth.hs | 4 ---- services/brig/test/integration/API/User/Client.hs | 7 ------- services/brig/test/integration/API/User/Handles.hs | 1 - .../test/unit/Test/Federator/InternalServer.hs | 1 - services/federator/test/unit/Test/Federator/Remote.hs | 1 - .../federator/test/unit/Test/Federator/Validation.hs | 3 --- services/galley/test/integration/API.hs | 10 ---------- services/galley/test/integration/API/Federation.hs | 1 - services/galley/test/integration/API/Teams.hs | 4 ---- services/spar/test-integration/Test/Spar/APISpec.hs | 1 - .../spar/test-integration/Test/Spar/Scim/AuthSpec.hs | 3 --- 15 files changed, 46 deletions(-) diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index 19ebd9fa2f4..1d9ad94ad23 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -73,7 +73,6 @@ testAccessUpdateGuestRemoved = do res.status `shouldMatchInt` 200 res.json %. "members.others.0.qualified_id" `shouldMatch` objQidObject bob - testAccessUpdateGuestRemovedUnreachableRemotes :: HasCallStack => App () testAccessUpdateGuestRemovedUnreachableRemotes = do resourcePool <- asks resourcePool diff --git a/integration/test/Test/Login.hs b/integration/test/Test/Login.hs index 6f403021feb..b16f5ec3074 100644 --- a/integration/test/Test/Login.hs +++ b/integration/test/Test/Login.hs @@ -38,7 +38,6 @@ testLoginVerify6DigitWrongCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" - -- -- Test that login without verification code fails if SndFactorPasswordChallenge feature is enabled in team testLoginVerify6DigitMissingCodeFails :: HasCallStack => App () @@ -51,7 +50,6 @@ testLoginVerify6DigitMissingCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-required" - -- -- Test that login fails with expired second factor email verification code testLoginVerify6DigitExpiredCodeFails :: HasCallStack => App () @@ -75,7 +73,6 @@ testLoginVerify6DigitExpiredCodeFails = do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "code-authentication-failed" - testLoginVerify6DigitResendCodeSuccessAndRateLimiting :: HasCallStack => App () testLoginVerify6DigitResendCodeSuccessAndRateLimiting = do (owner, team, []) <- createTeam OwnDomain 0 diff --git a/libs/zauth/test/ZAuth.hs b/libs/zauth/test/ZAuth.hs index 3f22f9c3879..db94845d04c 100644 --- a/libs/zauth/test/ZAuth.hs +++ b/libs/zauth/test/ZAuth.hs @@ -104,7 +104,6 @@ testExpired p = do x <- liftIO $ runValidate p $ check t liftIO $ Left Expired @=? x - testSignAndVerify :: V.Env -> Create () testSignAndVerify p = do u <- liftIO nextRandom diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 5c9d493f86d..0a852a7c75e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -196,7 +196,6 @@ testCreateUserWithInvalidVerificationCode brig = do ] postUserRegister' regEmail brig !!! const 404 === statusCode - testUpdateUserEmailByTeamOwner :: Opt.Opts -> Brig -> Http () testUpdateUserEmailByTeamOwner opts brig = do (_, teamOwner, emailOwner : otherTeamMember : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 2 @@ -345,7 +344,6 @@ testCreateUserEmptyName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode - -- The testCreateUserLongName test conforms to the following testing standards: -- -- a name with > 128 characters is not allowed. @@ -359,7 +357,6 @@ testCreateUserLongName brig = do post (brig . path "/register" . contentJson . body p) !!! const 400 === statusCode - testCreateUserAnon :: Brig -> Galley -> Http () testCreateUserAnon brig galley = do let p = @@ -468,7 +465,6 @@ testCreateUserConflict _ brig = do const 409 === statusCode const (Just "key-exists") === fmap Error.label . responseJsonMaybe - -- The testCreateUserInvalidEmailOrPhone test conforms to the following testing standards: -- -- Test to make sure a new user cannot be created with an invalid email address or invalid phone number. @@ -499,7 +495,6 @@ testCreateUserInvalidEmailOrPhone _ brig = do post (brig . path "/register" . contentJson . body reqPhone) !!! const 400 === statusCode - testCreateUserBlacklist :: Opt.Opts -> Brig -> AWS.Env -> Http () testCreateUserBlacklist (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () testCreateUserBlacklist _ brig aws = diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index ca0a42062fc..8a23e8cbb27 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -445,7 +445,6 @@ testLoginFailure brig = do PersistentCookie !!! const 403 === statusCode - testThrottleLogins :: Opts.Opts -> Brig -> Http () testThrottleLogins conf b = do -- Get the maximum amount of times we are allowed to login before @@ -525,7 +524,6 @@ testLimitRetries conf brig = do liftIO $ threadDelay (1000000 * 2) login brig (defEmailLogin email) SessionCookie !!! const 200 === statusCode - ------------------------------------------------------------------------------- -- LegalHold Login @@ -669,7 +667,6 @@ testInvalidCookie z b = do const 403 === statusCode const (Just "expired") =~= responseBody - testInvalidToken :: ZAuth.Env -> Brig -> Http () testInvalidToken z b = do user <- Public.userId <$> randomUser b @@ -1231,7 +1228,6 @@ testTooManyCookies config b = do ) xxx -> error ("Unexpected status code when logging in: " ++ show xxx) - testLogout :: Brig -> Http () testLogout b = do Just email <- userEmail <$> randomUser b diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 50a3b46d5ca..b7bbd4c2cd1 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -177,7 +177,6 @@ testAddGetClientMissingCode brig galley = do const 403 === statusCode const (Just "code-authentication-required") === fmap Error.label . responseJsonMaybe - -- -- Test that device cannot be added with wrong second factor email verification code when this feature is enabled testAddGetClientWrongCode :: Brig -> Galley -> Http () @@ -195,7 +194,6 @@ testAddGetClientWrongCode brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe - -- -- Test that device cannot be added with expired second factor email verification code when this feature is enabled testAddGetClientCodeExpired :: DB.ClientState -> Opt.Opts -> Brig -> Galley -> Http () @@ -220,7 +218,6 @@ testAddGetClientCodeExpired db opts brig galley = do const 403 === statusCode const (Just "code-authentication-failed") === fmap Error.label . responseJsonMaybe - data AddGetClient = AddGetClient { addWithPassword :: Bool, addWithMLSKeys :: Bool @@ -1024,7 +1021,6 @@ testRemoveClient hasPwd brig cannon = do newClientCookie = Just defCookieLabel } - -- The testRemoveClientShortPwd test conforms to the following testing standards: -- -- The test checks if a client can be deleted by providing a too short password. @@ -1058,7 +1054,6 @@ testRemoveClientShortPwd brig = do newClientCookie = Just defCookieLabel } - -- The testRemoveClientIncorrectPwd test conforms to the following testing standards: -- -- The test checks if a client can be deleted by providing a syntax-valid, but @@ -1092,7 +1087,6 @@ testRemoveClientIncorrectPwd brig = do newClientCookie = Just defCookieLabel } - testUpdateClient :: Opt.Opts -> Brig -> Http () testUpdateClient opts brig = do uid <- userId <$> randomUser brig @@ -1342,7 +1336,6 @@ testAddMultipleTemporary brig galley cannon = do . zUser u pure $ Vec.length <$> (preview _Array =<< responseJsonMaybe @Value r) - testPreKeyRace :: Brig -> Http () testPreKeyRace brig = do uid <- userId <$> randomUser brig diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index b9ac682f25b..88164a3e600 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -139,7 +139,6 @@ testHandleUpdate brig cannon = do put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! const 200 === statusCode - testHandleRace :: Brig -> Http () testHandleRace brig = do us <- replicateM 10 (userId <$> randomUser brig) diff --git a/services/federator/test/unit/Test/Federator/InternalServer.hs b/services/federator/test/unit/Test/Federator/InternalServer.hs index 3a51df051e2..86f9f7e93e7 100644 --- a/services/federator/test/unit/Test/Federator/InternalServer.hs +++ b/services/federator/test/unit/Test/Federator/InternalServer.hs @@ -149,4 +149,3 @@ federatedRequestFailureAllowList = . interpretMetricsEmpty $ callOutward Nothing targetDomain Brig (RPC "get-user-by-handle") request eith @?= Left (FederationDenied targetDomain) - diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 972acdb2469..8d8de9f0660 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -154,7 +154,6 @@ testValidatesCertificateWrongHostname = Right _ -> assertFailure "Expected connection with the server to fail" ] - testConnectionError :: TestTree testConnectionError = testCase "connection failures are reported correctly" $ do tlsSettings <- mkTLSSettingsOrThrow settings diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index ccffeb984e0..24879f15aae 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -132,7 +132,6 @@ validateDomainAllowListFail = $ validateDomain exampleCert (Domain "localhost.example.com") res @?= Left (FederationDenied (Domain "localhost.example.com")) - validateDomainAllowListSuccess :: TestTree validateDomainAllowListSuccess = testCase "should give parsed domain if in the allow list" $ do @@ -166,7 +165,6 @@ validateDomainCertWrongDomain = $ validateDomain exampleCert (Domain "foo.example.com") res @?= Left (AuthenticationFailure (pure [X509.NameMismatch "foo.example.com"])) - validateDomainCertCN :: TestTree validateDomainCertCN = testCase "should succeed if the certificate has subject CN but no SAN" $ do @@ -255,4 +253,3 @@ validateDomainCertInvalid = testCase "validateDomainCertInvalid - should fail if the client certificate is invalid" $ do let res = decodeCertificate "not a certificate" res @?= Left "no certificate found" - diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index e9a2d0ccd29..b20fb577974 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -498,7 +498,6 @@ postCryptoMessageVerifyMsgSentAndRejectIfMissingClient = do liftIO $ assertBool "unexpected equal clients" (bc /= bc2) assertNoMsg wsB2 (wsAssertOtr qconv qalice ac bc cipher) - -- This test verifies basic mismatch behavior of the the JSON endpoint. postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson :: TestM () postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do @@ -524,7 +523,6 @@ postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysJson = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] - -- This test verifies basic mismatch behaviour of the protobuf endpoint. postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto :: TestM () postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do @@ -552,7 +550,6 @@ postCryptoMessageVerifyRejectMissingClientAndRespondMissingPrekeysProto = do Map.keys (userClientMap (getUserClientPrekeyMap p)) @=? [eve] Map.keys <$> Map.lookup eve (userClientMap (getUserClientPrekeyMap p)) @=? Just [ec] - -- | This test verifies behaviour when an unknown client posts the message. Only -- tests the Protobuf endpoint. postCryptoMessageNotAuthorizeUnknownClient :: TestM () @@ -593,7 +590,6 @@ postMessageClientNotInGroupDoesNotReceiveMsg = do checkEveGetsMsg checkChadDoesNotGetMsg - -- This test verifies that when a client sends a message not to all clients of a group then the server should reject the message and sent a notification to the sender (412 Missing clients). -- The test is somewhat redundant because this is already tested as part of other tests already. This is a stand alone test that solely tests the behavior described above. postMessageRejectIfMissingClients :: TestM () @@ -621,7 +617,6 @@ postMessageRejectIfMissingClients = do mkMsg :: ByteString -> (UserId, ClientId) -> (UserId, ClientId, Text) mkMsg text (uid, clientId) = (uid, clientId, toBase64Text text) - -- This test verifies behaviour under various values of ignore_missing and -- report_missing. Only tests the JSON endpoint. postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam :: TestM () @@ -679,7 +674,6 @@ postCryptoMessageVerifyCorrectResponseIfIgnoreAndReportMissingQueryParam = do where listToByteString = BS.intercalate "," . map toByteString' - -- Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message but have a missing client. It is -- expected that the message will not be sent. @@ -740,7 +734,6 @@ postMessageQualifiedLocalOwningBackendMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] - -- | Sets up a conversation on Backend A known as "owning backend". One of the -- users from Backend A will send the message, it is expected that message will -- be sent successfully. @@ -957,7 +950,6 @@ postMessageQualifiedLocalOwningBackendIgnoreMissingClients = do assertMismatchQualified mempty expectedMissing mempty mempty mempty WS.assertNoEvent (1 # Second) [wsBob, wsChad] - postMessageQualifiedLocalOwningBackendFailedToSendClients :: TestM () postMessageQualifiedLocalOwningBackendFailedToSendClients = do -- WS receive timeout @@ -1244,7 +1236,6 @@ testJoinTeamConvGuestLinksDisabled = do postJoinCodeConv bob' cCode !!! const 200 === statusCode checkFeatureStatus Public.FeatureStatusEnabled - testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do let convName = "testConversation" @@ -1322,7 +1313,6 @@ postJoinCodeConvOk = do putQualifiedAccessUpdate alice qconv noCodeAccess !!! const 200 === statusCode postJoinCodeConv dave payload !!! const 404 === statusCode - postJoinCodeConvWithPassword :: TestM () postJoinCodeConvWithPassword = do alice <- randomUser diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 11dacfcafd6..abd5bfccac8 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -187,7 +187,6 @@ getConversationsNotPartOf = do GetConversationsRequest rando [qUnqualified . cnvQualifiedId $ cnv1] liftIO $ assertEqual "conversation list not empty" [] convs - onConvCreated :: TestM () onConvCreated = do c <- view tsCannon diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index a81e48d216a..060116473e0 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -1065,7 +1065,6 @@ testDeleteTeamVerificationCodeMissingCode = do const 403 === statusCode const "code-authentication-required" === (Error.label . responseJsonUnsafeWithMsg "error label") - -- -- Test that team cannot be deleted with expired second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeExpiredCode :: TestM () @@ -1090,7 +1089,6 @@ testDeleteTeamVerificationCodeExpiredCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") - -- -- Test that team cannot be deleted with wrong second factor email verification code when this feature is enabled testDeleteTeamVerificationCodeWrongCode :: TestM () @@ -1113,7 +1111,6 @@ testDeleteTeamVerificationCodeWrongCode = do const 403 === statusCode const "code-authentication-failed" === (Error.label . responseJsonUnsafeWithMsg "error label") - setFeatureLockStatus :: forall cfg. (KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> Public.LockStatus -> TestM () setFeatureLockStatus tid status = do g <- viewGalley @@ -1457,7 +1454,6 @@ testUpdateTeamMember = do e ^. eventTeam @?= tid e ^. eventData @?= EdMemberUpdate uid mPerm - testUpdateTeamStatus :: TestM () testUpdateTeamStatus = do g <- viewGalley diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 00ad86136a5..3efe14bfc2b 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -318,7 +318,6 @@ specFinalizeLogin = do authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp2 spmeta authnreq True loginFailure =<< submitAuthnResponse tid2 authnresp - context "user is created once, then deleted in team settings, then can login again." $ do it "responds with 'allowed'" $ do (ownerid, teamid) <- callCreateUserWithTeam diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 51c50d30f68..9247594fe87 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -141,7 +141,6 @@ testCreateTokenWithVerificationCode = do call $ post (brig . paths ["verification-code", "send"] . contentJson . json (Public.SendVerificationCode action email)) - unlockFeature :: GalleyReq -> TeamId -> TestSpar () unlockFeature galley tid = call $ put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig, toByteString' Public.LockStatusUnlocked]) !!! const 200 === statusCode @@ -252,7 +251,6 @@ testCreateTokenAuthorizesOnlyAdmins = do (mkUser RoleAdmin >>= createToken') !!! const 200 === statusCode - -- | Test that for a user with a password, token creation requires reauthentication (i.e. the -- field @"password"@ should be provided). -- @@ -462,4 +460,3 @@ testAuthIsNeeded = do listUsers_ (Just invalidToken) Nothing (env ^. teSpar) !!! checkErr 401 Nothing -- Try to do @GET /Users@ without a token and check that it fails listUsers_ Nothing Nothing (env ^. teSpar) !!! checkErr 401 Nothing - From db3bd1c1837b5bdea0f0a005d01f08cab8217c3e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 7 May 2024 12:07:20 +0200 Subject: [PATCH 11/13] drive-by typo fix --- services/brig/test/integration/API/User/Account.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 0a852a7c75e..494ffecdc6e 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -878,7 +878,7 @@ testCreateUserAnonExpiry b = do let diff = diffUTCTime a now minExp = 1 :: Integer -- 1 second maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days - liftIO $ assertBool "expiry must in be the future" (diff >= fromIntegral minExp) + liftIO $ assertBool "expiry must be in the future" (diff >= fromIntegral minExp) liftIO $ assertBool "expiry must be less than 10 days" (diff < fromIntegral maxExp) expire :: ResponseLBS -> Maybe UTCTime expire r = field "expires_at" =<< responseJsonMaybe r From 081c1ba0fd3c74c9717491a72624c7d9390f6b9e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 8 May 2024 16:30:47 +0200 Subject: [PATCH 12/13] fix compiler errors. --- .../test-integration/Test/Spar/APISpec.hs | 94 ++++++++++--------- 1 file changed, 49 insertions(+), 45 deletions(-) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 3efe14bfc2b..ea777758532 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -215,7 +215,8 @@ specFinalizeLogin :: SpecWith TestEnv specFinalizeLogin = do describe "POST /sso/finalize-login" $ do context "not granted" $ do - it "testRejectsSAMLResponseSayingAccessNotGranted - responds with a very peculiar 'forbidden' HTTP response" $ do + it "testRejectsSAMLResponseSayingAccessNotGranted - responds with a very peculiar 'forbidden' HTTP response" $ + testRejectsSAMLResponseSayingAccessNotGranted context "access granted" $ do let loginSuccess :: HasCallStack => ResponseLBS -> TestSpar () @@ -381,41 +382,6 @@ specFinalizeLogin = do pending context "bad AuthnResponse" $ do - let check :: - (IdP -> TestSpar SAML.AuthnRequest) -> - (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) -> - (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) -> - (ResponseLBS -> IO ()) -> - TestSpar () - check mkareq mkaresp submitaresp checkresp = do - (ownerid, teamid) <- callCreateUserWithTeam - (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid - authnreq <- mkareq idp - spmeta <- getTestSPMetadata teamid - authnresp <- - runSimpleSP $ - mkaresp - privcreds - idp - spmeta - authnreq - sparresp <- submitaresp teamid authnresp - liftIO $ checkresp sparresp - - shouldContainInBase64 :: String -> String -> Expectation - shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle - where - Right (Just hay'') = decodeBase64 <$> validateBase64 hay' - hay' = cs $ f hay - where - -- exercise to the reader: do this more idiomatically! - f (splitAt 5 -> ("
", s)) = g s
-                  f (_ : s) = f s
-                  f "" = ""
-                  g (splitAt 6 -> ("
", _)) = "" - g (c : s) = c : g s - g "" = "" - it "testRejectsSAMLResponseFromWrongIssuer" testRejectsSAMLResponseFromWrongIssuer it "testRejectsSAMLResponseSignedWithWrongKey" testRejectsSAMLResponseSignedWithWrongKey it "testRejectsSAMLResponseIfRequestIsStale" testRejectsSAMLResponseIfRequestIsStale @@ -1696,7 +1662,7 @@ specReAuthSsoUserWithPassword = ---------------------------------------------------------------------- -- tests for bsi audit -testRejectsSAMLResponseSayingAccessNotGranted :: SpecWith TestEnv +testRejectsSAMLResponseSayingAccessNotGranted :: TestSpar () testRejectsSAMLResponseSayingAccessNotGranted = do (user, tid) <- callCreateUserWithTeam (idp, (_, privcreds)) <- registerTestIdPWithMeta user @@ -1718,7 +1684,7 @@ testRejectsSAMLResponseSayingAccessNotGranted = do hasPersistentCookieHeader sparresp `shouldBe` Left "no set-cookie header" -- Do not authenticate if SSO IdP response is for unknown issuer -testRejectsSAMLResponseFromWrongIssuer :: SpecWith Env +testRejectsSAMLResponseFromWrongIssuer :: TestSpar () testRejectsSAMLResponseFromWrongIssuer = do let mkareq = negotiateAuthnRequest mkaresp privcreds idp spmeta authnreq = @@ -1735,14 +1701,14 @@ testRejectsSAMLResponseFromWrongIssuer = do (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:not-found" (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "(CustomError (IdpDbError IdpNotFound)" (cs . fromJust . responseBody $ sparresp) `shouldContainInBase64` "Input {iName = \"SAMLResponse\"" - check + checkSamlFlow mkareq mkaresp submitaresp checkresp -- Do not authenticate if SSO IdP response is signed with wrong key -testRejectsSAMLResponseSignedWithWrongKey :: SpecWith TestEnv +testRejectsSAMLResponseSignedWithWrongKey :: TestSpar () testRejectsSAMLResponseSignedWithWrongKey = do (ownerid, _teamid) <- callCreateUserWithTeam (_, (_, badprivcreds)) <- registerTestIdPWithMeta ownerid @@ -1756,10 +1722,10 @@ testRejectsSAMLResponseSignedWithWrongKey = do True submitaresp = submitAuthnResponse checkresp sparresp = statusCode sparresp `shouldBe` 400 - check mkareq mkaresp submitaresp checkresp + checkSamlFlow mkareq mkaresp submitaresp checkresp -- Do not authenticate if SSO IdP response has no corresponding request anymore -testRejectsSAMLResponseIfRequestIsStale :: TestEnv +testRejectsSAMLResponseIfRequestIsStale :: TestSpar () testRejectsSAMLResponseIfRequestIsStale = do let mkareq idp = do req <- negotiateAuthnRequest idp @@ -1771,10 +1737,10 @@ testRejectsSAMLResponseIfRequestIsStale = do statusCode sparresp `shouldBe` 200 (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" (cs . fromJust . responseBody $ sparresp) `shouldContain` "bad InResponseTo attribute(s)" - check mkareq mkaresp submitaresp checkresp + checkSamlFlow mkareq mkaresp submitaresp checkresp -- Do not authenticate if SSO IdP response is gone missing -testRejectsSAMLResponseIfResponseIsStale :: TestEnv +testRejectsSAMLResponseIfResponseIsStale :: TestSpar () testRejectsSAMLResponseIfResponseIsStale = do let mkareq = negotiateAuthnRequest mkaresp privcreds idp spmeta authnreq = mkAuthnResponse privcreds idp spmeta authnreq True @@ -1784,4 +1750,42 @@ testRejectsSAMLResponseIfResponseIsStale = do checkresp sparresp = do statusCode sparresp `shouldBe` 200 (cs . fromJust . responseBody $ sparresp) `shouldContain` "wire:sso:error:forbidden" - check mkareq mkaresp submitaresp checkresp + checkSamlFlow mkareq mkaresp submitaresp checkresp + +---------------------------------------------------------------------- +-- Helpers + +shouldContainInBase64 :: String -> String -> Expectation +shouldContainInBase64 hay needle = cs hay'' `shouldContain` needle + where + Right (Just hay'') = decodeBase64 <$> validateBase64 hay' + hay' = cs $ f hay + where + -- exercise to the reader: do this more idiomatically! + f (splitAt 5 -> ("
", s)) = g s
+        f (_ : s) = f s
+        f "" = ""
+        g (splitAt 6 -> ("
", _)) = "" + g (c : s) = c : g s + g "" = "" + +checkSamlFlow :: + (IdP -> TestSpar SAML.AuthnRequest) -> + (SignPrivCreds -> IdP -> SAML.SPMetadata -> SAML.AuthnRequest -> SimpleSP SignedAuthnResponse) -> + (TeamId -> SignedAuthnResponse -> TestSpar (Response (Maybe LByteString))) -> + (ResponseLBS -> IO ()) -> + TestSpar () +checkSamlFlow mkareq mkaresp submitaresp checkresp = do + (ownerid, teamid) <- callCreateUserWithTeam + (idp, (_, privcreds)) <- registerTestIdPWithMeta ownerid + authnreq <- mkareq idp + spmeta <- getTestSPMetadata teamid + authnresp <- + runSimpleSP $ + mkaresp + privcreds + idp + spmeta + authnreq + sparresp <- submitaresp teamid authnresp + liftIO $ checkresp sparresp From b84bdf20e4c90a1c216f9514d9416720c95b6967 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 8 May 2024 17:42:02 +0200 Subject: [PATCH 13/13] hi ci