hw-polysemy 0.2.0.0 → 0.2.1.0

raw patch · 17 files changed

+1054/−6 lines, 17 filesdep +aesondep +asyncdep +generic-lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, async, generic-lens, lens, network, resourcet, unliftio, yaml

API changes (from Hackage documentation)

Files

• core/HaskellWorks/IO/Network.hs +9/−0
• core/HaskellWorks/IO/Network/NamedPipe.hs +24/−0
• core/HaskellWorks/IO/Network/Port.hs +57/−0
• core/HaskellWorks/IO/Network/Socket.hs +73/−0
• core/HaskellWorks/IO/Process.hs +24/−0
• core/HaskellWorks/IO/Win32/NamedPipe.hsc +71/−0
• core/HaskellWorks/Polysemy/Cabal.hs +85/−0
• core/HaskellWorks/Polysemy/Cabal/Types.hs +36/−0
• core/HaskellWorks/Polysemy/Error/Types.hs +14/−0
• core/HaskellWorks/Polysemy/File.hs +61/−0
• core/HaskellWorks/Polysemy/FilePath.hs +17/−0
• core/HaskellWorks/Polysemy/OS.hs +12/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Assert.hs +224/−1
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Process.hs +266/−0
• hedgehog/HaskellWorks/Polysemy/Hedgehog/Process/Internal.hs +28/−0
• hw-polysemy.cabal +52/−4
• test/HaskellWorks/Polysemy/HedgehogSpec.hs +1/−1

@@ -0,0 +1,9 @@+module HaskellWorks.IO.Network+  ( doesNamedPipeExist,+    randomPort,+    reserveRandomPort,+    portInUse,+  ) where++import           HaskellWorks.IO.Network.NamedPipe+import           HaskellWorks.IO.Network.Port

@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}++module HaskellWorks.IO.Network.NamedPipe+  ( doesNamedPipeExist+  ) where++import           Data.Bool+import           Prelude (error)+import           System.IO (FilePath, IO)++#ifdef mingw32_HOST_OS+import qualified Hedgehog.Extras.Internal.Win32.NamedPipes as W32+#endif++doesNamedPipeExist :: FilePath -> IO Bool+doesNamedPipeExist path =+#ifdef mingw32_HOST_OS+  W32.waitNamedPipe path 1+#else+  error "doesNamedPipeExist may only be called on Windows"+#endif

@@ -0,0 +1,57 @@+{-# LANGUAGE TypeApplications #-}++module HaskellWorks.IO.Network.Port+  ( randomPort+  , reserveRandomPort+  , portInUse+  ) where++import           Control.Exception+import           Control.Monad                (Monad (..), MonadFail (..))+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Resource+import           Data.Bool+import           Data.Either+import           Data.Function+import           Network.Socket++-- | Return a random available port on a specified host address+randomPort :: ()+  => MonadIO m+  => MonadFail m+  => HostAddress+  -> m PortNumber+randomPort hostAddress = do+  sock <- liftIO $ socket AF_INET Stream defaultProtocol+  -- Allow the port to be reused immediately after the socket is closed+  liftIO $ setSocketOption sock ReuseAddr 1+  liftIO $ bind sock $ SockAddrInet defaultPort hostAddress+  SockAddrInet port _ <- liftIO $ getSocketName sock+  liftIO $ close sock+  return port++reserveRandomPort :: ()+  => MonadFail m+  => MonadResource m+  => HostAddress+  -> m (ReleaseKey, PortNumber)+reserveRandomPort hostAddress = do+  sock <- liftIO $ socket AF_INET Stream defaultProtocol+  liftIO $ setSocketOption sock ReuseAddr 1+  liftIO $ bind sock $ SockAddrInet defaultPort hostAddress+  SockAddrInet port _ <- liftIO $ getSocketName sock+  releaseKey <- register $ close sock+  return (releaseKey, port)++-- | Check if a port is in use on a specified host address+portInUse :: ()+  => MonadIO m+  => HostAddress+  -> PortNumber+  -> m Bool+portInUse hostAddress pn = do+  sock <- liftIO $ socket AF_INET Stream defaultProtocol+  liftIO $ setSocketOption sock ReuseAddr 1+  result <- liftIO $ try @SomeException $ bind sock (SockAddrInet pn hostAddress)+  liftIO $ close sock+  return $ either (const False) (const True) result

@@ -0,0 +1,73 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module HaskellWorks.IO.Network.Socket+  ( doesSocketExist+  , isPortOpen+  , canConnect+  , listenOn+  , allocateRandomPorts+  ) where++import           Control.Exception  (IOException, handle)+import           Control.Monad+import           Data.Bool+import           Data.Function+import           Data.Functor+import           Data.Int+import           Data.Maybe+import           Network.Socket     (Family (AF_INET), SockAddr (..), Socket,+                                     SocketType (Stream))+import           Prelude            (fromIntegral)+import           System.IO          (FilePath, IO)+import           Text.Show          (show)++import qualified Network.Socket     as IO+import qualified System.Directory   as IO+import qualified UnliftIO.Exception as IO++-- | Check if a TCP port is open+isPortOpen :: Int -> IO Bool+isPortOpen port = do+  socketAddressInfos <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))+  case socketAddressInfos of+    socketAddressInfo:_ ->+      handle (return . const @Bool @IOException False) $+        canConnect (IO.addrAddress socketAddressInfo) $> True+    [] -> return False++-- | Check if it is possible to connect to a socket address+canConnect :: SockAddr -> IO ()+canConnect sockAddr = IO.bracket (IO.socket AF_INET Stream 6) IO.close' $ \sock -> do+  IO.connect sock sockAddr++-- | Open a socket at the specified port for listening+listenOn :: Int -> IO Socket+listenOn n = do+  sock <- IO.socket AF_INET Stream 0+  sockAddrInfo:_ <- IO.getAddrInfo Nothing (Just "127.0.0.1") (Just (show n))+  IO.setSocketOption sock IO.ReuseAddr 1+  IO.bind sock (IO.addrAddress sockAddrInfo)+  IO.listen sock 2+  return sock++doesSocketExist :: FilePath -> IO Bool+doesSocketExist = IO.doesFileExist+{-# INLINE doesSocketExist #-}++-- | Allocate the specified number of random ports+allocateRandomPorts :: Int -> IO [Int]+allocateRandomPorts n = do+  let hints = IO.defaultHints+        { IO.addrFlags = [IO.AI_PASSIVE]+        , IO.addrSocketType = IO.Stream+        }++  -- Create n sockets with randomly bound ports, grab the port numbers and close those ports+  addr:_ <- IO.getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0")+  socks <- forM [1..n] $ \_ -> IO.socket (IO.addrFamily addr) (IO.addrSocketType addr) (IO.addrProtocol addr)+  forM_ socks $ \sock -> IO.bind sock (IO.addrAddress addr)+  ports <- forM socks IO.socketPort+  forM_ socks IO.close++  return $ fmap fromIntegral ports

