Expose process related functions without a MonadTest constraint

hedgehog-extras.cabal

@@ -19,6 +19,7 @@ source-repository head
 
 common aeson                        { build-depends: aeson                            >= 2.0.0.0 && < 2.3         }
 common aeson-pretty                 { build-depends: aeson-pretty                     >= 0.8.5   && < 0.9         }
+common annotated-exception          { build-depends: annotated-exception                            < 0.4         }
 common async                        { build-depends: async                                          < 2.3         }
 common base                         { build-depends: base                             >= 4.12    && < 4.22        }
 common bytestring                   { build-depends: bytestring                                     < 0.13        }
@@ -76,6 +77,7 @@ library
   import:               base, project-config,
                         aeson-pretty,
                         aeson,
+                        annotated-exception,
                         async,
                         bytestring,
                         containers,
@@ -118,6 +120,7 @@ library
                         Hedgehog.Extras.Internal.Cli
                         Hedgehog.Extras.Internal.Orphans
                         Hedgehog.Extras.Internal.Plan
+                        Hedgehog.Extras.Internal.Process 
                         Hedgehog.Extras.Internal.Test.Integration
                         Hedgehog.Extras.Stock
                         Hedgehog.Extras.Stock.Aeson
@@ -141,6 +144,7 @@ library
                         Hedgehog.Extras.Test.Network
                         Hedgehog.Extras.Test.Prim
                         Hedgehog.Extras.Test.Process
+                        Hedgehog.Extras.Test.ProcessIO
                         Hedgehog.Extras.Test.TestWatchdog
                         Hedgehog.Extras.Test.Tripwire
                         Hedgehog.Extras.Test.Unit

