Make workspace cleanup retry on failure

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,

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,16 +164,32 @@ 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"
   H.annotate $ "Workspace: " <> ws
   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

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