@@ -0,0 +1,24 @@+module HaskellWorks.IO.Process+  ( maybeWaitForProcess+  ) where++import qualified Control.Concurrent       as IO+import           Control.Concurrent.Async+import qualified Control.Concurrent.Async as IO+import qualified Control.Exception        as IO+import           Data.Maybe+import           System.Exit+import           System.IO+import qualified System.Process           as IO++import           Control.Applicative+import           Data.Function+import           Data.Functor+import           GHC.Stack                (HasCallStack, withFrozenCallStack)+import           System.Process++maybeWaitForProcess :: ()+  => ProcessHandle+  -> IO (Maybe ExitCode)+maybeWaitForProcess hProcess =+  IO.catch (fmap Just (IO.waitForProcess hProcess)) $ \(_ :: AsyncCancelled) -> pure Nothing

@@ -0,0 +1,71 @@+#include <fcntl.h>+#include <windows.h>++{-# LANGUAGE CPP                #-}+{-# LANGUAGE MultiWayIf         #-}++-- | For full details on the Windows named pipes API see+-- <https://docs.microsoft.com/en-us/windows/desktop/ipc/named-pipes>+--+module HaskellWorks.IO.Win32.NamedPipe+  ( -- ** waiting for named pipe instances+    waitNamedPipe,++    TimeOut,+    nMPWAIT_USE_DEFAULT_WAIT,+    nMPWAIT_WAIT_FOREVER,+  ) where++import Control.Applicative (pure)+import Data.Bool (Bool (..), otherwise)+import Data.Eq ((==))+import Data.Function (($))+import Data.String (String)+import Foreign.C.String (withCString)+import System.IO (IO)+import System.Win32.File+import System.Win32.Types hiding (try)++-- | Timeout in milliseconds.+--+-- * 'nMPWAIT_USE_DEFAULT_WAIT' indicates that the timeout value passed to+--   'createNamedPipe' should be used.+-- * 'nMPWAIT_WAIT_FOREVER' - 'waitNamedPipe' will block forever, until a named+--   pipe instance is available.+--+type TimeOut = DWORD+#{enum TimeOut,+ , nMPWAIT_USE_DEFAULT_WAIT = NMPWAIT_USE_DEFAULT_WAIT+ , nMPWAIT_WAIT_FOREVER     = NMPWAIT_WAIT_FOREVER+ }++-- | Wait until a named pipe instance is available.  If there is no instance at+-- hand before the timeout, it will error with 'ERROR_SEM_TIMEOUT', i.e.+-- @invalid argument (The semaphore timeout period has expired)@+--+-- It returns 'True' if there is an available instance, subsequent 'createFile'+-- might still fail, if another thread will take turn and connect before, or if+-- the other end shuts down the name pipe.+--+-- It returns 'False' if timeout fired.+--+waitNamedPipe :: String  -- ^ pipe name+              -> TimeOut -- ^ nTimeOut+              -> IO Bool+waitNamedPipe name timeout =+    withCString name $ \ c_name -> do+      r <- c_WaitNamedPipe c_name timeout+      e <- getLastError+      if | r                      -> pure r+         | e == eRROR_SEM_TIMEOUT -> pure False+         | otherwise              -> failWith "waitNamedPipe" e+++-- 'c_WaitNamedPipe' is a blocking call, hence the _safe_ import.+foreign import ccall safe "windows.h WaitNamedPipeA"+  c_WaitNamedPipe :: LPCSTR -- lpNamedPipeName+                  -> DWORD  -- nTimeOut+                  -> IO BOOL++eRROR_SEM_TIMEOUT :: ErrCode+eRROR_SEM_TIMEOUT = #const ERROR_SEM_TIMEOUT

