From 424c32bf15eb855449ac496eb62a8a1cd2d019be Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 11 Oct 2024 12:26:47 +0200 Subject: [PATCH 1/2] Make workspace cleanup retry on failure --- hedgehog-extras.cabal | 2 ++ src/Hedgehog/Extras/Test/Base.hs | 33 +++++++++++++++++++++++++------- 2 files changed, 28 insertions(+), 7 deletions(-) diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal index fb4386a9..208c5a50 100644 --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -37,6 +37,7 @@ common mtl { build-depends: mtl common network { build-depends: network } common process { build-depends: process } common resourcet { build-depends: resourcet } +common retry { build-depends: retry >= 0.9 } common stm { build-depends: stm } common tar { build-depends: tar ^>= 0.6 } common tasty { build-depends: tasty } @@ -89,6 +90,7 @@ library network, process, resourcet, + retry, stm, tar, temporary, diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs index 8cd3112f..22377c00 100644 --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -92,9 +92,9 @@ import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, un import Control.Monad.Catch (MonadCatch) import Control.Monad.Morph (hoist) import Control.Monad.Reader (MonadIO (..), MonadReader (ask)) -import Control.Monad.Trans.Resource (ReleaseKey, runResourceT) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register, runResourceT) import Data.Aeson (Result (..)) -import Data.Bool (Bool, (&&), otherwise) +import Data.Bool (Bool (..), otherwise, (&&)) import Data.Either (Either (..), either) import Data.Eq (Eq ((/=))) import Data.Foldable (for_) @@ -108,7 +108,7 @@ import Data.String (String) import Data.Time.Clock (NominalDiffTime, UTCTime) import Data.Traversable (Traversable) import Data.Tuple (snd) -import GHC.Stack (CallStack, HasCallStack) +import GHC.Stack import Hedgehog (MonadTest) import Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) import Hedgehog.Extras.Stock.CallStack (callerModuleName) @@ -123,7 +123,10 @@ import Text.Show (Show (show)) import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM +import Control.Exception (IOException) +import Control.Monad.Catch (Handler (..)) import qualified Control.Monad.Trans.Resource as IO +import qualified Control.Retry as R import qualified Data.List as L import qualified Data.Time.Clock as DTC import qualified GHC.Stack as GHC @@ -161,8 +164,14 @@ failMessage cs = failWithCustom cs Nothing -- -- The directory will be deleted if the block succeeds, but left behind if -- the block fails. -workspace :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> (FilePath -> m ()) -> m () -workspace prefixPath f = GHC.withFrozenCallStack $ do +workspace + :: MonadTest m + => HasCallStack + => MonadResource m + => 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" @@ -170,7 +179,17 @@ workspace prefixPath f = GHC.withFrozenCallStack $ do H.evalIO $ IO.writeFile (ws "module") callerModuleName f ws when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ do - H.evalIO $ IO.removePathForcibly ws + -- try to delete the directory 20 times, 100ms apart + let retryPolicy = R.constantDelay 100000 <> R.limitRetries 20 + -- retry only on IOExceptions + ioExH _ = Handler $ \(_ :: IOException) -> pure True + -- For some reason, the temporary directory removal sometimes fails. + -- Lets wrap this in MonadResource to try multiple times, during the cleanup, before we fail. + void + . register + . R.recovering retryPolicy [ioExH] + . const + $ IO.removePathForcibly ws -- | Create a workspace directory which will exist for at least the duration of -- the supplied block. @@ -182,7 +201,7 @@ workspace prefixPath f = GHC.withFrozenCallStack $ do -- the block fails. -- -- The 'prefix' argument should not contain directory delimeters. -moduleWorkspace :: (MonadTest m, MonadIO m, HasCallStack) => String -> (FilePath -> m ()) -> m () +moduleWorkspace :: (MonadTest m, MonadResource m, HasCallStack) => String -> (FilePath -> m ()) -> m () moduleWorkspace prefix f = GHC.withFrozenCallStack $ do let srcModule = maybe "UnknownModule" (GHC.srcLocModule . snd) (listToMaybe (GHC.getCallStack GHC.callStack)) workspace (prefix <> "-" <> srcModule) f From 4eeec6125111e81def6d1521243791d974ec3c52 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 11 Oct 2024 13:10:43 +0200 Subject: [PATCH 2/2] Improve error reporting when calling binaries from plan.json --- src/Hedgehog/Extras/Test/Process.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs index a273a31b..e2a8f457 100644 --- a/src/Hedgehog/Extras/Test/Process.hs +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -25,7 +25,7 @@ module Hedgehog.Extras.Test.Process , defaultExecConfig ) where -import Control.Monad (Monad (..), MonadFail (fail), void) +import Control.Monad (Monad (..), MonadFail (fail), void, unless) import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) @@ -84,14 +84,15 @@ findDefaultPlanJsonFile :: IO FilePath findDefaultPlanJsonFile = IO.getCurrentDirectory >>= go where go :: FilePath -> IO FilePath go d = do - let file = d "dist-newstyle/cache/plan.json" + let planRelPath = "dist-newstyle/cache/plan.json" + file = d planRelPath exists <- IO.doesFileExist file if exists then return file else do let parent = takeDirectory d if parent == d - then return "dist-newstyle/cache/plan.json" + then return planRelPath else go parent -- | Discover the location of the plan.json file. @@ -272,7 +273,7 @@ waitSecondsForProcess seconds hProcess = GHC.withFrozenCallStack $ do -- | Compute the path to the binary given a package name or an environment variable override. binFlex - :: (MonadTest m, MonadIO m) + :: (HasCallStack, MonadTest m, MonadIO m) => String -- ^ Package name -> String @@ -288,22 +289,26 @@ binFlex pkg binaryEnv = do -- | Consult the "plan.json" generated by cabal to get the path to the executable corresponding. -- to a haskell package. It is assumed that the project has already been configured and the -- executable has been built. +-- Throws an exception on failure. binDist - :: (MonadTest m, MonadIO m) + :: (HasCallStack, MonadTest m, MonadIO m) => String -- ^ Package name -> m FilePath -- ^ Path to executable binDist pkg = do + doesPlanExist <- liftIO $ IO.doesFileExist planJsonFile + unless doesPlanExist $ + error $ "Could not find plan.json in the path: " <> planJsonFile contents <- H.evalIO . LBS.readFile $ planJsonFile case eitherDecode contents of Right plan -> case L.filter matching (plan & installPlan) of (component:_) -> case component & binFile of Just bin -> return $ addExeSuffix (T.unpack bin) - Nothing -> error $ "missing bin-file in: " <> show component - [] -> error $ "Cannot find exe:" <> pkg <> " in plan" - Left message -> error $ "Cannot decode plan: " <> message + Nothing -> error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile + [] -> error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile + Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message where matching :: Component -> Bool matching component = case componentName component of Just name -> name == "exe:" <> T.pack pkg