src/Hedgehog/Extras/Internal/Process.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Hedgehog.Extras.Internal.Process 
+  ( binDist
+  , liftIOAnnotated
+  , planJsonFile
+  ) where
+
+import           Control.Applicative (pure, (<|>))
+import           Control.Exception.Annotated (exceptionWithCallStack)
+import           Control.Monad (Monad (..), unless)
+import           Control.Monad.Catch 
+import           Control.Monad.IO.Class (MonadIO, liftIO)
+import           Data.Aeson (eitherDecode)
+import           Data.Bool (otherwise)
+import           Data.Either (Either (..))
+import           Data.Eq (Eq (..))
+import           Data.Function (($), (.))
+import           Data.Functor ((<$>))
+import           Data.Maybe (Maybe (..))
+import           Data.Monoid ((<>))
+import           Data.String (IsString (..), String)
+import           GHC.Stack (HasCallStack)
+import           Hedgehog.Extras.Internal.Plan (Component (..), Plan (..))
+import           Prelude (error)
+import           System.FilePath (takeDirectory)
+import           System.FilePath.Posix ((</>))
+import           System.IO (FilePath, IO)
+import           Text.Show (Show (show))
+
+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.Extras.Stock.OS as OS
+import qualified System.Directory as IO
+import qualified System.Environment as IO
+import qualified System.IO.Unsafe as IO
+
+-- | 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
+  :: (HasCallStack, MonadIO m)
+  => String
+  -- ^ Package name
+  -> String
+  -- ^ Environment variable pointing to the binary to run (used for error messages only)
+  -> m FilePath
+  -- ^ Path to executable
+binDist pkg binaryEnv = do
+  doesPlanExist <- liftIOAnnotated $ IO.doesFileExist planJsonFile
+  unless doesPlanExist $
+    error $ "Could not find plan.json in the path: "
+              <> planJsonFile
+              <> ". Please run \"cabal build "
+              <> pkg
+              <> "\" if you are working with sources. Otherwise define "
+              <> binaryEnv
+              <> " and have it point to the executable you want."
+
+  Plan{installPlan} <- eitherDecode <$> liftIOAnnotated (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
+
+-- This will also catch async exceptions as well.
+liftIOAnnotated :: (HasCallStack, MonadIO m) => IO a -> m a
+liftIOAnnotated action = GHC.withFrozenCallStack $
+  liftIO $ action `catch` (\(e :: SomeException) -> throwM $ exceptionWithCallStack e)
+
+-- | Discover the location of the plan.json file.
+planJsonFile :: String
+planJsonFile = IO.unsafePerformIO $ do
+  maybeBuildDir <- liftIOAnnotated $ IO.lookupEnv "CABAL_BUILDDIR"
+  case maybeBuildDir of
+    Just buildDir -> return $ ".." </> buildDir </> "cache/plan.json"
+    Nothing -> findDefaultPlanJsonFile
+{-# NOINLINE planJsonFile #-}
+
+-- | Find the nearest plan.json going upwards from the current directory.
+findDefaultPlanJsonFile :: IO FilePath
+findDefaultPlanJsonFile = IO.getCurrentDirectory >>= go
+  where go :: FilePath -> IO FilePath
+        go d = do
+          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 planRelPath
+                else go parent
+
+addExeSuffix :: String -> String
+addExeSuffix s = if ".exe" `L.isSuffixOf` s
+  then s
+  else s <> exeSuffix
+
+
+exeSuffix :: String
+exeSuffix = if OS.isWin32 then ".exe" else ""

src/Hedgehog/Extras/Test/Concurrent.hs

@@ -60,47 +60,53 @@ Please note that only @FAIL1@ and @FAIL2@ annotations were reported - @FAIL3@ an
 below was swallowed without any information.
 
 __Don't use concurrency abstractions from this module, when you need to aggregate and report failures!__
-
 -}
-module Hedgehog.Extras.Test.Concurrent
-  ( threadDelay
-  , asyncRegister_
-  -- * Re-exports of concurrency abstractions from @lifted-base@
-  , module Control.Concurrent.Async.Lifted
-  , module Control.Concurrent.MVar.Lifted
-  , module System.Timeout.Lifted
-  ) where
+module Hedgehog.Extras.Test.Concurrent (
+    threadDelay,
+    asyncRegister_,
+
+    -- * Re-exports of concurrency abstractions from @lifted-base@
+    module Control.Concurrent.Async.Lifted,
+    module Control.Concurrent.MVar.Lifted,
+    module System.Timeout.Lifted,
+) where
 
-import           Control.Concurrent.Async.Lifted
+import Control.Concurrent.Async.Lifted
 import qualified Control.Concurrent.Lifted as IO
-import           Control.Concurrent.MVar.Lifted
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Resource
-import           Data.Function
-import           Data.Int
+import Control.Concurrent.MVar.Lifted
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
+import Data.Function
+import Data.Int
 import qualified GHC.Stack as GHC
-import           System.IO (IO)
-import           System.Timeout.Lifted
-import           Hedgehog.Extras.Internal.Orphans ()
+import Hedgehog.Extras.Internal.Orphans ()
+import System.IO (IO)
+import System.Timeout.Lifted
 
-import           Control.Monad
-import           Control.Monad.Catch (MonadCatch)
-import           GHC.Stack
-import           Hedgehog
+import Control.Monad
+import GHC.Stack
+import Hedgehog
 import qualified Hedgehog as H
 
 -- | Delay the thread by 'n' microseconds.
 threadDelay :: (HasCallStack, MonadTest m, MonadIO m) => Int -> m ()
 threadDelay n = GHC.withFrozenCallStack . H.evalIO $ IO.threadDelay n
 
 -- | Runs an action in background, and registers its cancellation to 'MonadResource'.
-asyncRegister_ :: HasCallStack
-               => MonadTest m
-               => MonadResource m
-               => MonadCatch m
-               => IO a -- ^ Action to run in background
-               -> m ()
-asyncRegister_ act = GHC.withFrozenCallStack $ void . H.evalM $ allocate (async act) cleanUp
+asyncRegister_ ::
+    (HasCallStack) =>
+    (MonadResource m) =>
+    -- | Action to run in background
+    IO a ->
+    m (ReleaseKey, Async a)
+asyncRegister_ act = GHC.withFrozenCallStack $ do
+    allocate
+        ( do
+            a <- async act
+            link a
+            return a
+        )
+        cleanUp
   where
     cleanUp :: Async a -> IO ()
-    cleanUp a = cancel a >> void (link a)
+    cleanUp = cancel