@@ -0,0 +1,85 @@+module HaskellWorks.Polysemy.Cabal+  ( findDefaultPlanJsonFile+  , getPlanJsonFile+  , binDist+  ) where++import           HaskellWorks.Polysemy.Cabal.Types+import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS+import           HaskellWorks.Polysemy.Error.Types+import           HaskellWorks.Polysemy.Prelude+import           HaskellWorks.Polysemy.System.Directory+import           HaskellWorks.Polysemy.System.Environment+import           System.FilePath                            (takeDirectory)++import           Data.Aeson+import qualified Data.List                                  as L+import qualified HaskellWorks.Polysemy.Data.Text            as T+import           HaskellWorks.Polysemy.FilePath+import           Polysemy+import           Polysemy.Error+import           Polysemy.Log++-- | Find the nearest plan.json going upwards from the current directory.+findDefaultPlanJsonFile :: ()+  => Member (Embed IO) r+  => Member (Error IOException) r+  => Member Log r+  => Sem r FilePath+findDefaultPlanJsonFile = getCurrentDirectory >>= go+  where go :: ()+          => Member (Embed IO) r+          => Member (Error IOException) r+          => Member Log r+          => FilePath+          -> Sem r FilePath+        go d = do+          let file = d </> "dist-newstyle/cache/plan.json"+          exists <- doesFileExist file+          if exists+            then return file+            else do+              let parent = takeDirectory d+              if parent == d+                then return "dist-newstyle/cache/plan.json"+                else go parent+++getPlanJsonFile :: ()+  => Member (Embed IO) r+  => Member (Error IOException) r+  => Member Log r+  => Sem r String+getPlanJsonFile =  do+  maybeBuildDir <- lookupEnv "CABAL_BUILDDIR"+  case maybeBuildDir of+    Just buildDir -> return $ ".." </> buildDir </> "cache/plan.json"+    Nothing       -> findDefaultPlanJsonFile++-- | 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.+binDist:: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => String+  -- ^ Package name+  -> Sem r FilePath+  -- ^ Path to executable+binDist pkg = do+  planJsonFile <- getPlanJsonFile+  contents <- 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  -> throw $ GenericError $ "Missing bin-file in " <> tshow component+      [] -> throw $ GenericError $ "Cannot find exe " <> tshow pkg <> " in plan"+    Left message -> throw $ GenericError $ "Cannot decode plan: " <> T.pack message+  where matching :: Component -> Bool+        matching component = case componentName component of+          Just name -> name == "exe:" <> T.pack pkg+          Nothing   -> False

@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Polysemy.Cabal.Types+  ( Plan(..)+  , Component(..)+  ) where++import           Control.Applicative+import           Data.Aeson+import           Data.Eq+import           Data.Function+import           Data.Maybe+import           Data.Text           (Text)+import           GHC.Generics+import           Text.Show++data Component = Component+  { componentName :: Maybe Text+  , binFile       :: Maybe Text+  }+  deriving (Generic, Eq, Show)++newtype Plan = Plan+  { installPlan :: [Component]+  }+  deriving (Generic, Eq, Show)++instance FromJSON Plan where+    parseJSON = withObject "Plan" $ \v -> Plan+        <$> v .: "install-plan"++instance FromJSON Component where+    parseJSON = withObject "Plan" $ \v -> Component+        <$> v .:? "component-name"+        <*> v .:? "bin-file"

@@ -0,0 +1,14 @@+module HaskellWorks.Polysemy.Error.Types+  ( GenericError(..)+  , TimedOut(..)+  ) where++import           HaskellWorks.Polysemy.Prelude++newtype GenericError = GenericError+  { message :: Text+  }+  deriving (Eq, Show)++data TimedOut = TimedOut+  deriving (Generic, Eq, Show)

