hedgehog-extras 0.8.0.0 → 0.9.0.0

raw patch · 5 files changed

+124/−63 lines, 5 filesdep −retryPVP ok

version bump matches the API change (PVP)

Dependencies removed: retry

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +1/−2
• src/Hedgehog/Extras/Internal/Plan.hs +17/−3
• src/Hedgehog/Extras/Test/Base.hs +47/−26
• src/Hedgehog/Extras/Test/Process.hs +27/−16
• src/Hedgehog/Extras/Test/TestWatchdog.hs +32/−16

@@ -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,

@@ -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{..}+

@@ -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

@@ -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,

@@ -95,24 +95,40 @@   kickWatchdog watchdog   pure watchdog +getCallerLocation :: HasCallStack => String+getCallerLocation =+  case getCallStack callStack of+    (_funcName, _) : (_callerName, callerLoc) : _ ->+      srcLocFile callerLoc ++ ":" ++ show (srcLocStartLine callerLoc)+    _ -> "<no call stack>"+ -- | 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