cradle (empty) → 0.0.0.0
raw patch · 10 files changed
+1195/−0 lines, 10 filesdep +basedep +bytestringdep +cradle
Dependencies added: base, bytestring, cradle, directory, filepath, hspec, hspec-discover, interpolate, markdown-unlit, mockery, process, silently, string-conversions, text, transformers
Files
- LICENSE +11/−0
- README.lhs +31/−0
- cradle.cabal +89/−0
- src/Cradle.hs +99/−0
- src/Cradle/Output.hs +168/−0
- src/Cradle/ProcessConfiguration.hs +223/−0
- src/Cradle/ProcessConfiguration/Helpers.hs +60/−0
- test/CradleSpec.hs +494/−0
- test/OverloadedStringsSpec.hs +19/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2024 garnix, Co.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.lhs view
@@ -0,0 +1,31 @@+# `cradle`++Conveniently run child processes:++```haskell+{-# LANGUAGE ScopedTypeVariables #-}+import Cradle++main :: IO ()+main = do+ StdoutTrimmed stdout <- run $ cmd "echo" & addArgs ["Hello, World!"]+ print stdout+ -- prints "Hello, World!"++ -- `run` is polymorphic on the return type. Just by adding it to the pattern+ -- match, you can get things like the exit code and stderr:+ (exitCode :: ExitCode, StderrRaw stderr) <- run $ cmd "ls" & addArgs ["does-not-exist"]+ print exitCode+ -- prints ExitFailure 2+ print stderr+ -- prints "ls: cannot access 'does-not-exist': No such file or directory\n"+```++It does _not_ run the processes through a shell, but rather is meant as a high-level interface to `fork` & `exec`.++# Alternatives++- [`process`](https://hackage.haskell.org/package/process): `process` is substantially lower level than `cradle`. That is, it allows for more control, and more options, but at the cost of a more complicated interface. (`cradle` uses `process` under the hood.)+- [`typed-process`](https://hackage.haskell.org/package/typed-process): A safer version of `process`. Still lower-level than `cradle`.+- [`turtle`](https://hackage.haskell.org/package/turtle): `turtle` is a more ambitious library, including a number of system-related functionality (such as changing directories, looking up environment variables, etc.), as well as providing convenient functions for running common executables such as `date` and `rm`. `cradle` by contrast *only* runs specified processes.+- `shake`'s `cmd`. This was the basis for `cradle`, which indeed started it's life as a factoring-out of the `cmd` logic into a separate library. Since then, the API has been cleaned up and generalized. Notable changes are separating `cmd` from `run` so functions can be more easily applied to the command; not being variadic in the arguments for better type inference; and removing `CmdArguments` class altogether in favor of a composition of `ProcessConfiguration -> ProcessConfiguration` functions.
+ cradle.cabal view
@@ -0,0 +1,89 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: cradle+version: 0.0.0.0+synopsis: A simpler process library+description: This library provides an intuitive, simple, and composable interface for+ running system processes. Think of it as a higher-level `process`.+category: System+homepage: https://github.com/garnix-io/cradle#readme+bug-reports: https://github.com/garnix-io/cradle/issues+author: garnix team <dev@garnix.io>+maintainer: garnix team <dev@garnix.io>+license: BSD3+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/garnix-io/cradle++library+ exposed-modules:+ Cradle+ Cradle.Output+ Cradle.ProcessConfiguration+ Cradle.ProcessConfiguration.Helpers+ other-modules:+ Paths_cradle+ hs-source-dirs:+ src+ ghc-options: -Wall -Wno-name-shadowing -threaded+ build-depends:+ base >=4.5 && <5+ , bytestring+ , process+ , string-conversions+ , text+ default-language: Haskell2010++test-suite readme+ type: exitcode-stdio-1.0+ main-is: README.lhs+ other-modules:+ Paths_cradle+ ghc-options: -Wall -Wno-name-shadowing -threaded -pgmL markdown-unlit+ build-depends:+ base >=4.5 && <5+ , bytestring+ , cradle+ , markdown-unlit+ , process+ , string-conversions+ , text+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ CradleSpec+ OverloadedStringsSpec+ Cradle+ Cradle.Output+ Cradle.ProcessConfiguration+ Cradle.ProcessConfiguration.Helpers+ Paths_cradle+ hs-source-dirs:+ test+ src+ ghc-options: -Wall -Wno-name-shadowing -threaded -fdefer-typed-holes+ build-depends:+ base >=4.5 && <5+ , bytestring+ , directory+ , filepath+ , hspec+ , hspec-discover+ , interpolate+ , mockery+ , process+ , silently+ , string-conversions+ , text+ , transformers+ default-language: Haskell2010
+ src/Cradle.hs view
@@ -0,0 +1,99 @@+-- | Create and run child processes and retrieve results from them.+--+-- For example:+--+-- >>> StdoutTrimmed stdout <- run $ cmd "echo" & addArgs ["Hello, World!"]+-- >>> print stdout+-- "Hello, World!"+--+-- == Outputs+--+-- `run` is polymorphic in its output, the output type just has to implement+-- 'Output'. So for example you can get the exit code of a process like this:+--+-- >>> run $ cmd "false" :: IO ExitCode+-- ExitFailure 1+--+-- If you don't want to retrieve any information from a child process, you can+-- use `run_` (or make the output type '()').+--+-- For more information on available output types, see 'Output'.+--+-- == Process Configuration+--+-- To modify the setup of the child process -- e.g. to add arguments or modify+-- stdin or stdout, etc. -- you can use one of the functions that modify+-- 'ProcessConfiguration.ProcessConfiguration', see [here](#processConfiguration). Here's how you add+-- arguments, for example:+--+-- >>> run_ $ cmd "echo" & addArgs ["foo", "bar"]+-- foo bar+-- >>> run_ $ cmd "echo"+-- <BLANKLINE>+--+-- == No Shell, No Automatic Splitting of Strings+--+-- `cradle` will never wrap your process in a shell process.+--+-- `cradle` will not split any inputs by whitespace. So e.g. this doesn't work:+--+-- >>> run_ $ cmd "echo foo bar"+-- *** Exception: echo foo bar: Cradle.run: posix_spawnp: does not exist (No such file or directory)+--+-- This is trying to run an executable with the file name @"echo foo"@, which+-- doesn't exist. If you want to split up arguments automatically, you can do+-- that in haskell though:+--+-- >>> run_ $ cmd "echo" & addArgs (words "foo bar")+-- foo bar+module Cradle+ ( -- * Running Child Processes+ run,+ run_,+ (&),+ -- | #processConfiguration#++ -- * Process Configuration++ -- | Configuration on how to run a process. You can+ --+ -- * create one with 'cmd',+ --+ -- * configure it with functions from 'Cradle.ProcessConfiguration.Helpers',+ -- (which are re-exported from here for convenience) and+ --+ -- * run the process with 'run' or 'run_'.+ --+ -- Usually it shouldn't be necessary to modify its fields directly, but you+ -- *can* import the constructors and fields from+ -- 'Control.ProcessConfiguration'.+ ProcessConfiguration,+ cmd,+ module Cradle.ProcessConfiguration.Helpers,++ -- * Possible Outputs+ Output,+ StdoutUntrimmed (..),+ StdoutTrimmed (..),+ StdoutRaw (..),+ StderrRaw (..),+ ExitCode (..),+ )+where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Cradle.Output+import Cradle.ProcessConfiguration+import Cradle.ProcessConfiguration.Helpers+import Data.Function ((&))+import System.Exit (ExitCode (..))++run :: (Output output, MonadIO m) => ProcessConfiguration -> m output+run = liftIO . runAndGetOutput++-- | Same as `run`, but always returns '()'.+--+-- >>> run_ $ cmd "echo" & addArgs ["Hello, World!"]+-- Hello, World!+run_ :: (MonadIO m) => ProcessConfiguration -> m ()+run_ = run
+ src/Cradle/Output.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Cradle.Output+ ( runAndGetOutput,+ Output (..),+ StdoutUntrimmed (..),+ StdoutTrimmed (..),+ StdoutRaw (..),+ StderrRaw (..),+ )+where++import Control.Arrow ((>>>))+import Cradle.ProcessConfiguration+import Data.ByteString (ByteString)+import Data.Proxy+import Data.String.Conversions (cs)+import Data.Text (Text, strip)+import GHC.Generics (Generic)+import System.Exit+import Prelude hiding (dropWhile)++runAndGetOutput :: forall output. (Output output) => ProcessConfiguration -> IO output+runAndGetOutput config = extractOutput <$> runProcess (configure (Proxy :: Proxy output) config)++class Output output where+ configure :: Proxy output -> ProcessConfiguration -> ProcessConfiguration+ extractOutput :: ProcessResult -> output++instance Output () where+ configure Proxy = id+ extractOutput = const ()++instance+ (Output a, Output b) =>+ Output (a, b)+ where+ configure Proxy =+ configure (Proxy :: Proxy a)+ >>> configure (Proxy :: Proxy b)+ extractOutput result =+ ( extractOutput result,+ extractOutput result+ )++instance+ (Output a, Output b, Output c) =>+ Output (a, b, c)+ where+ configure Proxy =+ configure (Proxy :: Proxy a)+ >>> configure (Proxy :: Proxy b)+ >>> configure (Proxy :: Proxy c)+ extractOutput result =+ ( extractOutput result,+ extractOutput result,+ extractOutput result+ )++instance+ (Output a, Output b, Output c, Output d) =>+ Output (a, b, c, d)+ where+ configure Proxy =+ configure (Proxy :: Proxy a)+ >>> configure (Proxy :: Proxy b)+ >>> configure (Proxy :: Proxy c)+ >>> configure (Proxy :: Proxy d)+ extractOutput result =+ ( extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result+ )++instance+ (Output a, Output b, Output c, Output d, Output e) =>+ Output (a, b, c, d, e)+ where+ configure Proxy =+ configure (Proxy :: Proxy a)+ >>> configure (Proxy :: Proxy b)+ >>> configure (Proxy :: Proxy c)+ >>> configure (Proxy :: Proxy d)+ >>> configure (Proxy :: Proxy e)+ extractOutput result =+ ( extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result+ )++instance+ (Output a, Output b, Output c, Output d, Output e, Output f) =>+ Output (a, b, c, d, e, f)+ where+ configure Proxy =+ configure (Proxy :: Proxy a)+ >>> configure (Proxy :: Proxy b)+ >>> configure (Proxy :: Proxy c)+ >>> configure (Proxy :: Proxy d)+ >>> configure (Proxy :: Proxy e)+ >>> configure (Proxy :: Proxy f)+ extractOutput result =+ ( extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result,+ extractOutput result+ )++newtype StdoutUntrimmed = StdoutUntrimmed+ { fromStdoutUntrimmed :: Text+ }+ deriving stock (Show, Eq, Ord, Generic)++instance Output StdoutUntrimmed where+ configure Proxy config =+ config {stdoutConfig = (stdoutConfig config) {capture = True}}+ extractOutput result =+ let StdoutRaw output = extractOutput result+ in StdoutUntrimmed $ cs output++newtype StdoutTrimmed = StdoutTrimmed+ { fromStdoutTrimmed :: Text+ }+ deriving stock (Show, Eq, Ord, Generic)++instance Output StdoutTrimmed where+ configure Proxy config =+ config {stdoutConfig = (stdoutConfig config) {capture = True}}+ extractOutput result =+ let StdoutRaw output = extractOutput result+ in StdoutTrimmed $ strip $ cs output++newtype StdoutRaw = StdoutRaw+ { fromStdoutRaw :: ByteString+ }+ deriving stock (Show, Eq, Ord, Generic)++instance Output StdoutRaw where+ configure Proxy config =+ config {stdoutConfig = (stdoutConfig config) {capture = True}}+ extractOutput result =+ case stdout result of+ Nothing -> error "impossible: stdout not captured"+ Just output -> StdoutRaw output++newtype StderrRaw = StderrRaw+ { fromStderr :: ByteString+ }+ deriving stock (Show, Eq, Ord, Generic)++instance Output StderrRaw where+ configure Proxy config =+ config {stderrConfig = (stderrConfig config) {capture = True}}+ extractOutput result =+ case stderr result of+ Nothing -> error "impossible: stderr not captured"+ Just stderr -> StderrRaw stderr++instance Output ExitCode where+ configure Proxy config = config {throwOnError = False}+ extractOutput = exitCode
+ src/Cradle/ProcessConfiguration.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}++module Cradle.ProcessConfiguration+ ( ProcessConfiguration (..),+ StdinConfig (..),+ OutputStreamConfig (..),+ silenceDefault,+ addHandle,+ cmd,+ ProcessResult (..),+ runProcess,+ )+where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString, hGetContents, hGetSome, hPut, null)+import System.Environment (getEnvironment)+import System.Exit+import System.IO (Handle)+import System.Posix.Internals (hostIsThreaded)+import System.Process+ ( CreateProcess (..),+ ProcessHandle,+ StdStream (..),+ cleanupProcess,+ createProcess_,+ proc,+ waitForProcess,+ )++data ProcessConfiguration = ProcessConfiguration+ { executable :: String,+ arguments :: [String],+ environmentModification :: Maybe ([(String, String)] -> [(String, String)]),+ workingDir :: Maybe FilePath,+ throwOnError :: Bool,+ stdinConfig :: StdinConfig,+ stdoutConfig :: OutputStreamConfig,+ stderrConfig :: OutputStreamConfig,+ delegateCtlc :: Bool+ }++data StdinConfig+ = InheritStdin+ | UseStdinHandle Handle+ | NoStdinStream++data OutputStreamConfig = OutputStreamConfig+ { capture :: Bool,+ -- | Handles that the user set for the output stream.+ --+ -- @Nothing@ means use the default behavior (which depends on the @capture@+ -- field).+ setHandles :: Maybe [Handle]+ }+ deriving stock (Show)++defaultOutputStreamConfig :: OutputStreamConfig+defaultOutputStreamConfig = OutputStreamConfig False Nothing++silenceDefault :: OutputStreamConfig -> OutputStreamConfig+silenceDefault config =+ config+ { setHandles = case setHandles config of+ Nothing -> Just []+ Just handles -> Just handles+ }++addHandle :: Handle -> OutputStreamConfig -> OutputStreamConfig+addHandle handle config =+ config+ { setHandles = case setHandles config of+ Nothing -> Just [handle]+ Just hs -> Just $ handle : hs+ }++cmd :: String -> ProcessConfiguration+cmd executable =+ ProcessConfiguration+ { executable = executable,+ arguments = [],+ environmentModification = Nothing,+ workingDir = Nothing,+ throwOnError = True,+ stdinConfig = InheritStdin,+ stdoutConfig = defaultOutputStreamConfig,+ stderrConfig = defaultOutputStreamConfig,+ delegateCtlc = False+ }++data ProcessResult = ProcessResult+ { exitCode :: ExitCode,+ stdout :: Maybe ByteString,+ stderr :: Maybe ByteString,+ processConfiguration :: ProcessConfiguration+ }++runProcess :: ProcessConfiguration -> IO ProcessResult+runProcess config = do+ assertThreadedRuntime+ let stdoutHandler = outputStreamHandler $ stdoutConfig config+ stderrHandler = outputStreamHandler $ stderrConfig config+ environment <- forM (environmentModification config) $ \f -> do+ f <$> getEnvironment+ withCreateProcess+ "Cradle.run"+ ( (proc (executable config) (arguments config))+ { cwd = workingDir config,+ std_in = case stdinConfig config of+ InheritStdin -> Inherit+ UseStdinHandle handle -> UseHandle handle+ NoStdinStream -> NoStream,+ std_out = stdStream stdoutHandler,+ std_err = stdStream stderrHandler,+ delegate_ctlc = delegateCtlc config,+ env = environment+ }+ )+ $ \_ mStdout mStderr handle -> do+ waitForStdoutCapture <- startCapturing stdoutHandler mStdout+ waitForStderrCapture <- startCapturing stderrHandler mStderr+ exitCode <- waitForProcess handle+ throwWhenNonZero config exitCode+ stdout <- waitForStdoutCapture+ stderr <- waitForStderrCapture+ return $+ ProcessResult+ { stdout,+ stderr,+ exitCode,+ processConfiguration = config+ }++withCreateProcess :: String -> CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a+withCreateProcess message createProcess action =+ bracket+ (createProcess_ message createProcess)+ cleanupProcess+ (\(mStdin, mStdout, mStderr, processHandle) -> action mStdin mStdout mStderr processHandle)++data OutputStreamHandler = OutputStreamHandler+ { stdStream :: StdStream,+ startCapturing :: Maybe Handle -> IO (IO (Maybe ByteString))+ }++maxBufferSize :: Int+maxBufferSize = 1024 * 1024++outputStreamHandler :: OutputStreamConfig -> OutputStreamHandler+outputStreamHandler config =+ OutputStreamHandler+ { stdStream = case config of+ OutputStreamConfig False Nothing -> Inherit+ OutputStreamConfig False (Just [sink]) -> UseHandle sink+ OutputStreamConfig _ _ -> CreatePipe,+ startCapturing = case config of+ OutputStreamConfig False Nothing -> expectNoHandle $ return $ return Nothing+ OutputStreamConfig True Nothing -> expectHandle $ \handle -> do+ mvar <- newEmptyMVar+ _ <- forkIO $ hGetContents handle >>= putMVar mvar+ return $ Just <$> readMVar mvar+ OutputStreamConfig False (Just []) -> expectHandle $ \_handle -> return $ return Nothing+ OutputStreamConfig False (Just [_sink]) -> expectNoHandle $ return $ return Nothing+ OutputStreamConfig False (Just sinks) -> expectHandle $ \handle -> do+ mvar <- newEmptyMVar+ _ <- forkIO $ do+ let loop = do+ chunk <- hGetSome handle maxBufferSize+ if Data.ByteString.null chunk+ then return ()+ else do+ forM_ sinks $ \sink -> hPut sink chunk+ loop+ loop+ putMVar mvar ()+ return $ do+ readMVar mvar+ return Nothing+ OutputStreamConfig True (Just sinks) -> expectHandle $ \handle -> do+ mvar <- newEmptyMVar+ _ <- forkIO $ do+ let loop acc = do+ chunk <- hGetSome handle maxBufferSize+ if Data.ByteString.null chunk+ then return acc+ else do+ forM_ sinks $ \sink -> hPut sink chunk+ loop $ acc <> chunk+ loop mempty >>= putMVar mvar+ return $ Just <$> readMVar mvar+ }+ where+ expectNoHandle :: IO a -> Maybe Handle -> IO a+ expectNoHandle action = \case+ Just _ -> throwIO $ ErrorCall "outputStreamHandler: pipe created unexpectedly"+ Nothing -> action++ expectHandle :: (Handle -> IO a) -> Maybe Handle -> IO a+ expectHandle action = \case+ Nothing -> throwIO $ ErrorCall "outputStreamHandler: pipe not created unexpectedly"+ Just handle -> action handle++assertThreadedRuntime :: IO ()+assertThreadedRuntime =+ when (not hostIsThreaded) $ do+ throwIO $ ErrorCall "Cradle needs the ghc's threaded runtime system to work correctly. Use the ghc option '-threaded'."++throwWhenNonZero :: ProcessConfiguration -> ExitCode -> IO ()+throwWhenNonZero config exitCode = do+ when (throwOnError config) $ do+ case exitCode of+ ExitSuccess -> return ()+ ExitFailure exitCode -> do+ throwIO $+ ErrorCall $+ "command failed with exitcode "+ <> show exitCode+ <> ": "+ <> executable config
+ src/Cradle/ProcessConfiguration/Helpers.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++module Cradle.ProcessConfiguration.Helpers where++import Cradle.ProcessConfiguration+import Data.String.Conversions (ConvertibleStrings, cs)+import System.IO (Handle)++addArgs :: ConvertibleStrings s String => [s] -> ProcessConfiguration -> ProcessConfiguration+addArgs args config =+ config {arguments = arguments config <> map cs args}++setStdinHandle :: Handle -> ProcessConfiguration -> ProcessConfiguration+setStdinHandle handle config =+ config {stdinConfig = UseStdinHandle handle}++setNoStdin :: ProcessConfiguration -> ProcessConfiguration+setNoStdin config =+ config {stdinConfig = NoStdinStream}++addStdoutHandle :: Handle -> ProcessConfiguration -> ProcessConfiguration+addStdoutHandle handle config =+ config {stdoutConfig = addHandle handle (stdoutConfig config)}++silenceStdout :: ProcessConfiguration -> ProcessConfiguration+silenceStdout config =+ config {stdoutConfig = silenceDefault (stdoutConfig config)}++addStderrHandle :: Handle -> ProcessConfiguration -> ProcessConfiguration+addStderrHandle handle config =+ config {stderrConfig = addHandle handle (stderrConfig config)}++silenceStderr :: ProcessConfiguration -> ProcessConfiguration+silenceStderr config =+ config {stderrConfig = silenceDefault (stderrConfig config)}++setDelegateCtrlC :: ProcessConfiguration -> ProcessConfiguration+setDelegateCtrlC config =+ config {delegateCtlc = True}++modifyEnvVar ::+ String ->+ (Maybe String -> Maybe String) ->+ ProcessConfiguration ->+ ProcessConfiguration+modifyEnvVar name f config =+ config+ { environmentModification =+ Just $ maybe newModification (newModification .) $ environmentModification config+ }+ where+ newModification :: [(String, String)] -> [(String, String)]+ newModification env =+ maybe [] (pure . (name,)) (f $ lookup name env)+ ++ filter ((/= name) . fst) env++setWorkingDir :: FilePath -> ProcessConfiguration -> ProcessConfiguration+setWorkingDir dir config =+ config {workingDir = Just dir}
+ test/CradleSpec.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module CradleSpec where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Exception+import Control.Monad (void, when)+import Control.Monad.Trans.Identity+import Cradle+import Data.ByteString (pack)+import Data.String.Conversions+import Data.String.Interpolate (i)+import Data.String.Interpolate.Util (unindent)+import Data.Text (Text)+import qualified Data.Text+import GHC.IO.Exception+import System.Directory+import System.Environment+import System.FilePath ((</>))+import System.IO (hClose, hGetContents, hIsClosed, hPutStrLn, stderr, stdout)+import System.IO.Silently+import System.Process (createPipe)+import Test.Hspec+import Test.Mockery.Directory+import Test.Mockery.Environment (withModifiedEnvironment)+import Prelude hiding (getContents, length)++spec :: Spec+spec = do+ around_ inTempDirectory $ do+ it "runs simple commands" $ do+ writePythonScript "exe" "open('file', 'w').write('')"+ run_ $ cmd "./exe"+ doesFileExist "file" `shouldReturn` True++ describe "exceptions" $ do+ it "throws when executable cannot be found" $ do+ run_ (cmd "./exe")+ `shouldThrow` ( \(e :: IOException) ->+ ioe_filename e == Just "./exe"+ && ioe_type e == NoSuchThing+ )++ it "throws when the executable flag isn't set" $ do+ writeFile "exe" "whatever"+ run_ (cmd "./exe")+ `shouldThrow` ( \(e :: IOException) ->+ ioe_filename e == Just "./exe"+ && ioe_type e == PermissionDenied+ )++ it "throws when the hashbang interpreter cannot be found" $ do+ writeFile "exe" "#!/does/not/exist\nfoo"+ makeExecutable "exe"+ run_ (cmd "./exe")+ `shouldThrow` ( \(e :: IOException) ->+ ioe_filename e == Just "./exe"+ && ioe_type e == NoSuchThing+ )++ it "runs in MonadIO contexts" $ do+ writePythonScript "exe" "pass"+ runIdentityT $ do+ _ :: StdoutUntrimmed <- run $ cmd "./exe"+ run_ $ cmd "./exe"++ describe "arguments" $ do+ let writeArgumentWriter = do+ writePythonScript+ "exe"+ "open('file', 'w').write(' '.join(sys.argv[1:]))"++ it "allows passing in an argument" $ do+ writeArgumentWriter+ run_ $+ cmd "./exe"+ & addArgs ["foo"]+ readFile "file" `shouldReturn` "foo"++ it "allows passing in multiple arguments" $ do+ writeArgumentWriter+ run_ $+ cmd "./exe"+ & addArgs ["foo", "bar"]+ readFile "file" `shouldReturn` "foo bar"++ it "allows splitting strings in haskell" $ do+ StdoutUntrimmed output <-+ run $+ cmd "printf"+ & addArgs (words "%s.%s foo bar")+ output `shouldBe` cs "foo.bar"++ it "allows Text as arguments" $ do+ StdoutTrimmed output <-+ run $+ cmd "echo"+ & addArgs [cs "foo" :: Text]+ output `shouldBe` cs "foo"++ describe "providing stdin" $ do+ describe "using handles" $ do+ it "allows passing in a handle for stdin" $ do+ writePythonScript "exe" "print(sys.stdin.read().strip())"+ (readEnd, writeEnd) <- createPipe+ _ <- forkIO $ do+ hPutStrLn writeEnd "test stdin"+ hClose writeEnd+ StdoutUntrimmed output <-+ run $+ cmd "./exe"+ & setStdinHandle readEnd+ output `shouldBe` cs "test stdin\n"++ it "allows disabling inheriting stdin" $ do+ writePythonScript "exe" "print(sys.stdin)"+ StdoutTrimmed output <- run $ cmd "./exe" & setNoStdin+ output `shouldBe` cs "None"++ describe "capturing stdout" $ do+ it "allows capturing stdout" $ do+ writePythonScript "exe" "print('output')"+ StdoutUntrimmed stdout <- run $ cmd "./exe"+ stdout `shouldBe` cs "output\n"++ it "allows capturing stdout *and* pass in arguments" $ do+ writePythonScript "exe" "print(' '.join(sys.argv[1:]))"+ StdoutUntrimmed output <-+ run $+ cmd "./exe"+ & addArgs ["foo"]+ output `shouldBe` cs "foo\n"+ StdoutUntrimmed output <- run $ cmd "./exe" & addArgs ["foo", "bar"]+ output `shouldBe` cs "foo bar\n"++ it "relays stdout when it's not captured (by default)" $ do+ writePythonScript "exe" "print('foo')"+ output <- capture_ $ run_ $ cmd "./exe"+ output `shouldBe` "foo\n"++ it "allows silencing stdout when it's not captured" $ do+ writePythonScript "exe" "print('foo')"+ output <- hCapture_ [stdout] $ run_ $ cmd "./exe" & silenceStdout+ output `shouldBe` ""++ it "does not relay stdout when it's captured (by default)" $ do+ writePythonScript "exe" "print('foo')"+ output <- capture_ $ do+ StdoutUntrimmed _ <- run $ cmd "./exe"+ return ()+ output `shouldBe` ""++ describe "StdoutTrimmed" $ do+ it "allows capturing the stripped stdout" $ do+ writePythonScript "exe" "print('foo')"+ StdoutTrimmed output <- run $ cmd "./exe" & addArgs ["foo"]+ output `shouldBe` cs "foo"++ it "strips leading and trailing spaces and newlines" $ do+ writePythonScript "exe" "print(' foo ')"+ StdoutTrimmed output <- run $ cmd "./exe" & addArgs ["foo"]+ output `shouldBe` cs "foo"++ it "handles bigger outputs correctly" $ do+ writePythonScript "exe" "print('x' * 2 ** 22)"+ StdoutTrimmed output <- run $ cmd "./exe"+ Data.Text.length output `shouldBe` 2 ^ (22 :: Int)++ it "allows capturing binary data" $ do+ writePythonScript "exe" "sys.stdout.buffer.write(bytearray([0, 1, 2, 3]))"+ StdoutRaw output <- run $ cmd "./exe"+ output `shouldBe` pack [0, 1, 2, 3]++ it "uses the replacement character when capturing invalid utf-8 as Text" $ do+ writePythonScript "exe" "sys.stdout.buffer.write(b'foo-\\x80-bar')"+ StdoutUntrimmed output <- run $ cmd "./exe"+ output `shouldBe` cs "foo-�-bar"++ describe "using handles" $ do+ it "allows sending stdout to a handle" $ do+ writePythonScript "exe" "print('foo')"+ (readEnd, writeEnd) <- createPipe+ run_ $ cmd "./exe" & addStdoutHandle writeEnd+ hClose writeEnd+ hGetContents readEnd `shouldReturn` cs "foo\n"++ it "does not relay stdout when it's captured (by default)" $ do+ writePythonScript "exe" "print('foo')"+ (_readEnd, writeEnd) <- createPipe+ stdout <- capture_ $ run_ $ cmd "./exe" & addStdoutHandle writeEnd+ hClose writeEnd+ stdout `shouldBe` ""++ it "doesn't close the handle after running the process" $ do+ writePythonScript "exe" "print(sys.argv[1])"+ (readEnd, writeEnd) <- createPipe+ run_ $+ cmd "./exe"+ & addArgs ["foo"]+ & addStdoutHandle writeEnd+ hIsClosed writeEnd `shouldReturn` False+ hIsClosed readEnd `shouldReturn` False+ run_ $+ cmd "./exe"+ & addArgs ["bar"]+ & addStdoutHandle writeEnd+ hClose writeEnd+ hGetContents readEnd `shouldReturn` cs "foo\nbar\n"++ it "allows capturing stdout *and* passing in a stdout handle" $ do+ writePythonScript "exe" "print('foo')"+ (readEnd, writeEnd) <- createPipe+ StdoutUntrimmed output <-+ run $+ cmd "./exe"+ & addStdoutHandle writeEnd+ hClose writeEnd+ handleOutput <- hGetContents readEnd+ (output, handleOutput) `shouldBe` (cs "foo\n", "foo\n")++ it "allows specifying multiple stdout handles" $ do+ writePythonScript "exe" "print('foo')"+ (readEnd1, writeEnd1) <- createPipe+ (readEnd2, writeEnd2) <- createPipe+ run_ $+ cmd "./exe"+ & addStdoutHandle writeEnd1+ & addStdoutHandle writeEnd2+ hClose writeEnd1+ hClose writeEnd2+ output1 <- hGetContents readEnd1+ output2 <- hGetContents readEnd2+ (output1, output2) `shouldBe` ("foo\n", "foo\n")++ describe "capture stderr" $ do+ it "allows capturing stderr" $ do+ writePythonScript "exe" "print('output', file=sys.stderr)"+ StderrRaw stderr <- run $ cmd "./exe"+ stderr `shouldBe` cs "output\n"++ it "relays stderr when it's not captured (by default)" $ do+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ output <- hCapture_ [stderr] $ run_ $ cmd "./exe"+ output `shouldBe` "foo\n"++ it "allows silencing stderr when it's not captured" $ do+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ output <- hCapture_ [stderr] $ run_ $ cmd "./exe" & silenceStderr+ output `shouldBe` ""++ it "does not relay stderr when it's captured (by default)" $ do+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ output <- hCapture_ [stderr] $ do+ StderrRaw _ <- run $ cmd "./exe"+ return ()+ output `shouldBe` ""++ describe "using handles" $ do+ it "allows sending stderr to a handle" $ do+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ (readEnd, writeEnd) <- createPipe+ run_ $+ cmd "./exe"+ & addStderrHandle writeEnd+ hClose writeEnd+ hGetContents readEnd `shouldReturn` cs "foo\n"++ it "does not relay stderr when it's captured (by default)" $ do+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ (_readEnd, writeEnd) <- createPipe+ stderr <- hCapture_ [stderr] $ run_ $ cmd "./exe" & addStderrHandle writeEnd+ hClose writeEnd+ stderr `shouldBe` ""++ it "doesn't close the handle after running the process" $ do+ writePythonScript "exe" "print(sys.argv[1], file=sys.stderr)"+ (readEnd, writeEnd) <- createPipe+ run_ $+ cmd "./exe"+ & addStderrHandle writeEnd+ & addArgs ["foo"]+ hIsClosed writeEnd `shouldReturn` False+ hIsClosed readEnd `shouldReturn` False+ run_ $+ cmd "./exe"+ & addStderrHandle writeEnd+ & addArgs ["bar"]+ hClose writeEnd+ hGetContents readEnd `shouldReturn` cs "foo\nbar\n"++ it "allows writing a wrapper that captures stderr" $ do+ let wrapper :: Output output => ProcessConfiguration -> IO output+ wrapper pc = do+ (exitCode, StderrRaw err, o) <- run pc+ when (exitCode /= ExitSuccess) $ do+ throwIO $ ErrorCall $ "stderr:\n" <> cs err+ return o+ writePythonScript "exe" "print('foo', file=sys.stderr)"+ (readEnd, writeEnd) <- createPipe+ StderrRaw output <-+ wrapper $+ cmd "./exe"+ & addStderrHandle writeEnd+ hClose writeEnd+ handleOutput <- hGetContents readEnd+ (output, handleOutput) `shouldBe` (cs "foo\n", "foo\n")+ writePythonScript "exe" "print('foo', file=sys.stderr); sys.exit(42)"+ try (wrapper $ cmd "./exe" :: IO ())+ `shouldReturn` Left (ErrorCall "stderr:\nfoo\n")++ it "allows capturing both stdout and stderr" $ do+ writePythonScript "exe" "print('out') ; print('err', file=sys.stderr)"+ (StdoutUntrimmed out, StderrRaw err) <- run $ cmd "./exe"+ (out, err) `shouldBe` (cs "out\n", cs "err\n")++ describe "exitcodes" $ do+ it "throws when the exitcode is not 0" $ do+ writePythonScript "exe" "sys.exit(42)"+ run_ (cmd "./exe")+ `shouldThrowShow` "command failed with exitcode 42: ./exe"++ it "doesn't throw when the exitcode is captured" $ do+ writePythonScript "exe" "sys.exit(42)"+ exitCode <- run $ cmd "./exe"+ exitCode `shouldBe` ExitFailure 42++ it "captures success exitcodes" $ do+ writePythonScript "exe" "pass"+ run (cmd "./exe") `shouldReturn` ExitSuccess++ it "allows capturing exitcodes and stdout" $ do+ writePythonScript "exe" "print('foo'); sys.exit(42)"+ (exitCode, StdoutTrimmed stdout) <- run $ cmd "./exe"+ stdout `shouldBe` cs "foo"+ exitCode `shouldBe` ExitFailure 42++ describe "working directory" $ do+ it "inherits the current working directory" $ do+ writePythonScript "exe" "print(os.getcwd())"+ StdoutTrimmed stdout <- run $ cmd "./exe"+ cwd <- getCurrentDirectory+ stdout `shouldBe` cs cwd++ it "allows setting the working directory" $ do+ writePythonScript "exe" "print(os.getcwd())"+ createDirectory "dir"+ cwd <- getCurrentDirectory+ StdoutTrimmed stdout <-+ run $+ cmd (cwd </> "./exe")+ & setWorkingDir "dir"+ stdout `shouldBe` cs (cwd </> "dir")++ it "does not modify the parent's working directory" $ do+ writePythonScript "exe" "print('foo')"+ createDirectory "dir"+ before <- getCurrentDirectory+ StdoutTrimmed output <-+ run $+ cmd (before </> "./exe")+ & setWorkingDir "dir"+ after <- getCurrentDirectory+ output `shouldBe` cs "foo"+ after `shouldBe` before++ describe "when receiving an async exception" $ do+ it "sends a signal to the child process" $ do+ writePythonScript "exe" $+ unindent+ [i|+ import signal+ import time+ import os++ def handler(signal, stack_frame):+ open('received-signal', 'a').write(f'received signal: {signal}')+ exit(0)++ signal.signal(signal.SIGTERM, handler)+ open('running', 'a').write('')+ time.sleep(3)+ |]+ thread <- forkIO $ run_ $ cmd "./exe"+ waitFor $ void $ readFile "running"+ killThread thread+ waitFor $ do+ readFile "received-signal" `shouldReturn` "received signal: 15"++ describe "environment" $ do+ it "inherits the environment (by default)" $ do+ withModifiedEnvironment [("TEST_ENV_VAR", "foo")] $ do+ writePythonScript "exe" "print(os.environ.get('TEST_ENV_VAR'))"+ StdoutTrimmed stdout <- run $ cmd "./exe"+ stdout `shouldBe` cs "foo"++ describe "modifyEnvVar" $ do+ it "allows setting environment variables" $ do+ writePythonScript "exe" "print(os.environ.get('TEST_ENV_VAR'))"+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "TEST_ENV_VAR" (const $ Just "foo")+ stdout `shouldBe` cs "foo"++ it "doesn't overwrite existing environment variables" $ do+ withModifiedEnvironment [("TEST_ENV_VAR", "foo")] $ do+ writePythonScript "exe" "print(os.environ.get('TEST_ENV_VAR'))"+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "OTHER_ENV_VAR" (const $ Just "bar")+ stdout `shouldBe` cs "foo"++ it "allows modifying environment variables" $ do+ withModifiedEnvironment [("TEST_ENV_VAR", "foo"), ("OTHER_VAR", "bar")] $ do+ writePythonScript "exe" $+ unindent+ [i|+ print(os.environ.get('TEST_ENV_VAR'))+ print(os.environ.get('OTHER_VAR'))+ |]+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "TEST_ENV_VAR" (fmap reverse)+ stdout `shouldBe` cs "oof\nbar"++ it "allows removing environment variables" $ do+ withModifiedEnvironment [("TEST_ENV_VAR", "foo")] $ do+ writePythonScript "exe" "print(os.environ.get('TEST_ENV_VAR'))"+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "TEST_ENV_VAR" (const Nothing)+ stdout `shouldBe` cs "None"++ it "allows setting multiple environment variables" $ do+ writePythonScript "exe" $+ unindent+ [i|+ print(os.environ.get('TEST_ENV_VAR'))+ print(os.environ.get('OTHER_VAR'))+ |]+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "TEST_ENV_VAR" (const $ Just "foo")+ & modifyEnvVar "OTHER_VAR" (const $ Just "bar")+ stdout `shouldBe` cs "foo\nbar"++ it "allows modifying environment variables multiple times" $ do+ writePythonScript "exe" "print(os.environ.get('TEST_ENV_VAR'))"+ StdoutTrimmed stdout <-+ run $+ cmd "./exe"+ & modifyEnvVar "TEST_ENV_VAR" (const $ Just "foo")+ & modifyEnvVar "TEST_ENV_VAR" (fmap reverse)+ stdout `shouldBe` cs "oof"++writePythonScript :: FilePath -> String -> IO ()+writePythonScript file code = do+ pythonPath <- getEnv "PYTHON_BIN_PATH"+ writeFile file ("#!" <> pythonPath <> "\nimport os\nimport sys\n" <> code)+ makeExecutable file++makeExecutable :: FilePath -> IO ()+makeExecutable file = do+ permissions <- getPermissions file+ setPermissions file $ setOwnerExecutable True permissions++shouldThrowShow :: IO a -> String -> IO ()+shouldThrowShow action expected = do+ result <-+ (action >> return Nothing)+ `catch` (\(e :: SomeException) -> return $ Just e)+ case result of+ Nothing -> fail $ "action didn't throw: " <> expected+ Just e -> show e `shouldBe` expected++waitFor :: IO () -> IO ()+waitFor action = go 10+ where+ go n = do+ mException :: Either SomeException () <- try action+ case mException of+ Right () -> return ()+ Left exception ->+ if n <= 0+ then throwIO $ ErrorCall $ "waitFor timed out: " <> show exception+ else do+ threadDelay 100000+ go (n - 1)
+ test/OverloadedStringsSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module OverloadedStringsSpec where++import Cradle+import Test.Hspec+import Test.Mockery.Directory++spec :: Spec+spec = do+ around_ inTempDirectory $ do+ it "works with overloaded strings" $ do+ StdoutUntrimmed _ <-+ run $+ cmd "ls"+ & addArgs ["-la"]+ return () :: IO ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}