diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -99,7 +99,6 @@ network, process, resourcet, - retry, stm, tar, tasty, diff --git a/src/Hedgehog/Extras/Internal/Plan.hs b/src/Hedgehog/Extras/Internal/Plan.hs --- a/src/Hedgehog/Extras/Internal/Plan.hs +++ b/src/Hedgehog/Extras/Internal/Plan.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} module Hedgehog.Extras.Internal.Plan ( Plan(..) @@ -7,7 +9,10 @@ ) where import Control.Applicative +import Control.Monad import Data.Aeson +import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as M import Data.Eq import Data.Function import Data.Maybe @@ -18,6 +23,7 @@ data Component = Component { componentName :: Maybe Text , binFile :: Maybe Text + , components :: [Component] } deriving (Generic, Eq, Show) @@ -31,6 +37,14 @@ <$> v .: "install-plan" instance FromJSON Component where - parseJSON = withObject "Plan" $ \v -> Component - <$> v .:? "component-name" - <*> v .:? "bin-file" + parseJSON = withObject "Plan" $ \v -> do + componentName <- v .:? "component-name" + binFile <- v .:? "bin-file" + componentsTuples <- join . maybeToList . fmap M.toAscList <$> v .:? "components" + -- sub-components are an object with components name as a key + components <- forM componentsTuples $ \(subComponentName, subComponent) -> + parseJSON $ + A.Object $ + M.insert "component-name" (toJSON subComponentName) subComponent + pure Component{..} + diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -98,13 +98,13 @@ import Control.Applicative (Applicative (..)) import Control.Exception (IOException) -import Control.Exception.Lifted (bracket, bracket_) +import Control.Exception.Lifted (bracket, bracket_, try) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when) -import Control.Monad.Catch (Handler (..), MonadCatch) +import Control.Monad.Catch (MonadCatch) import Control.Monad.Morph (hoist) import Control.Monad.Reader (MonadIO (..), MonadReader (ask)) -import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register, runResourceT) +import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, runResourceT) import Data.Aeson (Result (..)) import Data.Bool (Bool (..), otherwise, (&&)) import Data.Either (Either (..), either) @@ -135,7 +135,6 @@ import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM 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 @@ -181,32 +180,47 @@ -- The directory will be deleted if the block succeeds, but left behind if -- the block fails. workspace - :: MonadTest m - => HasCallStack + :: HasCallStack + => MonadBaseControl IO m => MonadResource m + => MonadTest 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 - -- 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 +workspace prefixPath f = + withFrozenCallStack $ + bracket init fini $ \ws -> do + H.annotate $ "Workspace: " <> ws + H.evalIO $ IO.writeFile (ws "module") callerModuleName + f ws + where + init = do + systemTemp <- H.evalIO IO.getCanonicalTemporaryDirectory + H.evalIO $ IO.createTempDirectory systemTemp $ prefixPath <> "-test" + fini ws = do + maybeKeepWorkspace <- H.evalIO $ IO.lookupEnv "KEEP_WORKSPACE" + when (IO.os /= "mingw32" && maybeKeepWorkspace /= Just "1") $ + removeWorkspaceRetries ws 20 + removeWorkspaceRetries + :: MonadBaseControl IO m + => MonadResource m + => MonadTest m + => FilePath + -> Int + -> m () + removeWorkspaceRetries ws retries = GHC.withFrozenCallStack $ do + result <- try (liftIO (IO.removePathForcibly ws)) + case result of + Right () -> return () + Left (_ :: IOException) -> do + if retries > 0 + then do + liftIO (IO.threadDelay 100000) -- wait 100ms before retrying + removeWorkspaceRetries ws (retries - 1) + else do + failMessage GHC.callStack "Failed to remove workspace directory after multiple attempts" + -- | Create a workspace directory which will exist for at least the duration of -- the supplied block. -- @@ -217,7 +231,14 @@ -- the block fails. -- -- The 'prefix' argument should not contain directory delimeters. -moduleWorkspace :: (MonadTest m, MonadResource m, HasCallStack) => String -> (FilePath -> m ()) -> m () +moduleWorkspace + :: HasCallStack + => MonadBaseControl IO m + => MonadResource m + => MonadTest m + => 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 diff --git a/src/Hedgehog/Extras/Test/Process.hs b/src/Hedgehog/Extras/Test/Process.hs --- a/src/Hedgehog/Extras/Test/Process.hs +++ b/src/Hedgehog/Extras/Test/Process.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -25,20 +27,21 @@ , defaultExecConfig ) where -import Control.Monad (Monad (..), MonadFail (fail), void, unless) +import Control.Applicative (pure, (<|>)) +import Control.Monad (Monad (..), MonadFail (fail), unless, void) import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, ReleaseKey, register) import Data.Aeson (eitherDecode) -import Data.Bool (Bool (..)) +import Data.Bool (Bool (True), otherwise) import Data.Either (Either (..)) import Data.Eq (Eq (..)) -import Data.Function (($), (&), (.)) +import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (Maybe (..)) import Data.Monoid (Last (..), mempty, (<>)) -import Data.String (String) +import Data.String (IsString (..), String) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Hedgehog (MonadTest) @@ -55,6 +58,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L +import Data.Text (Text) import qualified Data.Text as T import qualified GHC.Stack as GHC import qualified Hedgehog as H @@ -308,19 +312,26 @@ <> "\" if you are working with sources. Otherwise define " <> binaryEnv <> " and have it point to the executable you want." - 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\" 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 - Nothing -> False + Plan{installPlan} <- eitherDecode <$> H.evalIO (LBS.readFile planJsonFile) + >>= \case + Left message -> error $ "Cannot decode plan in " <> planJsonFile <> ": " <> message + Right plan -> pure plan + + let componentName = "exe:" <> fromString pkg + case findComponent componentName installPlan of + Just Component{binFile=Just binFilePath} -> pure . addExeSuffix $ T.unpack binFilePath + Just component@Component{binFile=Nothing} -> + error $ "missing \"bin-file\" key in plan component: " <> show component <> " in the plan in: " <> planJsonFile + Nothing -> + error $ "Cannot find \"component-name\" key with the value \"exe:" <> pkg <> "\" in the plan in: " <> planJsonFile + where + findComponent :: Text -> [Component] -> Maybe Component + findComponent _ [] = Nothing + findComponent needle (c@Component{componentName, components}:topLevelComponents) + | componentName == Just needle = Just c + | otherwise = findComponent needle topLevelComponents <|> findComponent needle components + -- | Create a 'CreateProcess' describing how to start a process given the Cabal package name -- corresponding to the executable, an environment variable pointing to the executable, diff --git a/src/Hedgehog/Extras/Test/TestWatchdog.hs b/src/Hedgehog/Extras/Test/TestWatchdog.hs --- a/src/Hedgehog/Extras/Test/TestWatchdog.hs +++ b/src/Hedgehog/Extras/Test/TestWatchdog.hs @@ -95,24 +95,40 @@ kickWatchdog watchdog pure watchdog +getCallerLocation :: HasCallStack => String +getCallerLocation = + case getCallStack callStack of + (_funcName, _) : (_callerName, callerLoc) : _ -> + srcLocFile callerLoc ++ ":" ++ show (srcLocStartLine callerLoc) + _ -> "" + -- | Run watchdog in a loop in the current thread. Usually this function should be used with 'H.withAsync' -- to run it in the background. -runWatchdog :: MonadBase IO m - => Watchdog - -> m () -runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} = liftBase $ do - atomically (tryReadTChan kickChan) >>= \case - Just PoisonPill -> - -- deactivate watchdog - pure () - Just (Kick timeout) -> do - -- got a kick, wait for another period - threadDelay $ timeout * 1_000_000 - runWatchdog w - Nothing -> do - -- we are out of scheduled timeouts, kill the monitored thread - currentTime <- getCurrentTime - throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime +runWatchdog + :: HasCallStack + => MonadBase IO m + => Watchdog + -> m () +runWatchdog w@Watchdog{watchedThreadId, startTime, kickChan} = + withFrozenCallStack $ liftBase $ do + atomically (tryReadTChan kickChan) >>= \case + Just PoisonPill -> + -- deactivate watchdog + pure () + Just (Kick timeout) -> do + -- got a kick, wait for another period + threadDelay $ timeout * 1_000_000 + runWatchdog w + Nothing -> do + -- we are out of scheduled timeouts, kill the monitored thread + currentTime <- getCurrentTime + liftIO $ appendFile "/tmp/watchdog.log" $ mconcat + [ "Watchdog: killing thread " <> show watchedThreadId + , " after " <> show (diffUTCTime currentTime startTime) + , "at " <> getCallerLocation + , "\n" + ] + throwTo watchedThreadId . WatchdogException $ diffUTCTime currentTime startTime -- | Watchdog command data WatchdogCommand