From 44e6d2065924c73ae4bc751ac0fcfe890f7c166d Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 8 Jan 2025 23:59:51 +1100 Subject: [PATCH 1/3] Tidy up --- .../Effectful/Zoo/TestContainers/LocalStack.hs | 2 +- effectful-zoo.cabal | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack.hs b/components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack.hs index 941f4da..9d1dcba 100644 --- a/components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack.hs +++ b/components/testcontainers-localstack/Effectful/Zoo/TestContainers/LocalStack.hs @@ -24,7 +24,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.Function import Data.Generics.Product.Any import Data.Text qualified as T -import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Time.Clock.POSIX (getPOSIXTime) import Effectful import Effectful.Zoo.Core import Effectful.Zoo.Reader.Static diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal index e9a13cb..a068217 100644 --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -338,15 +338,11 @@ library testcontainers-localstack bytestring, effectful-core, effectful-plugin, - -- effectful-zoo-amazonka, effectful-zoo-core, - -- effectful-zoo-hedgehog, - -- effectful-zoo-rds-data, generic-lens, http-conduit, hw-prelude, microlens, - -- rds-data-codecs, testcontainers, text, time, From dbe405ab81db3c67462758aa62bb97ea4f497585 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 12 Jan 2025 02:00:51 +1100 Subject: [PATCH 2/3] New hedgehog Range and Gen modules --- .../Effectful/Zoo/Hedgehog/Api/Gen.hs | 7 ++++ .../Effectful/Zoo/Hedgehog/Api/Gen/Time.hs | 18 +++++++++++ .../Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs | 32 +++++++++++++++++++ .../Effectful/Zoo/Hedgehog/Api/Range.hs | 5 +++ effectful-zoo.cabal | 8 +++++ 5 files changed, 70 insertions(+) create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Range.hs diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs new file mode 100644 index 0000000..04840ca --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen.hs @@ -0,0 +1,7 @@ +module Effectful.Zoo.Hedgehog.Api.Gen + ( module Hedgehog.Gen, + module Effectful.Zoo.Hedgehog.Api.Gen.Ulid, + ) where + +import Effectful.Zoo.Hedgehog.Api.Gen.Ulid +import Hedgehog.Gen diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs new file mode 100644 index 0000000..f1ebf5e --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Time.hs @@ -0,0 +1,18 @@ +module Effectful.Zoo.Hedgehog.Api.Gen.Time + ( genPosixTime, + ) where + +import Data.Time.Clock.POSIX (POSIXTime) +import HaskellWorks.Prelude +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +genPosixTime :: Gen POSIXTime +genPosixTime = do + -- Generate a random integer within a reasonable range for POSIX time + -- POSIXTime is a type synonym for NominalDiffTime, which is in seconds + -- We'll use a range from 0 to a large number of seconds to cover a wide time span + seconds <- Gen.integral (Range.linear 0 4_102_444_800) -- Up to year 2100 + + pure $ fromIntegral @Word64 seconds diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs new file mode 100644 index 0000000..96e5559 --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Gen/Ulid.hs @@ -0,0 +1,32 @@ +module Effectful.Zoo.Hedgehog.Api.Gen.Ulid ( + genUlid, + genUlidRandom, + genUlidTimeStamp, +) where + +import Data.Binary (decodeOrFail) +import Data.ByteString.Lazy qualified as LBS +import Data.ULID (ULID (..)) +import Data.ULID.Random (ULIDRandom) +import Data.ULID.TimeStamp (ULIDTimeStamp, mkULIDTimeStamp) +import Effectful.Zoo.Hedgehog.Api.Gen.Time +import HaskellWorks.Prelude +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +genUlidRandom :: Gen ULIDRandom +genUlidRandom = do + bytes <- Gen.bytes (Range.singleton 10) -- 80 bits + let lazyBytes = LBS.fromStrict bytes + case decodeOrFail lazyBytes of + Left (_, _, err) -> fail $ "Failed to decode ULIDRandom: " <> err -- This shouldn't happen. + Right (_, _, ulid) -> pure ulid + +genUlidTimeStamp :: Gen ULIDTimeStamp +genUlidTimeStamp = + mkULIDTimeStamp <$> genPosixTime + +genUlid :: Gen ULID +genUlid = + ULID <$> genUlidTimeStamp <*> genUlidRandom diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Range.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Range.hs new file mode 100644 index 0000000..99349ca --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Range.hs @@ -0,0 +1,5 @@ +module Effectful.Zoo.Hedgehog.Api.Range + ( module Hedgehog.Range, + ) where + +import Hedgehog.Range diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal index a068217..1bcab56 100644 --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -35,6 +35,7 @@ common amazonka-rds { build-depends: amazonka-rds >= common amazonka-rds-data { build-depends: amazonka-rds-data >= 2 && < 3 } common amazonka-secretsmanager { build-depends: amazonka-secretsmanager >= 2 && < 3 } common base64-bytestring { build-depends: base64-bytestring >= 1.2.1 && < 2 } +common binary { build-depends: binary >= 0.8.9 && < 0.9 } common blockfrost-api { build-depends: blockfrost-api >= 0.11 && < 0.12 } common blockfrost-client { build-depends: blockfrost-client >= 0.8 && < 0.9 } common bytestring { build-depends: bytestring >= 0.11 && < 1 } @@ -62,6 +63,7 @@ common testcontainers { build-depends: testcontainers >= common text { build-depends: text >= 2 && < 3 } common time { build-depends: time >= 1.12 && < 2 } common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 } +common ulid { build-depends: ulid >= 0.3.2 && < 0.4 } common uuid { build-depends: uuid >= 1.3.16 && < 2 } common yaml { build-depends: yaml >= 0.11.11.2 && < 1 } @@ -280,6 +282,7 @@ library hedgehog import: base, project-config, aeson-pretty, aeson, + binary, bytestring, effectful-core, effectful-plugin, @@ -297,15 +300,20 @@ library hedgehog text, time, transformers, + ulid, yaml, visibility: public exposed-modules: Effectful.Zoo.Hedgehog Effectful.Zoo.Hedgehog.Api Effectful.Zoo.Hedgehog.Api.Assert Effectful.Zoo.Hedgehog.Api.Failure + Effectful.Zoo.Hedgehog.Api.Gen + Effectful.Zoo.Hedgehog.Api.Gen.Time + Effectful.Zoo.Hedgehog.Api.Gen.Ulid Effectful.Zoo.Hedgehog.Api.Hedgehog Effectful.Zoo.Hedgehog.Api.Journal Effectful.Zoo.Hedgehog.Api.MonadAssertion + Effectful.Zoo.Hedgehog.Api.Range Effectful.Zoo.Hedgehog.Api.Stack Effectful.Zoo.Hedgehog.Api.Tasty Effectful.Zoo.Hedgehog.Api.Workspace From 9b8f82a84ff9593c8871b0eeb65bba7ee82bbfb7 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 12 Jan 2025 02:47:34 +1100 Subject: [PATCH 3/3] Hedgehog process support --- components/core/Effectful/Zoo/FileSystem.hs | 12 + components/core/Effectful/Zoo/Process.hs | 273 +++++++++++++++ .../Zoo/Hedgehog/Api/Internal/Cabal.hs | 90 +++++ .../Zoo/Hedgehog/Api/Internal/Cabal/Types.hs | 36 ++ .../Zoo/Hedgehog/Api/Internal/FilePath.hs | 16 + .../Effectful/Zoo/Hedgehog/Api/Internal/OS.hs | 12 + .../Effectful/Zoo/Hedgehog/Api/Journal.hs | 53 ++- .../Effectful/Zoo/Hedgehog/Api/Process.hs | 313 ++++++++++++++++++ .../Zoo/Hedgehog/Api/Process/Internal.hs | 28 ++ effectful-zoo.cabal | 9 + 10 files changed, 834 insertions(+), 8 deletions(-) create mode 100644 components/core/Effectful/Zoo/Process.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal/Types.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/FilePath.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/OS.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs create mode 100644 components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process/Internal.hs diff --git a/components/core/Effectful/Zoo/FileSystem.hs b/components/core/Effectful/Zoo/FileSystem.hs index 1ddbff7..a4d0802 100644 --- a/components/core/Effectful/Zoo/FileSystem.hs +++ b/components/core/Effectful/Zoo/FileSystem.hs @@ -15,6 +15,8 @@ module Effectful.Zoo.FileSystem doesDirectoryExist, runFileSystem, + + getCurrentDirectory, ) where import Data.Aeson (FromJSON) @@ -180,3 +182,13 @@ doesDirectoryExist fp = withFrozenCallStack $ do unsafeFileSystemEff_ (D.doesDirectoryExist fp) & trapIO @IOException throw + +getCurrentDirectory :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => Eff r FilePath +getCurrentDirectory = withFrozenCallStack do + unsafeFileSystemEff_ D.getCurrentDirectory + & trapIO @IOException throw +{-# INLINE getCurrentDirectory #-} \ No newline at end of file diff --git a/components/core/Effectful/Zoo/Process.hs b/components/core/Effectful/Zoo/Process.hs new file mode 100644 index 0000000..3c58394 --- /dev/null +++ b/components/core/Effectful/Zoo/Process.hs @@ -0,0 +1,273 @@ +module Effectful.Zoo.Process + ( IO.CreateProcess(..), + IO.CmdSpec(..), + IO.StdStream(..), + Handle, + ProcessHandle, + ExitCode(..), + FD, + Pid, + createProcess, + createProcess_, + IO.shell, + IO.proc, + callProcess, + callCommand, + spawnProcess, + spawnCommand, + readCreateProcess, + readProcess, + readCreateProcessWithExitCode, + readProcessWithExitCode, + cleanupProcess, + getPid, + getCurrentPid, + interruptProcessGroupOf, + createPipe, + createPipeFd, + runProcess, + runCommand, + runInteractiveProcess, + runInteractiveCommand, + system, + rawSystem, + + waitSecondsForProcess, + ) where + +import Control.Exception qualified as CE +import HaskellWorks.Error +import HaskellWorks.Error.Types +import HaskellWorks.IO.Process qualified as IO +import HaskellWorks.Prelude +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Error.Static +import System.Exit (ExitCode (..)) +import System.Posix.Internals (FD) +import System.Process (Pid, ProcessHandle) +import System.Process qualified as IO + +createProcess :: () + => r <: Error IOException + => r <: IOE + => IO.CreateProcess + -> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess cp = do + r <- liftIO $ CE.try @IOException $ IO.createProcess cp + fromEither r + +createProcess_ :: () + => r <: Error IOException + => r <: IOE + => String + -> IO.CreateProcess + -> Eff r (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess_ cmd cp = do + r <- liftIO $ CE.try @IOException $ IO.createProcess_ cmd cp + fromEither r + +callProcess :: () + => r <: Error IOException + => r <: IOE + => String + -> [String] + -> Eff r () +callProcess cmd args = do + r <- liftIO $ CE.try @IOException $ IO.callProcess cmd args + fromEither r + +callCommand :: () + => r <: Error IOException + => r <: IOE + => String + -> Eff r () +callCommand cmd = do + r <- liftIO $ CE.try @IOException $ IO.callCommand cmd + fromEither r + +spawnProcess :: () + => r <: Error IOException + => r <: IOE + => String + -> [String] + -> Eff r ProcessHandle +spawnProcess cmd args = do + r <- liftIO $ CE.try @IOException $ IO.spawnProcess cmd args + fromEither r + +spawnCommand :: () + => r <: Error IOException + => r <: IOE + => String + -> Eff r ProcessHandle +spawnCommand cmd = do + r <- liftIO $ CE.try @IOException $ IO.spawnCommand cmd + fromEither r + +readCreateProcess :: () + => r <: Error IOException + => r <: IOE + => IO.CreateProcess + -> String + -> Eff r String +readCreateProcess cp input = do + r <- liftIO $ CE.try @IOException $ IO.readCreateProcess cp input + fromEither r + +readProcess :: () + => r <: Error IOException + => r <: IOE + => String + -> [String] + -> String + -> Eff r String +readProcess cmd args input = do + r <- liftIO $ CE.try @IOException $ IO.readProcess cmd args input + fromEither r + +readCreateProcessWithExitCode :: () + => r <: Error IOException + => r <: IOE + => IO.CreateProcess + -> String + -> Eff r (ExitCode, String, String) +readCreateProcessWithExitCode cp input = do + r <- liftIO $ CE.try @IOException $ IO.readCreateProcessWithExitCode cp input + fromEither r + +readProcessWithExitCode :: () + => r <: Error IOException + => r <: IOE + => String + -> [String] + -> String + -> Eff r (ExitCode, String, String) +readProcessWithExitCode cmd args input = do + r <- liftIO $ CE.try @IOException $ IO.readProcessWithExitCode cmd args input + fromEither r + +cleanupProcess :: () + => r <: Error IOException + => r <: IOE + => (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + -> Eff r () +cleanupProcess (mIn, mOut, mErr, ph) = do + r <- liftIO $ CE.try @IOException $ IO.cleanupProcess (mIn, mOut, mErr, ph) + fromEither r + +getPid :: () + => r <: Error IOException + => r <: IOE + => ProcessHandle + -> Eff r (Maybe Pid) +getPid ph = do + r <- liftIO $ CE.try @IOException $ IO.getPid ph + fromEither r + +getCurrentPid :: () + => r <: Error IOException + => r <: IOE + => Eff r Pid +getCurrentPid = do + r <- liftIO $ CE.try @IOException $ IO.getCurrentPid + fromEither r + +interruptProcessGroupOf :: () + => r <: Error IOException + => r <: IOE + => ProcessHandle + -> Eff r () +interruptProcessGroupOf ph = do + r <- liftIO $ CE.try @IOException $ IO.interruptProcessGroupOf ph + fromEither r + +createPipe :: () + => r <: Error IOException + => r <: IOE + => Eff r (Handle, Handle) +createPipe = do + r <- liftIO $ CE.try @IOException $ IO.createPipe + fromEither r + +createPipeFd :: () + => r <: Error IOException + => r <: IOE + => Eff r (FD, FD) +createPipeFd = do + r <- liftIO $ CE.try @IOException $ IO.createPipeFd + fromEither r + +runProcess :: () + => r <: Error IOException + => r <: IOE + => FilePath + -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> Maybe Handle + -> Maybe Handle + -> Maybe Handle + -> Eff r ProcessHandle +runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr = do + r <- liftIO $ CE.try @IOException $ IO.runProcess cmd args mbStdIn mbEnv mbCwd mbStdOut mbStdErr + fromEither r + +runCommand :: () + => r <: Error IOException + => r <: IOE + => String + -> Eff r ProcessHandle +runCommand cmd = do + r <- liftIO $ CE.try @IOException $ IO.runCommand cmd + fromEither r + +runInteractiveProcess :: () + => r <: Error IOException + => r <: IOE + => FilePath + -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> Eff r (Handle, Handle, Handle, ProcessHandle) +runInteractiveProcess cmd args mbCwd mbEnv = do + r <- liftIO $ CE.try @IOException $ IO.runInteractiveProcess cmd args mbCwd mbEnv + fromEither r + +runInteractiveCommand :: () + => r <: Error IOException + => r <: IOE + => String + -> Eff r (Handle, Handle, Handle, ProcessHandle) +runInteractiveCommand cmd = do + r <- liftIO $ CE.try @IOException $ IO.runInteractiveCommand cmd + fromEither r + +system :: () + => r <: Error IOException + => r <: IOE + => String + -> Eff r ExitCode +system cmd = do + r <- liftIO $ CE.try @IOException $ IO.system cmd + fromEither r + +rawSystem :: () + => r <: Error IOException + => r <: IOE + => String + -> [String] + -> Eff r ExitCode +rawSystem cmd args = do + r <- liftIO $ CE.try @IOException $ IO.rawSystem cmd args + fromEither r + +waitSecondsForProcess :: () + => r <: Error TimedOut + => r <: IOE + => Int + -> ProcessHandle + -> Eff r (Maybe ExitCode) +waitSecondsForProcess seconds hProcess = + liftIO (IO.waitSecondsForProcess seconds hProcess) + & onLeftM @TimedOut throw diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal.hs new file mode 100644 index 0000000..cf87e50 --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal.hs @@ -0,0 +1,90 @@ +module Effectful.Zoo.Hedgehog.Api.Internal.Cabal + ( findDefaultPlanJsonFile, + getPlanJsonFile, + binDist, + ) where + +import Data.Aeson +import Data.List qualified as L +import Data.Text qualified as T +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Environment +import Effectful.Zoo.Error.Static +import Effectful.Zoo.FileSystem +import Effectful.Zoo.Hedgehog.Api.Internal.Cabal.Types +import Effectful.Zoo.Hedgehog.Api.Internal.FilePath +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Error.Types +import HaskellWorks.Prelude +import System.FilePath (takeDirectory, ()) + +-- | Find the nearest plan.json going upwards from the current directory. +findDefaultPlanJsonFile :: () + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => Eff r FilePath +findDefaultPlanJsonFile = getCurrentDirectory >>= go + where go :: () + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => FilePath + -> Eff 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 :: () + => r <: Environment + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => Eff r FilePath +getPlanJsonFile = do + maybeBuildDir <- lookupEnvMaybe "CABAL_BUILDDIR" + case maybeBuildDir of + Just buildDir -> pure $ ".." T.unpack 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:: () + => r <: Environment + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => String + -- ^ Package name + -> Eff r FilePath + -- ^ Path to executable +binDist pkg = do + planJsonFile <- getPlanJsonFile + contents <- readLazyByteStringFile planJsonFile + + case eitherDecode @Plan 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 msg -> throw $ GenericError $ "Cannot decode plan: " <> T.pack msg + where matching :: Component -> Bool + matching component = case component.componentName of + Just name -> name == "exe:" <> T.pack pkg + Nothing -> False diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal/Types.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal/Types.hs new file mode 100644 index 0000000..2ec6f72 --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/Cabal/Types.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Effectful.Zoo.Hedgehog.Api.Internal.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 stock (Generic, Eq, Show) + +newtype Plan = Plan + { installPlan :: [Component] + } + deriving stock (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" diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/FilePath.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/FilePath.hs new file mode 100644 index 0000000..c5658ea --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/FilePath.hs @@ -0,0 +1,16 @@ +module Effectful.Zoo.Hedgehog.Api.Internal.FilePath + ( exeSuffix, + addExeSuffix, + ) where + +import Data.List qualified as L +import Effectful.Zoo.Hedgehog.Api.Internal.OS qualified as OS +import HaskellWorks.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 diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/OS.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/OS.hs new file mode 100644 index 0000000..20e2107 --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Internal/OS.hs @@ -0,0 +1,12 @@ +module Effectful.Zoo.Hedgehog.Api.Internal.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 #-} diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs index fa88adf..64efa69 100644 --- a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Journal.hs @@ -6,6 +6,9 @@ module Effectful.Zoo.Hedgehog.Api.Journal jotWithCallStack, + jotString, + jotString_, + jotText, jotText_, jotM, jotBsUtf8M, @@ -89,13 +92,11 @@ jotWithCallStack cs a = jot :: forall m. () => HasCallStack => MonadTest m - => String - -> m String + => Text + -> m Text jot a = withFrozenCallStack do - !b <- eval a - jotWithCallStack GHC.callStack b - return b + jotText a -- | Annotate the given string returning unit. jot_ :: forall m. () @@ -103,9 +104,44 @@ jot_ :: forall m. () => MonadTest m => Text -> m () -jot_ = +jot_ a = + withFrozenCallStack do + jotText_ a + +-- | Annotate with the given string. +jotString :: forall m. () + => HasCallStack + => MonadTest m + => String + -> m String +jotString a = + withFrozenCallStack do + !b <- eval a + jotWithCallStack GHC.callStack b + pure b + +-- | Annotate with the given string. +jotString_ :: forall m. () + => HasCallStack + => MonadTest m + => String + -> m () +jotString_ a = withFrozenCallStack do - jotText_ + !b <- eval a + jotWithCallStack GHC.callStack b + +-- | Annotate the given text returning unit. +jotText :: forall m. () + => HasCallStack + => MonadTest m + => Text + -> m Text +jotText a = + withFrozenCallStack do + !b <- eval a + jotWithCallStack GHC.callStack $ T.unpack a + pure b -- | Annotate the given text returning unit. jotText_ :: forall m. () @@ -115,7 +151,8 @@ jotText_ :: forall m. () -> m () jotText_ a = withFrozenCallStack do - jotWithCallStack GHC.callStack $ T.unpack a + !b <- eval a + jotWithCallStack GHC.callStack $ T.unpack b -- | Annotate the given string in a monadic context. jotM :: forall a m. () diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs new file mode 100644 index 0000000..4d7e82a --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process.hs @@ -0,0 +1,313 @@ +module Effectful.Zoo.Hedgehog.Api.Process + ( ExecConfig(..), + defaultExecConfig, + execDetailFlex, + execFlex, + execFlexOk, + execFlexOk', + execOk, + execOk_, + exec, + procFlex, + procFlex', + binFlex, + + waitSecondsForProcess, + waitSecondsForProcessOk, + + ) where + +import Data.List qualified as L +import Data.Monoid (Last (..)) +import Data.Text qualified as T +import Effectful +import Effectful.Concurrent +import Effectful.Zoo.Core +import Effectful.Zoo.Environment +import Effectful.Zoo.Error.Static +import Effectful.Zoo.Hedgehog.Api.Assert +import Effectful.Zoo.Hedgehog.Api.Internal.Cabal +import Effectful.Zoo.Hedgehog.Api.Journal +import Effectful.Zoo.Hedgehog.Api.Process.Internal +import Effectful.Zoo.Hedgehog.Effect.Hedgehog +import Effectful.Zoo.Log.Dynamic +import Effectful.Zoo.Process +import GHC.Stack (callStack) +import HaskellWorks.Error.Types +import HaskellWorks.Prelude +import Effectful.FileSystem (FileSystem) + +-- | Configuration for starting a new process. This is a subset of 'IO.CreateProcess'. +data ExecConfig = ExecConfig + { execConfigEnv :: Last [(String, String)] + , execConfigCwd :: Last FilePath + } deriving stock (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 :: () + => HasCallStack + => r <: Concurrent + => r <: Environment + => r <: Error Failure + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => String + -> String + -> [String] + -> Eff r String +execFlexOk = execFlexOk' defaultExecConfig + +execFlexOk' :: () + => HasCallStack + => r <: Concurrent + => r <: Environment + => r <: Error Failure + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => ExecConfig + -> String + -> String + -> [String] + -> Eff r String +execFlexOk' execConfig pkgBin envBin arguments = + withFrozenCallStack do + (exitResult, stdout, stderr) <- execFlex execConfig pkgBin envBin arguments + case exitResult of + ExitFailure exitCode -> do + jotString_ $ 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 :: () + => HasCallStack + => r <: Concurrent + => r <: Environment + => r <: Error Failure + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => 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] + -> Eff r (ExitCode, String, String) -- ^ exit code, stdout, stderr +execFlex execConfig pkgBin envBin arguments = + withFrozenCallStack do + cp <- procFlex' execConfig pkgBin envBin arguments + jotString_ . ("━━━━ command ━━━━\n" <>) $ case cmdspec cp of + ShellCommand cmd -> cmd + RawCommand cmd args -> cmd <> " " <> L.unwords (argQuote <$> args) + + readCreateProcessWithExitCode cp "" + +execDetailFlex :: () + => HasCallStack + => r <: Concurrent + => r <: Environment + => r <: Error Failure + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: Hedgehog + => r <: IOE + => r <: Log Text + => ExecConfig + -> String + -> String + -> [String] + -> Eff r (ExitCode, String, String) +execDetailFlex execConfig pkgBin envBin arguments = + withFrozenCallStack do + cp <- procFlex' execConfig pkgBin envBin arguments + jotString_ . ("Command: " <>) $ case cmdspec cp of + ShellCommand cmd -> cmd + RawCommand cmd args -> cmd <> " " <> L.unwords args + readCreateProcessWithExitCode cp "" + +-- | Execute a process, returning '()'. +execOk_ :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Error IOException + => r <: Hedgehog + => r <: IOE + => ExecConfig + -> String + -> [String] + -> Eff 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 :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Error IOException + => r <: Hedgehog + => r <: IOE + => ExecConfig + -> String + -> [String] + -> Eff 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 :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Error IOException + => r <: Hedgehog + => r <: IOE + => ExecConfig + -> String -- ^ The binary to launch + -> [String] -- ^ The binary's arguments + -> Eff r (ExitCode, String, String) -- ^ exit code, stdout, stderr +exec execConfig bin arguments = + withFrozenCallStack do + let cp = (proc bin arguments) + { env = getLast execConfig.execConfigEnv + , cwd = getLast execConfig.execConfigCwd + } + jotString_ . ( "━━━━ command ━━━━\n" <>) $ bin <> " " <> L.unwords (argQuote <$> arguments) + readCreateProcessWithExitCode cp "" + +-- | Wait a maximum of 'seconds' secons for process to exit. +waitSecondsForProcessOk :: () + => HasCallStack + => r <: Concurrent + => r <: Error Failure + => r <: Hedgehog + => r <: IOE + => Int + -> ProcessHandle + -> Eff r ExitCode +waitSecondsForProcessOk seconds hProcess = + withFrozenCallStack do + maybeExitCode <- waitSecondsForProcess seconds hProcess + & trapFail @TimedOut + + case maybeExitCode of + Nothing -> failMessage callStack "No exit code for process" + Just exitCode -> do + jotString_ $ "Process exited " <> show exitCode + return exitCode + +-- | Compute the path to the binary given a package name or an environment variable override. +binFlex :: () + => HasCallStack + => r <: Environment + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => String + -- ^ Package name + -> String + -- ^ Environment variable pointing to the binary to run + -> Eff r FilePath + -- ^ Path to executable +binFlex pkg binaryEnv = + withFrozenCallStack do + maybeEnvBin <- lookupEnvMaybe $ T.pack binaryEnv + case maybeEnvBin of + Just envBin -> return $ T.unpack 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 :: () + => HasCallStack + => r <: Environment + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => String + -- ^ Cabal package name corresponding to the executable + -> String + -- ^ Environment variable pointing to the binary to run + -> [String] + -- ^ Arguments to the CLI command + -> Eff r CreateProcess + -- ^ Captured stdout +procFlex = + procFlex' defaultExecConfig + +procFlex' :: () + => HasCallStack + => r <: Environment + => r <: Error GenericError + => r <: Error IOException + => r <: FileSystem + => r <: IOE + => r <: Log Text + => ExecConfig + -> String + -- ^ Cabal package name corresponding to the executable + -> String + -- ^ Environment variable pointing to the binary to run + -> [String] + -- ^ Arguments to the CLI command + -> Eff r CreateProcess + -- ^ Captured stdout +procFlex' execConfig pkg binaryEnv arguments = + withFrozenCallStack do + bin <- binFlex pkg binaryEnv + return (proc bin arguments) + { env = getLast execConfig.execConfigEnv + , cwd = getLast execConfig.execConfigCwd + -- this allows sending signals to the created processes, without killing the test-suite process + , create_group = True + } diff --git a/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process/Internal.hs b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process/Internal.hs new file mode 100644 index 0000000..dc598cb --- /dev/null +++ b/components/hedgehog/Effectful/Zoo/Hedgehog/Api/Process/Internal.hs @@ -0,0 +1,28 @@ +module Effectful.Zoo.Hedgehog.Api.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 "" = "" diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal index 1bcab56..b607679 100644 --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -52,6 +52,7 @@ common HUnit { build-depends: HUnit >= common hw-prelude { build-depends: hw-prelude >= 0.0.4.4 && < 0.1 } common lifted-base { build-depends: lifted-base >= 0.2.3.12 && < 0.3 } common microlens { build-depends: microlens >= 0.4.13.1 && < 0.5 } +common process { build-depends: process >= 1.6.19 && < 2 } common rds-data-codecs { build-depends: rds-data:codecs >= 0.1.1.1 && < 0.2 } common resourcet { build-depends: resourcet >= 1.3 && < 2 } common resourcet-effectful { build-depends: resourcet-effectful >= 1.0.1 && < 2 } @@ -131,6 +132,7 @@ library core effectful-plugin, effectful, hw-prelude, + process, text, temporary, time, @@ -171,6 +173,7 @@ library core Effectful.Zoo.Log.Dynamic Effectful.Zoo.Log.Static Effectful.Zoo.Prim + Effectful.Zoo.Process Effectful.Zoo.Reader.Static Effectful.Zoo.Unsafe ghc-options: -fplugin=Effectful.Plugin @@ -311,8 +314,14 @@ library hedgehog Effectful.Zoo.Hedgehog.Api.Gen.Time Effectful.Zoo.Hedgehog.Api.Gen.Ulid Effectful.Zoo.Hedgehog.Api.Hedgehog + Effectful.Zoo.Hedgehog.Api.Internal.Cabal + Effectful.Zoo.Hedgehog.Api.Internal.Cabal.Types + Effectful.Zoo.Hedgehog.Api.Internal.FilePath + Effectful.Zoo.Hedgehog.Api.Internal.OS Effectful.Zoo.Hedgehog.Api.Journal Effectful.Zoo.Hedgehog.Api.MonadAssertion + Effectful.Zoo.Hedgehog.Api.Process + Effectful.Zoo.Hedgehog.Api.Process.Internal Effectful.Zoo.Hedgehog.Api.Range Effectful.Zoo.Hedgehog.Api.Stack Effectful.Zoo.Hedgehog.Api.Tasty