Skip to content

Commit

Permalink
Fix flaky test cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer committed Jun 6, 2024
1 parent ebc3ae3 commit a6a8f55
Show file tree
Hide file tree
Showing 2 changed files with 40 additions and 3 deletions.
4 changes: 3 additions & 1 deletion cardano-testnet/cardano-testnet.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -75,13 +75,15 @@ library
, process
, random
, resourcet
, retry
, safe-exceptions
, scientific
, si-timers
, stm
, tasty ^>= 1.5
, tasty-expected-failure
, tasty-hedgehog
, temporary
, text
, time
, transformers
Expand Down Expand Up @@ -226,7 +228,7 @@ test-suite cardano-testnet-test
, exceptions
, filepath
, hedgehog
, hedgehog-extras
, hedgehog-extras
, http-conduit
, lens-aeson
, microlens
Expand Down
39 changes: 37 additions & 2 deletions cardano-testnet/src/Testnet/Property/Util.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

Expand All @@ -15,14 +16,22 @@ module Testnet.Property.Util

import Cardano.Api

import Control.Exception.Safe
import Control.Monad
import qualified Control.Retry as R
import qualified Data.Aeson as Aeson
import GHC.Stack
import qualified System.Directory as IO
import qualified System.Environment as IO
import System.FilePath ((</>))
import System.Info (os)
import qualified System.IO as IO
import qualified System.IO.Temp as IO
import qualified System.IO.Unsafe as IO

import qualified Hedgehog as H
import qualified Hedgehog.Extras as H
import qualified Hedgehog.Extras.Stock.CallStack as H
import Hedgehog.Internal.Property (MonadTest)


Expand All @@ -43,10 +52,36 @@ integrationRetryWorkspace n workspaceName f = withFrozenCallStack $
if disableRetries
then
integration $
H.runFinallies $ H.workspace (workspaceName <> "-no-retries") f
H.runFinallies $ workspace (workspaceName <> "-no-retries") f
else
integration $ H.retry n $ \i ->
H.runFinallies $ H.workspace (workspaceName <> "-" <> show i) f
H.runFinallies $ workspace (workspaceName <> "-" <> show i) f

-- | Create a workspace directory which will exist for at least the duration of
-- the supplied block.
--
-- The directory will have the supplied prefix but contain a generated random
-- suffix to prevent interference between tests
--
-- The directory will be deleted if the block succeeds, but left behind if
-- the block fails.
-- TODO: this is a version which retries deleting of a workspace on exception - upstream to hedgehog-extras
workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m ()
workspace prefixPath f = withFrozenCallStack $ do
systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory
maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE"
ws <- H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test"
H.annotate $ "Workspace: " <> ws
H.evalIO $ IO.writeFile (ws </> "module") H.callerModuleName
f ws
when (os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do
-- try to delete the directory 5 times, 100ms apart
let retryPolicy = R.constantDelay 100_000 <> R.limitRetries 10
-- retry only on IOExceptions
ioExH _ = Handler $ \(_ :: IOException) -> pure True
-- For some reason, the temporary directory sometimes fails, lets try multiple times before we fail
H.evalIO $ R.recovering retryPolicy [ioExH] . const $
IO.removePathForcibly ws

-- | The 'FilePath' in '(FilePath -> H.Integration ())' is the work space directory.
-- This is created (and returned) via 'H.workspace'.
Expand Down

0 comments on commit a6a8f55

Please sign in to comment.