@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module HaskellWorks.Polysemy.File+  ( JsonDecodeError(..)+  , YamlDecodeError(..)+  , readJsonFile+  , readYamlFile+  ) where++import           Data.Aeson+import qualified Data.Aeson                                 as J+import qualified Data.Yaml                                  as Y+import           GHC.Generics+import qualified HaskellWorks.Polysemy.Data.ByteString.Lazy as LBS+import qualified HaskellWorks.Polysemy.Data.Text            as T+import           HaskellWorks.Polysemy.Error+import           HaskellWorks.Polysemy.Prelude+import           Polysemy+import           Polysemy.Error+import           Polysemy.Log++newtype JsonDecodeError = JsonDecodeError { message :: String }+  deriving (Eq, Generic, Show)++newtype YamlDecodeError = YamlDecodeError { message :: String }+  deriving (Eq, Generic, Show)++-- | Read the 'filePath' file as JSON. Use @readJsonFile \@'Value'@ to decode into 'Value'.+readJsonFile :: forall a r. ()+  => FromJSON a+  => HasCallStack+  => Member (Error IOException) r+  => Member (Error JsonDecodeError) r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r a+readJsonFile filePath = withFrozenCallStack $ do+  info $ "Reading JSON file: " <> T.pack filePath+  contents <- LBS.readFile filePath+  J.eitherDecode contents+    & onLeft (throw . JsonDecodeError)+++-- | Read the 'filePath' file as YAML.+readYamlFile :: forall a r. ()+  => FromJSON a+  => HasCallStack+  => Member (Error IOException) r+  => Member (Error JsonDecodeError) r+  => Member (Error YamlDecodeError) r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r a+readYamlFile filePath = withFrozenCallStack $ do+  info $ "Reading YAML file: " <> T.pack filePath+  contents <- LBS.toStrict <$> LBS.readFile filePath+  Y.decodeEither' contents+    & onLeft (throw . YamlDecodeError . Y.prettyPrintParseException)

@@ -0,0 +1,17 @@+module HaskellWorks.Polysemy.FilePath+  ( exeSuffix+  , addExeSuffix+  ) where++import qualified HaskellWorks.Polysemy.OS      as OS++import qualified Data.List                     as L+import           HaskellWorks.Polysemy.Prelude++exeSuffix :: String+exeSuffix = if OS.isWin32 then ".exe" else ""++addExeSuffix :: String -> String+addExeSuffix s = if ".exe" `L.isSuffixOf` s+  then s+  else s <> exeSuffix

