From e1a10058ff6605ecb0a1fd13d764425b2ebab0a2 Mon Sep 17 00:00:00 2001 From: Guillaume Bouchard Date: Fri, 6 Sep 2024 14:54:30 +0400 Subject: [PATCH] feat: add a 2s timeout on test diff computation Ensures that the diff computed when `shouldBe` test are failing is not taking more than 2s, otherwise do not display a diff. But this partially fix https://github.com/NorfairKing/sydtest/issues/92 in which we observed that diff can take an arbitrary amount of time, up to a few minutes or hours. This implementation uses `unsafePerformIO` for simplicity, but could be fixed in a future commit. --- sydtest-test/test/Test/Syd/TimingSpec.hs | 29 ++++++++++++++++++++++++ sydtest/default.nix | 8 +++---- sydtest/package.yaml | 3 ++- sydtest/src/Test/Syd/Output.hs | 29 ++++++++++++++++++++++-- sydtest/sydtest.cabal | 3 ++- 5 files changed, 64 insertions(+), 8 deletions(-) diff --git a/sydtest-test/test/Test/Syd/TimingSpec.hs b/sydtest-test/test/Test/Syd/TimingSpec.hs index d67106b..fd316e8 100644 --- a/sydtest-test/test/Test/Syd/TimingSpec.hs +++ b/sydtest-test/test/Test/Syd/TimingSpec.hs @@ -6,7 +6,11 @@ module Test.Syd.TimingSpec (spec) where import Control.Concurrent +import Control.Exception (try) +import Control.Monad +import GHC.IO.Exception (ExitCode) import System.IO.Unsafe +import System.Timeout (timeout) import Test.QuickCheck import Test.Syd @@ -28,6 +32,31 @@ spec = doNotRandomiseExecutionOrder $ do it "takes at least 100 milliseconds (property) " $ property $ \() -> do threadDelay 10_000 + -- Ensure that long diff timeouts + -- See https://github.com/NorfairKing/sydtest/issues/92 + it "long diff timing is bounded" $ do + -- with n = 1000 it takes 30s on my laptop, so 10k is enough to trigger the + -- 2s timeout. + let n = 10_0000 + let test = do + res <- try $ sydTest $ do + it "test" $ do + let numbers = [0, 1 .. n] + numbers' = reverse numbers + + numbers `shouldBe` numbers' + + case res of + Right () -> fail "The subtest must fail" + Left (_ :: ExitCode) -> pure () + + -- We timeout after 10s. If the test timeouts by itself, it means that the + -- diff timeout worked after 2seconds. + -- + -- Why 10s? Because it's more than 2s, and gives enough room for scheduling + -- and additional operations (such as generating the random numbers) + -- without too much risk of generating a flaky test. + timeout 10_000_000 test `shouldReturn` Just () {-# NOINLINE take10ms #-} take10ms :: IO () diff --git a/sydtest/default.nix b/sydtest/default.nix index a6532af..002542d 100644 --- a/sydtest/default.nix +++ b/sydtest/default.nix @@ -1,5 +1,5 @@ { mkDerivation, async, autodocodec, base, bytestring, containers -, dlist, fast-myers-diff, filepath, lib, MonadRandom, mtl +, deepseq, dlist, fast-myers-diff, filepath, lib, MonadRandom, mtl , opt-env-conf, path, path-io, pretty-show, QuickCheck , quickcheck-io, random, random-shuffle, safe, safe-coloured-text , safe-coloured-text-terminfo, stm, svg-builder, text, vector @@ -9,9 +9,9 @@ mkDerivation { version = "0.17.0.0"; src = ./.; libraryHaskellDepends = [ - async autodocodec base bytestring containers dlist fast-myers-diff - filepath MonadRandom mtl opt-env-conf path path-io pretty-show - QuickCheck quickcheck-io random random-shuffle safe + async autodocodec base bytestring containers deepseq dlist + fast-myers-diff filepath MonadRandom mtl opt-env-conf path path-io + pretty-show QuickCheck quickcheck-io random random-shuffle safe safe-coloured-text safe-coloured-text-terminfo stm svg-builder text vector ]; diff --git a/sydtest/package.yaml b/sydtest/package.yaml index cb8a5ff..ee679f1 100644 --- a/sydtest/package.yaml +++ b/sydtest/package.yaml @@ -29,7 +29,7 @@ library: - bytestring - containers - dlist - - fast-myers-diff + - fast-myers-diff >= 0.0.1 - filepath - mtl - opt-env-conf >=0.5 @@ -45,6 +45,7 @@ library: - svg-builder - text - vector + - deepseq when: - condition: 'os(windows)' then: diff --git a/sydtest/src/Test/Syd/Output.hs b/sydtest/src/Test/Syd/Output.hs index e1f117d..f523451 100644 --- a/sydtest/src/Test/Syd/Output.hs +++ b/sydtest/src/Test/Syd/Output.hs @@ -1,13 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumDecimals #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Test.Syd.Output where import Control.Arrow (second) +import Control.DeepSeq import Control.Exception import Data.List (sortOn) import qualified Data.List as L @@ -16,6 +19,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as M import Data.Maybe +import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as LTB @@ -23,9 +27,11 @@ import qualified Data.Text.Lazy.Builder as Text import qualified Data.Text.Lazy.IO as LTIO import qualified Data.Vector as V import Data.Word +import GHC.IO (unsafePerformIO) import GHC.Stack import Myers.Diff import Safe +import System.Timeout (timeout) import Test.QuickCheck.IO () import Test.Syd.OptParse import Test.Syd.Run @@ -463,8 +469,27 @@ splitChunksIntoLines = outputEqualityAssertionFailed :: String -> String -> [[Chunk]] outputEqualityAssertionFailed actual expected = - let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected) - -- Add a header to a list of lines of chunks + let diffM = unsafePerformIO $ do + let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected) + -- we want to evaluate the diff in order to ensure that its + -- computation happen in the timeout block + -- and is not instead later because of lazy evaluation. + -- + -- The safe option here is to evaluate to normal form with `force`. + timeout 2e6 (evaluate (force diff)) + in case diffM of + Just diff -> formatDiff actual expected diff + Nothing -> + concat + [ [[chunk "Expected these values to be equal:"]], + [[chunk "Diff computation took too long and was canceled"]], + [[fromString actual]], + [[fromString expected]] + ] + +formatDiff :: String -> String -> [PolyDiff Text Text] -> [[Chunk]] +formatDiff actual expected diff = + let -- Add a header to a list of lines of chunks chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]] chunksLinesWithHeader header = \case -- If there is only one line, put the header on that line. diff --git a/sydtest/sydtest.cabal b/sydtest/sydtest.cabal index 513a876..7287e1b 100644 --- a/sydtest/sydtest.cabal +++ b/sydtest/sydtest.cabal @@ -66,8 +66,9 @@ library , base >=4.7 && <5 , bytestring , containers + , deepseq , dlist - , fast-myers-diff + , fast-myers-diff >=0.0.1 , filepath , mtl , opt-env-conf >=0.5