From 1196da5fe64ca83cbed52cae0170b5c0828a5c3b Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sun, 13 Oct 2024 21:39:33 +0300 Subject: [PATCH] [Chore] Tests: Wait for server to start In the `withServer` helper, we now use warp's beforeMainLoop callback and an MVar to synchronize threads. This makes the test suite more resilient to spurious failures on systems with slow IO. --- tests/Test/Xrefcheck/RedirectChainSpec.hs | 28 +++++++++---------- tests/Test/Xrefcheck/RedirectConfigSpec.hs | 30 ++++++++++----------- tests/Test/Xrefcheck/RedirectDefaultSpec.hs | 9 +++---- tests/Test/Xrefcheck/TimeoutSpec.hs | 12 ++++----- tests/Test/Xrefcheck/TooManyRequestsSpec.hs | 24 ++++++++--------- tests/Test/Xrefcheck/UtilRequests.hs | 28 +++++++++++++++---- 6 files changed, 73 insertions(+), 58 deletions(-) diff --git a/tests/Test/Xrefcheck/RedirectChainSpec.hs b/tests/Test/Xrefcheck/RedirectChainSpec.hs index 5a71d829..de242e89 100644 --- a/tests/Test/Xrefcheck/RedirectChainSpec.hs +++ b/tests/Test/Xrefcheck/RedirectChainSpec.hs @@ -11,7 +11,7 @@ import Control.Lens ((.~)) import Data.CaseInsensitive qualified as CI import Network.HTTP.Types (movedPermanently301) import Network.HTTP.Types.Header (HeaderName, hLocation) -import Network.Wai.Handler.Warp qualified as Web +import Network.Wai qualified as Web import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Web.Scotty qualified as Web @@ -28,7 +28,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 5) setRef - mockRedirect + (5000, mockRedirect) (link "/broken1") progress (VerifyResult [RedirectMissingLocation $ chain [ "/broken1", "/broken2", "/broken3"]]) @@ -37,7 +37,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 5) setRef - mockRedirect + (5000, mockRedirect) (link "/cycle1") progress (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]]) @@ -47,7 +47,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 1) setRef - mockRedirect + (5000, mockRedirect) (link "/relative/host") progress (VerifyResult [RedirectChainLimit $ chain ["/relative/host", "/cycle2", "/cycle3"]]) @@ -56,17 +56,17 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 1) setRef - mockRedirect + (5000, mockRedirect) (link "/relative/path") progress (VerifyResult [RedirectChainLimit $ chain ["/relative/path", "/relative/host", "/cycle2"]]) ] - , testCase "Other host redirect" $ withServer otherMockRedirect $ do + , testCase "Other host redirect" $ withServer (5001, otherMockRedirect) $ do setRef <- newIORef mempty checkLinkAndProgressWithServer (configMod 1) setRef - mockRedirect + (5000, mockRedirect) "http://127.0.0.1:5001/other/host" progress (VerifyResult [RedirectChainLimit $ fromList ["http://127.0.0.1:5001/other/host", link "/relative/host", link "/cycle2"]]) @@ -76,7 +76,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 2) setRef - mockRedirect + (5000, mockRedirect) (link "/cycle1") progress (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4"]]) @@ -85,7 +85,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod 0) setRef - mockRedirect + (5000, mockRedirect) (link "/cycle1") progress (VerifyResult [RedirectChainLimit $ chain ["/cycle1", "/cycle2"]]) @@ -94,7 +94,7 @@ test_redirectRequests = testGroup "Redirect chain tests" checkLinkAndProgressWithServer (configMod (-1)) setRef - mockRedirect + (5000, mockRedirect) (link "/cycle1") progress (VerifyResult [RedirectChainCycle $ chain ["/cycle1", "/cycle2", "/cycle3", "/cycle4", "/cycle2"]]) @@ -118,9 +118,9 @@ test_redirectRequests = testGroup "Redirect chain tests" setHeader :: HeaderName -> Text -> Web.ActionM () setHeader hdr value = Web.setHeader (decodeUtf8 (CI.original hdr)) (fromStrict value) - mockRedirect :: IO () + mockRedirect :: IO Web.Application mockRedirect = do - Web.run 5000 <=< Web.scottyApp $ do + Web.scottyApp $ do -- A set of redirect routes that correspond to a broken chain. Web.matchAny "/broken1" $ do setHeader hLocation (link "/broken2") @@ -155,8 +155,8 @@ test_redirectRequests = testGroup "Redirect chain tests" Web.status movedPermanently301 -- To other host - otherMockRedirect :: IO () + otherMockRedirect :: IO Web.Application otherMockRedirect = - Web.run 5001 <=< Web.scottyApp $ Web.matchAny "/other/host" $ do + Web.scottyApp $ Web.matchAny "/other/host" $ do setHeader hLocation (link "/relative/host") Web.status movedPermanently301 diff --git a/tests/Test/Xrefcheck/RedirectConfigSpec.hs b/tests/Test/Xrefcheck/RedirectConfigSpec.hs index cfad57ad..9f34dfd3 100644 --- a/tests/Test/Xrefcheck/RedirectConfigSpec.hs +++ b/tests/Test/Xrefcheck/RedirectConfigSpec.hs @@ -11,7 +11,7 @@ import Control.Lens ((%~), (.~)) import Data.CaseInsensitive qualified as CI import Network.HTTP.Types (found302, movedPermanently301, temporaryRedirect307) import Network.HTTP.Types.Header (HeaderName, hLocation) -import Network.Wai.Handler.Warp qualified as Web +import Network.Wai qualified as Web import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Text.Regex.TDFA.Text qualified as R @@ -32,7 +32,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing (Just RROTemporary) RROInvalid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/temporary-redirect") (progress False) (VerifyResult [RedirectRuleError (chain ["/temporary-redirect", "/ok"]) (Just RROTemporary)]) @@ -41,7 +41,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing (Just RROPermanent) RROInvalid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/temporary-redirect") (progress True) (VerifyResult []) @@ -52,7 +52,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing (regex ".*/ok") Nothing RROValid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/permanent-redirect") (progress True) (VerifyResult []) @@ -61,7 +61,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing (regex ".*/no-ok") (Just RROPermanent) RROValid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/permanent-redirect") (progress False) (VerifyResult [RedirectRuleError (chain ["/permanent-redirect", "/ok"]) (Just RROPermanent)]) @@ -72,7 +72,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule (regex ".*/permanent-.*") Nothing Nothing RROValid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/permanent-redirect") (progress True) (VerifyResult []) @@ -81,7 +81,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule (regex ".*/temporary-.*") Nothing (Just RROPermanent) RROValid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/permanent-redirect") (progress False) (VerifyResult [RedirectRuleError (chain ["/permanent-redirect", "/ok"]) (Just RROPermanent)]) @@ -92,7 +92,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule (regex ".*/follow[0-9]") (regex "^.*/ok$") (Just (RROCode 307)) RROInvalid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/follow3") (progress False) (VerifyResult [RedirectRuleError (chain ["/follow3", "/ok"]) (Just (RROCode 307))]) @@ -101,7 +101,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule (regex ".*/follow[0-9]") (regex "^.*/ok$") (Just (RROCode 307)) RROInvalid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/follow2") (progress True) (VerifyResult []) @@ -111,7 +111,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing Nothing RROValid] []) setRef - mockRedirect + (5000, mockRedirect) (link "/follow1") (progress True) (VerifyResult []) @@ -122,7 +122,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing Nothing RROFollow] []) setRef - mockRedirect + (5000, mockRedirect) (link "/follow1") (progress True) (VerifyResult []) @@ -131,7 +131,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing (Just (RROCode 307)) RROInvalid, RedirectRule Nothing Nothing Nothing RROFollow] []) setRef - mockRedirect + (5000, mockRedirect) (link "/follow1") (progress False) (VerifyResult [RedirectRuleError (chain ["/follow1", "/follow2", "/follow3", "/ok"]) (Just (RROCode 307))]) @@ -140,7 +140,7 @@ test_redirectRequests = testGroup "Redirect config tests" checkLinkAndProgressWithServer (configMod [RedirectRule Nothing Nothing (Just (RROCode 307)) RROInvalid, RedirectRule Nothing Nothing Nothing RROFollow] (maybeToList (regex ".*/follow3"))) setRef - mockRedirect + (5000, mockRedirect) (link "/follow1") (progress True) (VerifyResult []) @@ -172,9 +172,9 @@ test_redirectRequests = testGroup "Redirect config tests" then reportSuccess else reportError - mockRedirect :: IO () + mockRedirect :: IO Web.Application mockRedirect = - Web.run 5000 <=< Web.scottyApp $ do + Web.scottyApp $ do Web.matchAny "/ok" $ Web.raw "Ok" Web.matchAny "/permanent-redirect" $ do setHeader hLocation "/ok" diff --git a/tests/Test/Xrefcheck/RedirectDefaultSpec.hs b/tests/Test/Xrefcheck/RedirectDefaultSpec.hs index 5184d0a0..4a6f290b 100644 --- a/tests/Test/Xrefcheck/RedirectDefaultSpec.hs +++ b/tests/Test/Xrefcheck/RedirectDefaultSpec.hs @@ -11,7 +11,7 @@ import Data.CaseInsensitive qualified as CI import Data.Set qualified as S import Network.HTTP.Types (Status, mkStatus) import Network.HTTP.Types.Header (HeaderName, hLocation) -import Network.Wai.Handler.Warp qualified as Web +import Network.Wai qualified as Web import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase) import Web.Scotty qualified as Web @@ -69,17 +69,16 @@ test_redirectRequests = testGroup "Redirect response defaults" setRef <- newIORef S.empty checkLinkAndProgressWithServerDefault setRef - (mockRedirect expectedLocation expectedStatus) + (5000, mockRedirect expectedLocation expectedStatus) url ( (if isNothing expectedError then reportSuccess else reportError) "" $ initProgress 1 ) (VerifyResult $ maybeToList expectedError) - mockRedirect :: Maybe Text -> Status -> IO () + mockRedirect :: Maybe Text -> Status -> IO Web.Application mockRedirect expectedLocation expectedStatus = - Web.run 5000 <=< Web.scottyApp $ - Web.matchAny "/redirect" $ do + Web.scottyApp $ Web.matchAny "/redirect" $ do whenJust expectedLocation (setHeader hLocation) Web.status expectedStatus diff --git a/tests/Test/Xrefcheck/TimeoutSpec.hs b/tests/Test/Xrefcheck/TimeoutSpec.hs index 1ab08fcb..3f32359f 100644 --- a/tests/Test/Xrefcheck/TimeoutSpec.hs +++ b/tests/Test/Xrefcheck/TimeoutSpec.hs @@ -12,7 +12,7 @@ import Data.CaseInsensitive qualified as CI import Data.Set qualified as S import Network.HTTP.Types (ok200, tooManyRequests429) import Network.HTTP.Types.Header (HeaderName, hRetryAfter) -import Network.Wai.Handler.Warp qualified as Web +import Network.Wai qualified as Web import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import Time (Second, Time, sec, threadDelay) @@ -49,7 +49,7 @@ test_timeout = testGroup "Timeout tests" , testCase "Fails on timeout if another domain returned 429" $ do setRef <- newIORef S.empty checkMultipleLinksWithServer - (mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) + (5000, mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) setRef [ VerifyLinkTestEntry { vlteConfigModifier = \c -> c @@ -73,7 +73,7 @@ test_timeout = testGroup "Timeout tests" , testCase "Succeeds on timeout if another path of this domain returned 429" $ do setRef <- newIORef S.empty checkMultipleLinksWithServer - (mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) + (5000, mockTimeout (sec 0.4) [Respond429, Ok, Delay, Delay]) setRef [ VerifyLinkTestEntry { vlteConfigModifier = \c -> c @@ -111,7 +111,7 @@ test_timeout = testGroup "Timeout tests" & setAllowedTimeout & configModifier) setRef - (mockTimeout (sec 0.4) mockResponses) + (5000, mockTimeout (sec 0.4) mockResponses) "http://127.0.0.1:5000/timeout" prog $ VerifyResult $ [ExternalHttpTimeout $ Just (DomainName "127.0.0.1") | not shouldSucceed] @@ -119,10 +119,10 @@ test_timeout = testGroup "Timeout tests" -- When called for the first (N-1) times, waits for specified -- amount of seconds and returns an arbitrary result. -- When called N time returns the result immediately. - mockTimeout :: Time Second -> [MockTimeoutBehaviour] -> IO () + mockTimeout :: Time Second -> [MockTimeoutBehaviour] -> IO Web.Application mockTimeout timeout behList = do ref <- newIORef @_ behList - Web.run 5000 <=< Web.scottyApp $ do + Web.scottyApp $ do Web.matchAny "/timeout" $ handler ref Web.matchAny "/timeoutother" $ handler ref where diff --git a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs index 806f0cef..a21b6411 100644 --- a/tests/Test/Xrefcheck/TooManyRequestsSpec.hs +++ b/tests/Test/Xrefcheck/TooManyRequestsSpec.hs @@ -7,8 +7,6 @@ module Test.Xrefcheck.TooManyRequestsSpec where import Universum -import Control.Concurrent (forkIO, killThread) -import Control.Exception qualified as E import Data.CaseInsensitive qualified as CI import Data.Set qualified as S import Data.Time (addUTCTime, defaultTimeLocale, formatTime, getCurrentTime, rfc822DateFormat) @@ -16,7 +14,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Network.HTTP.Types (Status (..), ok200, serviceUnavailable503, tooManyRequests429) import Network.HTTP.Types.Header (HeaderName, hRetryAfter) import Network.Wai (requestMethod) -import Network.Wai.Handler.Warp qualified as Web +import Network.Wai qualified as Web import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import Time (sec, (-:-)) @@ -33,18 +31,18 @@ test_tooManyRequests = testGroup "429 response tests" [ testCase "Returns 200 eventually" $ do setRef <- newIORef S.empty let prog = reportSuccess "" $ initProgress 1 - checkLinkAndProgressWithServerDefault setRef (mock429 "1" ok200) + checkLinkAndProgressWithServerDefault setRef (5000, mock429 "1" ok200) "http://127.0.0.1:5000/429" prog $ VerifyResult [] , testCase "Returns 503 eventually" $ do setRef <- newIORef S.empty let prog = reportError "" $ initProgress 1 - checkLinkAndProgressWithServerDefault setRef (mock429 "1" serviceUnavailable503) + checkLinkAndProgressWithServerDefault setRef (5000, mock429 "1" serviceUnavailable503) "http://127.0.0.1:5000/429" prog $ VerifyResult [ ExternalHttpResourceUnavailable $ Status { statusCode = 503, statusMessage = "Service Unavailable"} ] , testCase "Successfully updates the new retry-after value (as seconds)" $ do - E.bracket (forkIO $ mock429 "2" ok200) killThread $ \_ -> do + withServer (5000, mock429 "2" ok200) $ do now <- getPOSIXTime <&> posixTimeToTimeSecond setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress @@ -68,7 +66,7 @@ test_tooManyRequests = testGroup "429 response tests" -- Set the @Retry-After@ response header value as (current datetime + 4 seconds) retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime 4 utctime) now = utcTimeToTimeSecond utctime - E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do + withServer (5000, mock429 (fromString retryAfter) ok200) $ do setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress { vrLocal = initProgress 0 @@ -92,7 +90,7 @@ test_tooManyRequests = testGroup "429 response tests" -- Set the @Retry-After@ response header value as (current datetime - 4 seconds) retryAfter = formatTime defaultTimeLocale rfc822DateFormat (addUTCTime (-4) utctime) now = utcTimeToTimeSecond utctime - E.bracket (forkIO $ mock429 (fromString retryAfter) ok200) killThread $ \_ -> do + withServer (5000, mock429 (fromString retryAfter) ok200) $ do setRef <- newIORef S.empty progressRef <- newIORef VerifyProgress { vrLocal = initProgress 0 @@ -111,10 +109,10 @@ test_tooManyRequests = testGroup "429 response tests" ", but instead it's " ++ show ttc , testCase "The GET request should not be attempted after catching a 429" $ do let - mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO () + mock429WithGlobalIORef :: IORef [(Text, Status)] -> IO Web.Application mock429WithGlobalIORef infoReverseAccumulatorRef = do callCountRef <- newIORef @_ @Int 0 - Web.run 5000 <=< Web.scottyApp $ + Web.scottyApp $ Web.matchAny "/429grandfinale" $ do req <- Web.request let m = decodeUtf8 (requestMethod req) @@ -135,7 +133,7 @@ test_tooManyRequests = testGroup "429 response tests" | otherwise -> Web.status serviceUnavailable503 infoReverseAccumulatorRef <- newIORef [] setRef <- newIORef S.empty - E.bracket (forkIO $ mock429WithGlobalIORef infoReverseAccumulatorRef) killThread $ \_ -> do + withServer (5000, mock429WithGlobalIORef infoReverseAccumulatorRef) $ do _ <- verifyLinkDefault setRef "http://127.0.0.1:5000/429grandfinale" infoReverseAccumulator <- readIORef infoReverseAccumulatorRef reverse infoReverseAccumulator @?= @@ -147,10 +145,10 @@ test_tooManyRequests = testGroup "429 response tests" where -- When called for the first time, returns with a 429 and `Retry-After: @retryAfter@`. -- Subsequent calls will respond with @status@. - mock429 :: Text -> Status -> IO () + mock429 :: Text -> Status -> IO Web.Application mock429 retryAfter status = do callCountRef <- newIORef @_ @Int 0 - Web.run 5000 <=< Web.scottyApp $ + Web.scottyApp $ Web.matchAny "/429" $ do callCount <- atomicModifyIORef' callCountRef $ \cc -> (cc + 1, cc) if callCount == 0 diff --git a/tests/Test/Xrefcheck/UtilRequests.hs b/tests/Test/Xrefcheck/UtilRequests.hs index f1a8d1a5..d2139d07 100644 --- a/tests/Test/Xrefcheck/UtilRequests.hs +++ b/tests/Test/Xrefcheck/UtilRequests.hs @@ -22,6 +22,8 @@ import Control.Exception qualified as E import Control.Lens ((.~)) import Data.Map qualified as M import Data.Set qualified as S +import Network.Wai qualified as Web +import Network.Wai.Handler.Warp qualified as Web import Test.Tasty.HUnit (assertBool) import Text.Interpolation.Nyan @@ -33,11 +35,27 @@ import Xrefcheck.System import Xrefcheck.Util import Xrefcheck.Verify -withServer :: IO () -> IO () -> IO () -withServer mock = E.bracket (forkIO mock) killThread . const +withServer :: (Int, IO Web.Application) -> IO () -> IO () +withServer (port, createApp) act = do + app <- createApp + ready :: MVar () <- newEmptyMVar + -- In the forked thread: the server puts () as soon as it's ready to process requests. + -- In the current therad: wait for () before running the action. + -- + -- This ensures that we don't encounter this error: + -- ConnectionFailure Network.Socket.connect: : does not exist (Connection refused) + E.bracket (serve ready app) killThread (\_ -> takeMVar ready >> act) + where + serve ready app = + forkIO $ Web.runSettings settings app + where + settings = + Web.setBeforeMainLoop (putMVar ready ()) $ + Web.setPort port $ + Web.defaultSettings checkMultipleLinksWithServer - :: IO () + :: (Int, IO Web.Application) -> IORef (S.Set DomainName) -> [VerifyLinkTestEntry] -> IO () @@ -54,7 +72,7 @@ checkMultipleLinksWithServer mock setRef entries = checkLinkAndProgressWithServer :: (Config -> Config) -> IORef (Set DomainName) - -> IO () + -> (Int, IO Web.Application) -> Text -> Progress Int Text -> VerifyResult VerifyError @@ -89,7 +107,7 @@ checkLinkAndProgress configModifier setRef link progress vrExpectation = do checkLinkAndProgressWithServerDefault :: IORef (Set DomainName) - -> IO () + -> (Int, IO Web.Application) -> Text -> Progress Int Text -> VerifyResult VerifyError