@@ -0,0 +1,12 @@+module HaskellWorks.Polysemy.OS+  ( isWin32+  ) where++import           Data.Bool+import           Data.Eq+import           System.Info++-- | Determine if the operating system is Windows.+isWin32 :: Bool+isWin32 = os == "mingw32"+{-# INLINE isWin32 #-}

@@ -2,22 +2,46 @@   ( Hedgehog,     leftFail,     leftFailM,+    nothingFail,+    nothingFailM,     requireHead,     catchFail,+    trapFail,     evalIO,     failure,     failMessage,      (===), +    assertPidOk,+    assertIsJsonFile_,+    assertIsYamlFile,+    assertFileExists,+    assertFilesExist,+    assertFileMissing,+    assertFilesMissing,+    assertFileOccurences,+    assertFileLines,+    assertEndsWithSingleNewline,+    assertDirectoryExists,+    assertDirectoryMissing,   ) where  +import           Control.Lens                                   ((^.))+import           Data.Aeson                                     (Value)+import           Data.Generics.Product.Any+import qualified Data.List                                      as L import qualified GHC.Stack                                      as GHC+import           HaskellWorks.Polysemy.File import           HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog import           HaskellWorks.Polysemy.Prelude+import           HaskellWorks.Polysemy.System.Directory+import           HaskellWorks.Polysemy.System.IO                as IO+import           HaskellWorks.Polysemy.System.Process import           Polysemy import           Polysemy.Error+import           Polysemy.Log  (===) :: ()   => Member Hedgehog r@@ -30,7 +54,7 @@ (===) a b = withFrozenCallStack $ assertEquals a b  -- | Fail when the result is Left.-leftFail :: forall e r a. ()+leftFail :: ()   => Member Hedgehog r   => Show e   => HasCallStack@@ -40,6 +64,15 @@   Right a -> pure a   Left e  -> failMessage GHC.callStack ("Expected Right: " <> show e) +nothingFail :: ()+  => Member Hedgehog r+  => HasCallStack+  => Maybe a+  -> Sem r a+nothingFail r = withFrozenCallStack $ case r of+  Just a  -> return a+  Nothing -> failMessage GHC.callStack "Expected Just"+ failure :: ()   => Member Hedgehog r   => HasCallStack@@ -65,6 +98,14 @@ leftFailM f =   withFrozenCallStack $ f >>= leftFail +nothingFailM :: forall r a. ()+  => Member Hedgehog r+  => HasCallStack+  => Sem r (Maybe a)+  -> Sem r a+nothingFailM f =+  withFrozenCallStack $ f >>= nothingFail+ catchFail :: forall e r a.()   => Member Hedgehog r   => HasCallStack@@ -73,7 +114,17 @@   -> Sem r a catchFail f =   withFrozenCallStack $ f & runError & leftFailM+{-# DEPRECATED catchFail "Use trapFail instead" #-} +trapFail :: forall e r a.()+  => Member Hedgehog r+  => HasCallStack+  => Show e+  => Sem (Error e ': r) a+  -> Sem r a+trapFail f =+  withFrozenCallStack $ f & runError & leftFailM+ requireHead :: ()   => Member Hedgehog r   => HasCallStack@@ -83,3 +134,175 @@   \case     []    -> failMessage GHC.callStack "Cannot take head of empty list"     (x:_) -> pure x++assertPidOk :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member (Error IOException) r+  => ProcessHandle+  -> Sem r Pid+assertPidOk hProcess = withFrozenCallStack $+  nothingFailM $ getPid hProcess++trap :: forall e r a. ()+  => (e -> Sem r a)+  -> Sem (Error e ': r) a+  -> Sem r a+trap h f =+  runError f >>= \case+    Left e  -> h e+    Right a -> pure a++-- | Assert the 'filePath' can be parsed as JSON.+assertIsJsonFile_ :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertIsJsonFile_ fp = withFrozenCallStack $ do+  void (readJsonFile @Value fp)+    & trap @IOException (failMessage GHC.callStack . show)+    & trap @JsonDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message"))++-- | Assert the 'filePath' can be parsed as YAML.+assertIsYamlFile :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertIsYamlFile fp = withFrozenCallStack $ do+  void (readYamlFile @Value fp)+    & trap @IOException (failMessage GHC.callStack . show)+    & trap @JsonDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message"))+    & trap @YamlDecodeError (\e -> failMessage GHC.callStack (e ^. the @"message"))++-- | Asserts that the given file exists.+assertFileExists :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertFileExists file = withFrozenCallStack $ do+  exists <- doesFileExist file+    & trap @IOException (const (pure False))+  unless exists $ failWithCustom GHC.callStack Nothing (file <> " has not been successfully created.")++-- | Asserts that all of the given files exist.+assertFilesExist :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => [FilePath]+  -> Sem r ()+assertFilesExist files =+  withFrozenCallStack $ for_ files assertFileExists++-- | Asserts that the given file is missing.+assertFileMissing :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertFileMissing file = withFrozenCallStack $ do+  exists <- doesFileExist file+    & trap @IOException (const (pure False))+  when exists $ failWithCustom GHC.callStack Nothing (file <> " should not have been created.")++-- | Asserts that all of the given files are missing.+assertFilesMissing :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => [FilePath]+  -> Sem r ()+assertFilesMissing files =+  withFrozenCallStack $ for_ files assertFileMissing++-- | Assert the file contains the given number of occurrences of the given string+assertFileOccurences :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => Int -> String -> FilePath -> Sem r ()+assertFileOccurences n s fp = withFrozenCallStack $ do+  contents <- readFile fp+    & trap @IOException (failMessage GHC.callStack . show)++  L.length (L.filter (s `L.isInfixOf`) (L.lines contents)) === n++-- | Assert the file contains the given number of occurrences of the given string+assertFileLines :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => (Int -> Bool)+  -> FilePath+  -> Sem r ()+assertFileLines p fp = withFrozenCallStack $ do+  contents <- readFile fp+    & trap @IOException (failMessage GHC.callStack . show)++  let lines = L.lines contents++  let len = case L.reverse lines of+        "":xs -> L.length xs+        xs    -> L.length xs++  unless (p len) $ do+    failWithCustom GHC.callStack Nothing (fp <> " has an unexpected number of lines")++-- | Assert the file contains the given number of occurrences of the given string+assertEndsWithSingleNewline :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertEndsWithSingleNewline fp = withFrozenCallStack $ do+  contents <- readFile fp+    & trap @IOException (failMessage GHC.callStack . show)++  case L.reverse contents of+    '\n':'\n':_ -> failWithCustom GHC.callStack Nothing (fp <> " ends with too many newlines.")+    '\n':_ -> return ()+    _ -> failWithCustom GHC.callStack Nothing (fp <> " must end with newline.")++-- | Asserts that the given directory exists.+assertDirectoryExists :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member Log r+  => FilePath+  -> Sem r ()+assertDirectoryExists dir = withFrozenCallStack $ do+  exists <- doesDirectoryExist dir+    & trap @IOException (const (pure False))+  unless exists $ failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does not exist on the file system.")++-- | Asserts that the given directory is missing.+assertDirectoryMissing :: ()+  => HasCallStack+  => Member Hedgehog r+  => Member Log r+  => Member (Embed IO) r+  => FilePath+  -> Sem r ()+assertDirectoryMissing dir = withFrozenCallStack $ do+  exists <- doesDirectoryExist dir+    & trap @IOException (const (pure False))+  when exists $ failWithCustom GHC.callStack Nothing ("Directory '" <> dir <> "' does exist on the file system.")

@@ -0,0 +1,266 @@+module HaskellWorks.Polysemy.Hedgehog.Process+  ( defaultExecConfig+  , execFlex+  , execFlexOk+  , execFlexOk'+  , execOk+  , execOk_+  , exec+  , procFlex+  , procFlex'+  , binFlex++  , waitSecondsForProcess+  , waitSecondsForProcessOk++  ) where++import qualified Control.Concurrent                              as IO+import qualified Control.Concurrent.Async                        as IO+import           Data.Monoid                                     (Last (..))+import           GHC.Stack                                       (callStack)+import qualified HaskellWorks.IO.Process                         as IO+import           HaskellWorks.Polysemy.Cabal+import           HaskellWorks.Polysemy.Error.Types+import           HaskellWorks.Polysemy.Hedgehog.Assert+import           HaskellWorks.Polysemy.Hedgehog.Jot+import           HaskellWorks.Polysemy.Hedgehog.Process.Internal+import           HaskellWorks.Polysemy.Prelude+import           HaskellWorks.Polysemy.System.Environment+import           HaskellWorks.Polysemy.System.Process++import qualified Data.List                                       as L+import           Polysemy+import           Polysemy.Error+import           Polysemy.Log++-- | Configuration for starting a new process.  This is a subset of 'IO.CreateProcess'.+data ExecConfig = ExecConfig+  { execConfigEnv :: Last [(String, String)]+  , execConfigCwd :: Last FilePath+  } deriving (Eq, Generic, Show)++defaultExecConfig :: ExecConfig+defaultExecConfig = ExecConfig+  { execConfigEnv = mempty+  , execConfigCwd = mempty+  }++-- | Create a process returning its stdout.+--+-- Being a 'flex' function means that the environment determines how the process is launched.+--+-- When running in a nix environment, the 'envBin' argument describes the environment variable+-- that defines the binary to use to launch the process.+--+-- When running outside a nix environment, the `pkgBin` describes the name of the binary+-- to launch via cabal exec.+execFlexOk :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => String+  -> String+  -> [String]+  -> Sem r String+execFlexOk = execFlexOk' defaultExecConfig++execFlexOk' :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String+  -> String+  -> [String]+  -> Sem r String+execFlexOk' execConfig pkgBin envBin arguments = withFrozenCallStack $ do+  (exitResult, stdout, stderr) <- execFlex execConfig pkgBin envBin arguments+  case exitResult of+    ExitFailure exitCode -> do+      jot_ $ L.unlines $+        [ "Process exited with non-zero exit-code: " <> show @Int exitCode ]+        <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout])+        <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr])+      failMessage callStack "Execute process failed"+    ExitSuccess -> return stdout++-- | Run a process, returning its exit code, its stdout, and its stderr.+-- Contrary to @execFlexOk'@, this function doesn't fail if the call fails.+-- So, if you want to test something negative, this is the function to use.+execFlex :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String -- ^ @pkgBin@: name of the binary to launch via 'cabal exec'+  -> String -- ^ @envBin@: environment variable defining the binary to launch the process, when in Nix+  -> [String]+  -> Sem r (ExitCode, String, String) -- ^ exit code, stdout, stderr+execFlex execConfig pkgBin envBin arguments = withFrozenCallStack $ do+  cp <- procFlex' execConfig pkgBin envBin arguments+  jot_ . ("━━━━ command ━━━━\n" <>) $ case cmdspec cp of+    ShellCommand cmd    -> cmd+    RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args)++  readCreateProcessWithExitCode cp ""++-- | Execute a process, returning '()'.+execOk_ :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String+  -> [String]+  -> Sem r ()+execOk_ execConfig bin arguments = void $ execOk execConfig bin arguments++-- | Execute a process, returning the stdout. Fail if the call returns+-- with a non-zero exit code. For a version that doesn't fail upon receiving+-- a non-zero exit code, see 'execAny'.+execOk :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String+  -> [String]+  -> Sem r String+execOk execConfig bin arguments = withFrozenCallStack $ do+  (exitResult, stdout, stderr) <- exec execConfig bin arguments+  case exitResult of+    ExitFailure exitCode ->failMessage callStack . L.unlines $+      [ "Process exited with non-zero exit-code: " <> show @Int exitCode ]+      <> (if L.null stdout then [] else ["━━━━ stdout ━━━━" , stdout])+      <> (if L.null stderr then [] else ["━━━━ stderr ━━━━" , stderr])+    ExitSuccess -> return stdout++-- | Execute a process, returning the error code, the stdout, and the stderr.+exec :: ()+  => Member (Embed IO) r+  => Member Hedgehog r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String -- ^ The binary to launch+  -> [String] -- ^ The binary's arguments+  -> Sem r (ExitCode, String, String) -- ^ exit code, stdout, stderr+exec execConfig bin arguments = withFrozenCallStack $ do+  let cp = (proc bin arguments)+        { env = getLast $ execConfigEnv execConfig+        , cwd = getLast $ execConfigCwd execConfig+        }+  jot_ . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments)+  readCreateProcessWithExitCode cp ""++waitSecondsForProcess :: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => Int+  -> ProcessHandle+  -> Sem r (Either TimedOut (Maybe ExitCode))+waitSecondsForProcess seconds hProcess = embed $+  IO.race+    (IO.threadDelay (seconds * 1000000) >> return TimedOut)+    (IO.maybeWaitForProcess hProcess)++-- | Wait a maximum of 'seconds' secons for process to exit.+waitSecondsForProcessOk :: ()+  => Member Hedgehog r+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => Int+  -> ProcessHandle+  -> Sem r (Either TimedOut ExitCode)+waitSecondsForProcessOk seconds hProcess = withFrozenCallStack $ do+  result <- waitSecondsForProcess seconds hProcess+  case result of+    Left TimedOut -> do+      jot_ "Timed out waiting for process to exit"+      return (Left TimedOut)+    Right maybeExitCode -> do+      case maybeExitCode of+        Nothing -> failMessage callStack "No exit code for process"+        Just exitCode -> do+          jot_ $ "Process exited " <> show exitCode+          return (Right exitCode)++-- | Compute the path to the binary given a package name or an environment variable override.+binFlex :: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => String+  -- ^ Package name+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> Sem r FilePath+  -- ^ Path to executable+binFlex pkg binaryEnv = do+  maybeEnvBin <- lookupEnv binaryEnv+  case maybeEnvBin of+    Just envBin -> return envBin+    Nothing     -> binDist pkg++-- | 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,+-- and an argument list.+--+-- The actual executable used will the one specified by the environment variable, but if+-- the environment variable is not defined, it will be found instead by consulting the+-- "plan.json" generated by cabal.  It is assumed that the project has already been+-- configured and the executable has been built.+procFlex :: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> Sem r CreateProcess+  -- ^ Captured stdout+procFlex = procFlex' defaultExecConfig++procFlex' :: ()+  => Member (Embed IO) r+  => Member (Error GenericError) r+  => Member (Error IOException) r+  => Member Log r+  => ExecConfig+  -> String+  -- ^ Cabal package name corresponding to the executable+  -> String+  -- ^ Environment variable pointing to the binary to run+  -> [String]+  -- ^ Arguments to the CLI command+  -> Sem r CreateProcess+  -- ^ Captured stdout+procFlex' execConfig pkg binaryEnv arguments = withFrozenCallStack $ do+  bin <- binFlex pkg binaryEnv+  return (proc bin arguments)+    { env = getLast $ execConfigEnv execConfig+    , cwd = getLast $ execConfigCwd execConfig+    -- this allows sending signals to the created processes, without killing the test-suite process+    , create_group = True+    }

@@ -0,0 +1,28 @@+module HaskellWorks.Polysemy.Hedgehog.Process.Internal+  ( argQuote+  ) where++import           Data.Bool+import           Data.Semigroup+import           Data.String++import qualified Data.List      as L++-- | Format argument for a shell CLI command.+--+-- This includes automatically embedding string in double quotes if necessary, including any necessary escaping.+--+-- Note, this function does not cover all the edge cases for shell processing, so avoid use in production code.+argQuote :: String -> String+argQuote arg = if ' ' `L.elem` arg || '"' `L.elem` arg || '$' `L.elem` arg+  then "\"" <> escape arg <> "\""+  else arg+  where escape :: String -> String+        escape ('"':xs)  = '\\':'"':escape xs+        escape ('\\':xs) = '\\':'\\':escape xs+        escape ('\n':xs) = '\\':'n':escape xs+        escape ('\r':xs) = '\\':'r':escape xs+        escape ('\t':xs) = '\\':'t':escape xs+        escape ('$':xs)  = '\\':'$':escape xs+        escape (x:xs)    = x:escape xs+        escape ""        = ""

@@ -1,6 +1,6 @@ cabal-version:          3.4 name:                   hw-polysemy-version:                0.2.0.0+version:                0.2.1.0 synopsis:               Opinionated polysemy library description:            Opinionated polysemy library. license:                Apache-2.0@@ -19,23 +19,31 @@  common base                       { build-depends: base                       >= 4.18       && < 5      } +common aeson                      { build-depends: aeson                                       < 2.3    }+common async                      { build-depends: async                                       < 2.3    } common bytestring                 { build-depends: bytestring                                  < 0.13   } common contravariant              { build-depends: contravariant                               < 1.6    } common Diff                       { build-depends: Diff                                        < 0.6    } common directory                  { build-depends: directory                                   < 1.4    } common filepath                   { build-depends: filepath                                    < 1.6    }+common generic-lens               { build-depends: generic-lens                                < 2.3    } common ghc-prim                   { build-depends: ghc-prim                                    < 0.12   } common hedgehog                   { build-depends: hedgehog                                    < 1.5    }+common network                    { build-depends: network                                     < 3.3    }+common lens                       { build-depends: lens                                        < 5.4    } common polysemy                   { build-depends: polysemy                                    < 2      } common polysemy-log               { build-depends: polysemy-log                                < 0.11   } common polysemy-plugin            { build-depends: polysemy-plugin                             < 0.5    } common polysemy-time              { build-depends: polysemy-time                               < 0.7    } common process                    { build-depends: process                                     < 1.7    }+common resourcet                  { build-depends: resourcet                                   < 1.4    } common stm                        { build-depends: stm                                         < 2.6    } common tasty                      { build-depends: tasty                                       < 1.6    } common tasty-hedgehog             { build-depends: tasty-hedgehog                              < 1.5    } common text                       { build-depends: text                                        < 3      } common time                       { build-depends: time                                        < 2      }+common unliftio                   { build-depends: unliftio                                    < 0.3    }+common yaml                       { build-depends: yaml                                        < 0.12   }  common hw-polysemy                { build-depends: hw-polysemy                                          } common hw-polysemy-core           { build-depends: hw-polysemy:core                                     }@@ -57,21 +65,40 @@  library core   import:               base, project-config,+                        aeson,+                        async,                         bytestring,                         contravariant,                         directory,                         filepath,+                        generic-lens,                         ghc-prim,                         hedgehog,+                        lens,+                        network,                         polysemy,                         polysemy-log,                         polysemy-time,                         process,+                        resourcet,                         stm,                         text,                         time,+                        unliftio,+                        yaml,   visibility:           public-  exposed-modules:      HaskellWorks.Polysemy++  if os(windows)+    exposed-modules:    HaskellWorks.IO.Win32.NamedPipe++  exposed-modules:      HaskellWorks.IO.Network+                        HaskellWorks.IO.Network.NamedPipe+                        HaskellWorks.IO.Network.Port+                        HaskellWorks.IO.Network.Socket+                        HaskellWorks.IO.Process+                        HaskellWorks.Polysemy+                        HaskellWorks.Polysemy.Cabal+                        HaskellWorks.Polysemy.Cabal.Types                         HaskellWorks.Polysemy.Control.Concurrent                         HaskellWorks.Polysemy.Control.Concurrent.QSem                         HaskellWorks.Polysemy.Control.Concurrent.STM@@ -84,6 +111,10 @@                         HaskellWorks.Polysemy.Data.Text.Lazy                         HaskellWorks.Polysemy.Data.Text.Strict                         HaskellWorks.Polysemy.Error+                        HaskellWorks.Polysemy.Error.Types+                        HaskellWorks.Polysemy.File+                        HaskellWorks.Polysemy.FilePath+                        HaskellWorks.Polysemy.OS                         HaskellWorks.Polysemy.Prelude                         HaskellWorks.Polysemy.String                         HaskellWorks.Polysemy.System.Directory@@ -95,16 +126,21 @@  library hedgehog   import:               base, project-config,+                        aeson,+                        async,                         bytestring,                         contravariant,                         Diff,                         filepath,+                        generic-lens,                         ghc-prim,                         hedgehog,                         hw-polysemy-core,-                        polysemy,+                        lens,                         polysemy-log,                         polysemy-time,+                        polysemy,+                        process,                         text,   visibility:           public   exposed-modules:      HaskellWorks.Polysemy.Hedgehog@@ -115,6 +151,8 @@                         HaskellWorks.Polysemy.Hedgehog.Eval                         HaskellWorks.Polysemy.Hedgehog.Golden                         HaskellWorks.Polysemy.Hedgehog.Jot+                        HaskellWorks.Polysemy.Hedgehog.Process+                        HaskellWorks.Polysemy.Hedgehog.Process.Internal                         HaskellWorks.Polysemy.Hedgehog.Property   hs-source-dirs:       hedgehog   default-language:     GHC2021@@ -123,7 +161,12 @@   import:               base, project-config,                         hw-polysemy-core,                         hw-polysemy-hedgehog,-  reexported-modules:   HaskellWorks.Polysemy,+  reexported-modules:   HaskellWorks.IO.Network,+                        HaskellWorks.IO.Network.NamedPipe,+                        HaskellWorks.IO.Network.Port,+                        HaskellWorks.Polysemy,+                        HaskellWorks.Polysemy.Cabal,+                        HaskellWorks.Polysemy.Cabal.Types,                         HaskellWorks.Polysemy.Control.Concurrent,                         HaskellWorks.Polysemy.Control.Concurrent.QSem,                         HaskellWorks.Polysemy.Control.Concurrent.STM,@@ -136,6 +179,9 @@                         HaskellWorks.Polysemy.Data.Text.Lazy,                         HaskellWorks.Polysemy.Data.Text.Strict,                         HaskellWorks.Polysemy.Error,+                        HaskellWorks.Polysemy.Error.Types,+                        HaskellWorks.Polysemy.FilePath,+                        HaskellWorks.Polysemy.OS,                         HaskellWorks.Polysemy.Hedgehog,                         HaskellWorks.Polysemy.Hedgehog.Assert,                         HaskellWorks.Polysemy.Hedgehog.Effect.Hedgehog,@@ -144,6 +190,8 @@                         HaskellWorks.Polysemy.Hedgehog.Eval,                         HaskellWorks.Polysemy.Hedgehog.Golden,                         HaskellWorks.Polysemy.Hedgehog.Jot,+                        HaskellWorks.Polysemy.Hedgehog.Process,+                        HaskellWorks.Polysemy.Hedgehog.Process.Internal,                         HaskellWorks.Polysemy.Hedgehog.Property,                         HaskellWorks.Polysemy.Prelude,                         HaskellWorks.Polysemy.String,

@@ -20,7 +20,7 @@   let projectRoot = "."    contents <- T.readFile (projectRoot </> "LICENSE")-    & catchFail @IOException+    & trapFail @IOException    line1 <- T.lines contents     & L.dropWhile T.null