diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 FP Complete, https://www.fpcomplete.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,485 @@ +## typed-process + +[![Build Status](https://travis-ci.org/fpco/typed-process.svg?branch=master)](https://travis-ci.org/fpco/typed-process) [![Build status](https://ci.appveyor.com/api/projects/status/bhh7aekbgeqp7g5j/branch/master?svg=true)](https://ci.appveyor.com/project/snoyberg/typed-process/branch/master) + +This library provides the ability to launch and interact with external +processes. It wraps around the +[process library](https://haskell-lang.org/library/process), and +intends to improve upon it by: + +1. Using type variables to represent the standard streams, making them + easier to manipulate +2. Use proper concurrency (e.g., the async library) in place of the + weird lazy I/O tricks for such things as consuming output streams +3. Allow for more complex concurrency by providing STM-based functions +4. Using binary I/O correctly +5. Providing a more composable API, designed to be easy to use for + both simple and complex use cases + +## Synopsis + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.IO (hPutStr, hClose) +import System.Process.Typed +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import Control.Concurrent.STM (atomically) +import Control.Exception (throwIO) + +main :: IO () +main = do + -- Run a process, print its exit code + runProcess "true" >>= print + runProcess "false" >>= print + + -- Check that the exit code is a success + runProcess_ "true" + -- This will throw an exception: runProcess_ "false" + + -- Capture output and error + (dateOut, dateErr) <- readProcess_ "date" + print (dateOut, dateErr) + + -- Use shell commands + (dateOut2, dateErr2) <- readProcess_ "date >&2" + print (dateOut2, dateErr2) + + -- Interact with a process + let catConfig = setStdin createPipe + $ setStdout byteStringOutput + $ proc "cat" ["/etc/hosts", "-", "/etc/group"] + withProcess_ catConfig $ \p -> do + hPutStr (getStdin p) "\n\nHELLO\n" + hPutStr (getStdin p) "WORLD\n\n\n" + hClose (getStdin p) + + atomically (getStdout p) >>= L8.putStr +``` + +## Types + +The two primary types in this package are `ProcessConfig` and +`Process`. `ProcessConfig` gives a specification for how to run a +process (e.g., the command to run, working directory, environment +variables) and how to deal with the three standard streams: input, +output, and error. You use one of the functions in this package for +launching a process to turn a `ProcessConfig` into a `Process`, which +represents an actual running system process. + +The easiest way to create a `ProcessConfig` is using the `IsString` +instance and `OverloadedStrings`. For example, to run the `date` +command, we can do the following. (NOTE: The type signatures used here +are simply to spell things out, they are not needed.) + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = do + let dateConfig :: ProcessConfig () () () + dateConfig = "date" + + process <- startProcess dateConfig + exitCode <- waitExitCode (process :: Process () () ()) + print exitCode + + stopProcess process +``` + +This shows the general workflow: use `startProcess` to launch a +`Process` from a `ProcessConfig`, interact with it (such as +`waitExitCode` to wait for the process to exit), and then clean up +resources with `stopProcess`. (We'll get to those `() () ()` type +parameters in the next section.) + +Instead of explicitly dealing with `startProcess` and `stopProcess`, +it's recommended to instead use `withProcess`, which uses the bracket +pattern and is exception safe: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = withProcess "date" $ \process -> do + exitCode <- waitExitCode (process :: Process () () ()) + print exitCode +``` + +But this pattern of running a process, waiting for it to exit, and +getting its exit code is very common, so it has a helper function of +its own: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = do + exitCode <- runProcess "date" + print exitCode +``` + +We'll discuss some functions which automatically check the exit code +below. + +## Type parameters + +Both `ProcessConfig` and `Process` each take three type parameters, +with the type of the standard input, output, and error streams for the +process. As you saw above, our default is `()` for each, and our +default behavior is to inherit the streams from the parent +process. This is why, when you run the previous programs, the `date` +program's output goes directly to your console. + +We can override these defaults in a number of ways. Perhaps the +easiest is to simply close the stream for the child so it cannot use +it at all. + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = do + let dateConfig :: ProcessConfig () () () + dateConfig = setStdin closed + $ setStdout closed + $ setStderr closed + "date" + exitCode <- runProcess dateConfig + print exitCode +``` + +A few things to note: + +* The type parameter is still `()`, since there's no data to + return. We'll see some more interesting cases later. +* This process now returns an `ExitFailure 1`, since it tries to write + to a closed `stdout` file descriptor. + +## Using `proc` and `shell` + +Using the `OverloadedStrings` approach works nicely for some cases, +but we'll often want more control over things. There are two smart +constructors available: `proc` takes a command and list of arguments, +and `shell` takes a single string which will be passed directly to the +system's shell. + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = do + -- Command and arguments + runProcess (proc "cat" ["/etc/hosts"]) >>= print + + -- Shell + runProcess (shell "cat /etc/hosts >&2 && false") >>= print +``` + +The behavior of the `OverloadedStrings` approach we've used until now +is actually based on these two smart constructors. If you provide it a +string without any spaces (like `"date"`), it will use `proc` without +any arguments, e.g. `fromString "date" = proc "date" []`. If there are +any spaces in the string, it will use `shell`. + +__EXERCISE__: Rewrite the previous example to not use the `shell` +constructor. + +## Checking the exit code + +We've done a lot of printing of exit codes. In many cases, we don't +actually want to look at the exit code, but instead just throw an +exception if the process failed. Fortunately, we have such an +exit-code-checking function. + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = runProcess_ "date" +``` + +By adding the `_` at the end of `runProcess`, we're now automatically +checking the exit code and throwing an exception if it returns +anything but success. Want to see it in action? + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = runProcess_ "false" +``` + +Under the surface, this function is using the `checkExitCode` +function. We can do this more explicitly if desired: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = withProcess "false" checkExitCode +``` + +## Reading from a process + +Sending all output to the parent process's handles is sometimes +desired, but often we'd rather just capture that output. The easiest +way to do that is to capture it in memory as a lazy +`ByteString`. Fortunately, we have a helper `readProcess` function for +that: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import System.Exit (ExitCode) +import Data.ByteString.Lazy (ByteString) + +main :: IO () +main = do + (exitCode, out, err) <- readProcess "date" + print (exitCode :: ExitCode) + print (out :: ByteString) + print (err :: ByteString) +``` + +One thing to point out is that, even though this is a lazy +`ByteString`, it is not using any lazy I/O. When `readProcess` exits, +the output has been fully generated, and is resident in memory. We +only use a lazy `ByteString` instead of a strict one for better memory +configuration (chunking into multiple smaller bits instead of one +massive chunk of data). + +Like `runProcess`, there's an exit-code-checking variant of +`readProcess`: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import Data.ByteString.Lazy (ByteString) + +main :: IO () +main = do + (out, err) <- readProcess_ "date" + print (out :: ByteString) + print (err :: ByteString) +``` + +__EXERCISE__: Use shell redirection to move the output from standard +output to standard error. + +## Redirecting to a file + +Another technique we'll commonly want to employ is to redirect output +from a process to a file. This is superior to the memory approach as +it does not have the risk of using large amounts of memory, though it +is more inconvenient. Together with the +[temporary library](https://www.stackage.org/package/temporary), we +can do some nice things: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process --package temporary +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import System.IO.Temp (withSystemTempFile) + +main :: IO () +main = withSystemTempFile "date" $ \fp h -> do + let dateConfig = setStdin closed + $ setStdout (useHandleClose h) + $ setStderr closed + "date" + + runProcess_ dateConfig + + readFile fp >>= print +``` + +The `useHandleClose` function lets us provide an already existing +`Handle`, and will close it when done. If you want to write the output +of multiple processes to a single file, you can instead use +`useHandleOpen`: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process --package temporary +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import System.IO (hClose) +import System.IO.Temp (withSystemTempFile) +import Control.Monad (replicateM_) + +main :: IO () +main = withSystemTempFile "date" $ \fp h -> do + let dateConfig = setStdin closed + $ setStdout (useHandleOpen h) + $ setStderr closed + "date" + + replicateM_ 10 $ runProcess_ dateConfig + hClose h + + readFile fp >>= putStrLn +``` + +__EXERCISE__ Create a separate file for error output and capture that +as well. + +## Providing input + +Using `OverloadedStrings`, it's trivial to provide some input to a +process: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process --package temporary +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = runProcess_ $ setStdin "Hello World!\n" "cat" +``` + +This is just a shortcut for using the `byteStringInput` function: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process --package temporary +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = runProcess_ $ setStdin (byteStringInput "Hello World!\n") "cat" +``` + +But like output and error, we can also use a `Handle` or a temporary +file: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process --package temporary +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import System.IO +import System.IO.Temp (withSystemTempFile) + +main :: IO () +main = withSystemTempFile "input" $ \fp h -> do + hPutStrLn h "Hello World!" + hClose h + + withBinaryFile fp ReadMode $ \h' -> + runProcess_ $ setStdin (useHandleClose h') "cat" +``` + +## Interacting with a process + +So far, everything we've done has been _running_ processes: spawning a +child with some settings, then waiting for it to exit. We will often +want to _interact_ with a process: spawn it, and then send it input or +receive output from it while it is still running. + +For this, using `createPipe` makes a lot of sense: + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed +import System.IO + +main :: IO () +main = do + let catConfig = setStdin createPipe + $ setStdout createPipe + $ setStderr closed + "cat" + + withProcess_ catConfig $ \p -> do + hPutStrLn (getStdin p) "Hello!" + hFlush (getStdin p) + hGetLine (getStdout p) >>= print + + hClose (getStdin p) +``` + +__EXERCISE__: What happens if you remove the `hClose` line, and why? +Hint: what happens if you both remove `hClose` _and_ replace +`withProcess_` with `withProcess`? + +## Other settings + +We've so far only played with modifying streams, but there are a +number of other settings you can tweak. It's best to just look at the +API docs for all available functions. We'll give examples of the two +most common settings: the working directory and environment variables. + +```haskell +#!/usr/bin/env stack +-- stack --resolver lts-7.3 --install-ghc runghc --package typed-process +{-# LANGUAGE OverloadedStrings #-} +import System.Process.Typed + +main :: IO () +main = do + putStrLn "1:" + runProcess_ "pwd" + putStrLn "\n2:" + runProcess_ $ setWorkingDir "/tmp" "pwd" + + putStrLn "\n3:" + runProcess_ "env" + putStrLn "\n4:" + runProcess_ $ setEnv [("HELLO", "WORLD")] "env" +``` + +## Async and STM + +When interacting with a process on multiple streams, you'll often want +to use some kind of concurrency. The strong recommendation is to use +the +[async library](https://haskell-lang.org/library/async). Additionally, +this library provides a number of functions that use STM, which also +plays very nicely with concurrency and the async package. For some +examples, check out: + +* `waitExitCodeSTM` +* `getExitCodeSTM` +* `checkExitCodeSTM` +* `byteStringOutput` + +__EXERCISE__ Reimplement the `readProcess` function using +`byteStringOutput` and `waitExitCodeSTM`. + +__EXERCISE__ Reimplement the `readProcess_` function using +`byteStringOutput` and `checkExitCodeSTM`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Typed.hs @@ -0,0 +1,824 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Please see the README.md file for examples of using this API. +module System.Process.Typed + ( -- * Types + ProcessConfig + , StreamSpec + , StreamType (..) + , Process + + -- * ProcessConfig + -- ** Smart constructors + , proc + , shell + + -- ** Setters + , setStdin + , setStdout + , setStderr + , setWorkingDir + , setEnv + , setCloseFds + , setCreateGroup + , setDelegateCtlc +#if MIN_VERSION_process(1, 3, 0) + , setDetachConsole + , setCreateNewConsole + , setNewSession +#endif +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS + , setChildGroup + , setChildUser +#endif + + -- * Stream specs + , mkStreamSpec + , inherit + , closed + , byteStringInput + , byteStringOutput + , createPipe + , useHandleOpen + , useHandleClose + + -- ** Conduit + , createSink + , createSource + + -- * Launch a process + , startProcess + , stopProcess + , withProcess + , withProcess_ + , readProcess + , readProcess_ + , runProcess + , runProcess_ + + -- * Interact with a process + + -- ** Process exit code + , waitExitCode + , waitExitCodeSTM + , getExitCode + , getExitCodeSTM + , checkExitCode + , checkExitCodeSTM + + -- ** Process streams + , getStdin + , getStdout + , getStderr + + -- * Exceptions + , ExitCodeException (..) + , ByteStringOutputException (..) + ) where + +import qualified Data.ByteString as S +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Control.Exception (throwIO) +import Control.Monad (void) +import Control.Monad.IO.Class +import qualified System.Process as P +import Control.Monad.Catch as C +import Data.Typeable (Typeable) +import System.IO (Handle, hClose) +import Control.Concurrent.Async (async, cancel, waitCatch) +import Control.Concurrent.STM (newEmptyTMVarIO, atomically, putTMVar, TMVar, readTMVar, tryReadTMVar, STM, tryPutTMVar, throwSTM, catchSTM) +import System.Exit (ExitCode (ExitSuccess)) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.String (IsString (fromString)) +import Data.Conduit (ConduitM) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB + +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS +import System.Posix.Types (GroupID, UserID) +#endif + +#if !MIN_VERSION_base(4, 8, 0) +import Control.Applicative (Applicative (..), (<$>), (<$)) +#endif + +#if !MIN_VERSION_process(1, 3, 0) +import qualified System.Process.Internals as P (createProcess_) +#endif + +-- | An abstract configuration for a process, which can then be +-- launched into an actual running 'Process'. Takes three type +-- parameters, providing the types of standard input, standard output, +-- and standard error, respectively. +-- +-- There are three ways to construct a value of this type: +-- +-- * With the 'proc' smart constructor, which takes a command name and +-- a list of arguments. +-- +-- * With the 'shell' smart constructor, which takes a shell string +-- +-- * With the 'IsString' instance via OverloadedStrings. If you +-- provide it a string with no spaces (e.g., @"date"@), it will +-- treat it as a raw command with no arguments (e.g., @proc "date" +-- []@). If it has spaces, it will use @shell@. +-- +-- In all cases, the default for all three streams is to inherit the +-- streams from the parent process. For other settings, see the +-- setters below for default values. +-- +-- @since 0.1.0.0 +data ProcessConfig stdin stdout stderr = ProcessConfig + { pcCmdSpec :: !P.CmdSpec + , pcStdin :: !(StreamSpec 'STInput stdin) + , pcStdout :: !(StreamSpec 'STOutput stdout) + , pcStderr :: !(StreamSpec 'STOutput stderr) + , pcWorkingDir :: !(Maybe FilePath) + , pcEnv :: !(Maybe [(String, String)]) + , pcCloseFds :: !Bool + , pcCreateGroup :: !Bool + , pcDelegateCtlc :: !Bool + +#if MIN_VERSION_process(1, 3, 0) + , pcDetachConsole :: !Bool + , pcCreateNewConsole :: !Bool + , pcNewSession :: !Bool +#endif + +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS + , pcChildGroup :: !(Maybe GroupID) + , pcChildUser :: !(Maybe UserID) +#endif + } +instance Show (ProcessConfig stdin stdout stderr) where + show pc = concat + [ case pcCmdSpec pc of + P.ShellCommand s -> "Shell command: " ++ s + P.RawCommand x xs -> "Raw command: " ++ unwords (map escape (x:xs)) + , "\n" + , case pcWorkingDir pc of + Nothing -> "" + Just wd -> concat + [ "Run from: " + , wd + , "\n" + ] + , case pcEnv pc of + Nothing -> "" + Just e -> unlines + $ "Modified environment:" + : map (\(k, v) -> concat [k, "=", v]) e + ] + where + escape x + | any (`elem` " \\\"'") x = show x + | otherwise = x +instance (stdin ~ (), stdout ~ (), stderr ~ ()) + => IsString (ProcessConfig stdin stdout stderr) where + fromString s + | any (== ' ') s = shell s + | otherwise = proc s [] + +-- | Whether a stream is an input stream or output stream. Note that +-- this is from the perspective of the /child process/, so that a +-- child's standard input stream is an @STInput@, even though the +-- parent process will be writing to it. +-- +-- @since 0.1.0.0 +data StreamType = STInput | STOutput + +-- | A specification for how to create one of the three standard child +-- streams. See examples below. +-- +-- @since 0.1.0.0 +data StreamSpec (streamType :: StreamType) a = StreamSpec + { ssStream :: !P.StdStream + , ssCreate :: !(ProcessConfig () () () -> Maybe Handle -> Cleanup a) + } + deriving Functor + +-- | This instance uses 'byteStringInput' to convert a raw string into +-- a stream of input for a child process. +-- +-- @since 0.1.0.0 +instance (streamType ~ 'STInput, res ~ ()) + => IsString (StreamSpec streamType res) where + fromString = byteStringInput . fromString + +-- | Internal type, to make for easier composition of cleanup actions. +-- +-- @since 0.1.0.0 +newtype Cleanup a = Cleanup { runCleanup :: IO (a, IO ()) } + deriving Functor +instance Applicative Cleanup where + pure x = Cleanup (return (x, return ())) + Cleanup f <*> Cleanup x = Cleanup $ do + (f', c1) <- f + (`onException` c1) $ do + (x', c2) <- x + return (f' x', c1 `finally` c2) + +-- | A running process. The three type parameters provide the type of +-- the standard input, standard output, and standard error streams. +-- +-- @since 0.1.0.0 +data Process stdin stdout stderr = Process + { pConfig :: !(ProcessConfig () () ()) + , pCleanup :: !(IO ()) + , pStdin :: !stdin + , pStdout :: !stdout + , pStderr :: !stderr + , pHandle :: !P.ProcessHandle + , pExitCode :: !(TMVar ExitCode) + } +instance Show (Process stdin stdout stderr) where + show p = "Running process: " ++ show (pConfig p) + +-- | Internal helper +defaultProcessConfig :: ProcessConfig () () () +defaultProcessConfig = ProcessConfig + { pcCmdSpec = P.ShellCommand "" + , pcStdin = inherit + , pcStdout = inherit + , pcStderr = inherit + , pcWorkingDir = Nothing + , pcEnv = Nothing + , pcCloseFds = False + , pcCreateGroup = False + , pcDelegateCtlc = False + +#if MIN_VERSION_process(1, 3, 0) + , pcDetachConsole = False + , pcCreateNewConsole = False + , pcNewSession = False +#endif + +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS + , pcChildGroup = Nothing + , pcChildUser = Nothing +#endif + } + +-- | Create a 'ProcessConfig' from the given command and arguments. +-- +-- @since 0.1.0.0 +proc :: FilePath -> [String] -> ProcessConfig () () () +proc cmd args = setProc cmd args defaultProcessConfig + +-- | Internal helper +setProc :: FilePath -> [String] + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setProc cmd args p = p { pcCmdSpec = P.RawCommand cmd args } + +-- | Create a 'ProcessConfig' from the given shell command. +-- +-- @since 0.1.0.0 +shell :: String -> ProcessConfig () () () +shell cmd = setShell cmd defaultProcessConfig + +-- | Internal helper +setShell :: String + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setShell cmd p = p { pcCmdSpec = P.ShellCommand cmd } + +-- | Set the child's standard input stream to the given 'StreamSpec'. +-- +-- Default: 'inherit' +-- +-- @since 0.1.0.0 +setStdin :: StreamSpec 'STInput stdin + -> ProcessConfig stdin0 stdout stderr + -> ProcessConfig stdin stdout stderr +setStdin spec pc = pc { pcStdin = spec } + +-- | Set the child's standard output stream to the given 'StreamSpec'. +-- +-- Default: 'inherit' +-- +-- @since 0.1.0.0 +setStdout :: StreamSpec 'STOutput stdout + -> ProcessConfig stdin stdout0 stderr + -> ProcessConfig stdin stdout stderr +setStdout spec pc = pc { pcStdout = spec } + +-- | Set the child's standard error stream to the given 'StreamSpec'. +-- +-- Default: 'inherit' +-- +-- @since 0.1.0.0 +setStderr :: StreamSpec 'STOutput stderr + -> ProcessConfig stdin stdout stderr0 + -> ProcessConfig stdin stdout stderr +setStderr spec pc = pc { pcStderr = spec } + +-- | Set the working directory of the child process. +-- +-- Default: current process's working directory. +-- +-- @since 0.1.0.0 +setWorkingDir :: FilePath + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setWorkingDir dir pc = pc { pcWorkingDir = Just dir } + +-- | Set the environment variables of the child process. +-- +-- Default: current process's environment. +-- +-- @since 0.1.0.0 +setEnv :: [(String, String)] + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setEnv env pc = pc { pcEnv = Just env } + +-- | Should we close all file descriptors besides stdin, stdout, and +-- stderr? See 'P.close_fds' for more information. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setCloseFds + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setCloseFds x pc = pc { pcCloseFds = x } + +-- | Should we create a new process group? +-- +-- Default: False +-- +-- @since 0.1.0.0 +setCreateGroup + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setCreateGroup x pc = pc { pcCreateGroup = x } + +-- | Delegate handling of Ctrl-C to the child. For more information, +-- see 'P.delegate_ctlc'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setDelegateCtlc + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setDelegateCtlc x pc = pc { pcDelegateCtlc = x } + +#if MIN_VERSION_process(1, 3, 0) + +-- | Detach console on Windows, see 'P.detach_console'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setDetachConsole + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setDetachConsole x pc = pc { pcDetachConsole = x } + +-- | Create new console on Windows, see 'P.create_new_console'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setCreateNewConsole + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setCreateNewConsole x pc = pc { pcCreateNewConsole = x } + +-- | Set a new session with the POSIX @setsid@ syscall, does nothing +-- on non-POSIX. See 'P.new_session'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setNewSession + :: Bool + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setNewSession x pc = pc { pcNewSession = x } +#endif + +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS +-- | Set the child process's group ID with the POSIX @setgid@ syscall, +-- does nothing on non-POSIX. See 'P.child_group'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setChildGroup + :: GroupID + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setChildGroup x pc = pc { pcChildGroup = Just x } + +-- | Set the child process's user ID with the POSIX @setuid@ syscall, +-- does nothing on non-POSIX. See 'P.child_user'. +-- +-- Default: False +-- +-- @since 0.1.0.0 +setChildUser + :: UserID + -> ProcessConfig stdin stdout stderr + -> ProcessConfig stdin stdout stderr +setChildUser x pc = pc { pcChildUser = Just x } +#endif + +-- | Create a new 'StreamSpec' from the given 'P.StdStream' and a +-- helper function. This function: +-- +-- * Takes as input the raw @Maybe Handle@ returned by the +-- 'P.createProcess' function. This will be determined by the +-- 'P.StdStream' argument. +-- +-- * Returns the actual stream value @a@, as well as a cleanup +-- * function to be run when calling 'stopProcess'. +-- +-- @since 0.1.0.0 +mkStreamSpec :: P.StdStream + -> (ProcessConfig () () () -> Maybe Handle -> IO (a, IO ())) + -> StreamSpec streamType a +mkStreamSpec ss f = StreamSpec ss (\pc mh -> Cleanup (f pc mh)) + +-- | A stream spec which simply inherits the stream of the parent +-- process. +-- +-- @since 0.1.0.0 +inherit :: StreamSpec anyStreamType () +inherit = mkStreamSpec P.Inherit (\_ Nothing -> pure ((), return ())) + +-- | A stream spec which will close the stream for the child process. +-- +-- @since 0.1.0.0 +closed :: StreamSpec anyStreamType () +#if MIN_VERSION_process(1, 4, 0) +closed = mkStreamSpec P.NoStream (\_ Nothing -> pure ((), return ())) +#else +closed = mkStreamSpec P.CreatePipe (\_ (Just h) -> (((), return ()) <$ hClose h)) +#endif + +-- | An input stream spec which sets the input to the given +-- 'L.ByteString'. A separate thread will be forked to write the +-- contents to the child process. +-- +-- @since 0.1.0.0 +byteStringInput :: L.ByteString -> StreamSpec 'STInput () +byteStringInput lbs = mkStreamSpec P.CreatePipe $ \_ (Just h) -> do + void $ async $ do + L.hPut h lbs + hClose h + return ((), hClose h) + +-- | Capture the output of a process in a 'L.ByteString'. +-- +-- This function will fork a separate thread to consume all input from +-- the process, and will only make the results available when the +-- underlying 'Handle' is closed. As this is provided as an 'STM' +-- action, you can either check if the result is available, or block +-- until it's ready. +-- +-- In the event of any exception occurring when reading from the +-- 'Handle', the 'STM' action will throw a +-- 'ByteStringOutputException'. +-- +-- @since 0.1.0.0 +byteStringOutput :: StreamSpec 'STOutput (STM L.ByteString) +byteStringOutput = mkStreamSpec P.CreatePipe $ \pc (Just h) -> do + mvar <- newEmptyTMVarIO + + void $ async $ do + let loop front = do + bs <- S.hGetSome h defaultChunkSize + if S.null bs + then atomically $ putTMVar mvar $ Right $ L.fromChunks $ front [] + else loop $ front . (bs:) + loop id `catch` \e -> do + atomically $ void $ tryPutTMVar mvar $ Left $ ByteStringOutputException e pc + throwIO e + + return (readTMVar mvar >>= either throwSTM return, hClose h) + +-- | Create a new pipe between this process and the child, and return +-- a 'Handle' to communicate with the child. +-- +-- @since 0.1.0.0 +createPipe :: StreamSpec anyStreamType Handle +createPipe = mkStreamSpec P.CreatePipe $ \_ (Just h) -> return (h, hClose h) + +-- | Use the provided 'Handle' for the child process, and when the +-- process exits, do /not/ close it. This is useful if, for example, +-- you want to have multiple processes write to the same log file +-- sequentially. +-- +-- @since 0.1.0.0 +useHandleOpen :: Handle -> StreamSpec anyStreamType () +useHandleOpen h = mkStreamSpec (P.UseHandle h) $ \_ Nothing -> return ((), return ()) + +-- | Use the provided 'Handle' for the child process, and when the +-- process exits, close it. If you have no reason to keep the 'Handle' +-- open, you should use this over 'useHandleOpen'. +-- +-- @since 0.1.0.0 +useHandleClose :: Handle -> StreamSpec anyStreamType () +useHandleClose h = mkStreamSpec (P.UseHandle h) $ \_ Nothing -> return ((), hClose h) + +-- | Provide input to a process by writing to a conduit. +-- +-- @since 0.1.0.0 +createSink :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ()) +createSink = + (\h -> C.addCleanup (\_ -> liftIO $ hClose h) (CB.sinkHandle h)) + <$> createPipe + +-- | Read output from a process by read from a conduit. +-- +-- @since 0.1.0.0 +createSource :: MonadIO m => StreamSpec 'STOutput (ConduitM i S.ByteString m ()) +createSource = + (\h -> C.addCleanup (\_ -> liftIO $ hClose h) (CB.sourceHandle h)) + <$> createPipe + +-- | Launch a process based on the given 'ProcessConfig'. You should +-- ensure that you close 'stopProcess' on the result. It's usually +-- better to use one of the functions in this module which ensures +-- 'stopProcess' is called, such as 'withProcess'. +-- +-- @since 0.1.0.0 +startProcess :: MonadIO m + => ProcessConfig stdin stdout stderr + -> m (Process stdin stdout stderr) +startProcess pConfig'@ProcessConfig {..} = liftIO $ do + let cp0 = + case pcCmdSpec of + P.ShellCommand cmd -> P.shell cmd + P.RawCommand cmd args -> P.proc cmd args + cp = cp0 + { P.std_in = ssStream pcStdin + , P.std_out = ssStream pcStdout + , P.std_err = ssStream pcStderr + , P.cwd = pcWorkingDir + , P.env = pcEnv + , P.close_fds = pcCloseFds + , P.create_group = pcCreateGroup + , P.delegate_ctlc = pcDelegateCtlc + +#if MIN_VERSION_process(1, 3, 0) + , P.detach_console = pcDetachConsole + , P.create_new_console = pcCreateNewConsole + , P.new_session = pcNewSession +#endif + +#if MIN_VERSION_process(1, 4, 0) && !WINDOWS + , P.child_group = pcChildGroup + , P.child_user = pcChildUser +#endif + + } + + (minH, moutH, merrH, pHandle) <- P.createProcess_ "startProcess" cp + + ((pStdin, pStdout, pStderr), pCleanup1) <- runCleanup $ (,,) + <$> ssCreate pcStdin pConfig minH + <*> ssCreate pcStdout pConfig moutH + <*> ssCreate pcStderr pConfig merrH + + pExitCode <- newEmptyTMVarIO + waitingThread <- async $ do + ec <- P.waitForProcess pHandle + atomically $ putTMVar pExitCode ec + return ec + + let pCleanup = pCleanup1 `finally` do + -- First: stop calling waitForProcess, so that we can + -- avoid race conditions where the process is removed from + -- the system process table while we're trying to + -- terminate it. + cancel waitingThread + + -- Now check if the process had already exited + eec <- waitCatch waitingThread + + case eec of + -- Process already exited, nothing to do + Right _ec -> return () + + -- Process didn't exit yet, let's terminate it and + -- then call waitForProcess ourselves + Left _ -> do + P.terminateProcess pHandle + void $ P.waitForProcess pHandle + + return Process {..} + where + pConfig = clearStreams pConfig' + +-- | Close a process and release any resources acquired. This will +-- ensure 'P.terminateProcess' is called, wait for the process to +-- actually exit, and then close out resources allocated for the +-- streams. In the event of any cleanup exceptions being thrown this +-- will throw an exception. +-- +-- @since 0.1.0.0 +stopProcess :: MonadIO m + => Process stdin stdout stderr + -> m () +stopProcess = liftIO . pCleanup + +-- | Use the bracket pattern to call 'startProcess' and ensure +-- 'stopProcess' is called. +-- +-- @since 0.1.0.0 +withProcess :: (MonadIO m, C.MonadMask m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess config = C.bracket (startProcess config) stopProcess + +-- | Same as 'withProcess', but also calls 'checkExitCode' +-- +-- @since 0.1.0.0 +withProcess_ :: (MonadIO m, C.MonadMask m) + => ProcessConfig stdin stdout stderr + -> (Process stdin stdout stderr -> m a) + -> m a +withProcess_ config = C.bracket + (startProcess config) + (\p -> stopProcess p `finally` checkExitCode p) + +-- | Run a process, capture its standard output and error as a +-- 'L.ByteString', wait for it to complete, and then return its exit +-- code, output, and error. +-- +-- Note that any previously used 'setStdout' or 'setStderr' will be +-- overridden. +-- +-- @since 0.1.0.0 +readProcess :: MonadIO m + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> m (ExitCode, L.ByteString, L.ByteString) +readProcess pc = + liftIO $ withProcess pc' $ \p -> atomically $ (,,) + <$> waitExitCodeSTM p + <*> getStdout p + <*> getStderr p + where + pc' = setStdout byteStringOutput + $ setStderr byteStringOutput pc + +-- | Same as 'readProcess', but instead of returning the 'ExitCode', +-- checks it with 'checkExitCode'. +-- +-- @since 0.1.0.0 +readProcess_ :: MonadIO m + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> m (L.ByteString, L.ByteString) +readProcess_ pc = + liftIO $ withProcess pc' $ \p -> atomically $ do + stdout <- getStdout p + stderr <- getStderr p + checkExitCodeSTM p `catchSTM` \ece -> throwSTM ece + { eceStdout = stdout + , eceStderr = stderr + } + return (stdout, stderr) + where + pc' = setStdout byteStringOutput + $ setStderr byteStringOutput pc + +-- | Run the given process, wait for it to exit, and returns its +-- 'ExitCode'. +-- +-- @since 0.1.0.0 +runProcess :: MonadIO m + => ProcessConfig stdin stdout stderr + -> m ExitCode +runProcess pc = liftIO $ withProcess pc waitExitCode + +-- | Same as 'runProcess', but ignores the 'ExitCode'. +-- +-- @since 0.1.0.0 +runProcess_ :: MonadIO m + => ProcessConfig stdin stdout stderr + -> m () +runProcess_ pc = liftIO $ withProcess pc checkExitCode + +-- | Wait for the process to exit and then return its 'ExitCode'. +-- +-- @since 0.1.0.0 +waitExitCode :: MonadIO m => Process stdin stdout stderr -> m ExitCode +waitExitCode = liftIO . atomically . waitExitCodeSTM + +-- | Same as 'waitExitCode', but in 'STM'. +-- +-- @since 0.1.0.0 +waitExitCodeSTM :: Process stdin stdout stderr -> STM ExitCode +waitExitCodeSTM = readTMVar . pExitCode + +-- | Check if a process has exited and, if so, return its 'ExitCode'. +-- +-- @since 0.1.0.0 +getExitCode :: MonadIO m => Process stdin stdout stderr -> m (Maybe ExitCode) +getExitCode = liftIO . atomically . getExitCodeSTM + +-- | Same as 'getExitCode', but in 'STM'. +-- +-- @since 0.1.0.0 +getExitCodeSTM :: Process stdin stdout stderr -> STM (Maybe ExitCode) +getExitCodeSTM = tryReadTMVar . pExitCode + +-- | Wait for a process to exit, and ensure that it exited +-- successfully. If not, throws an 'ExitCodeException'. +-- +-- @since 0.1.0.0 +checkExitCode :: MonadIO m => Process stdin stdout stderr -> m () +checkExitCode = liftIO . atomically . checkExitCodeSTM + +-- | Same as 'checkExitCode', but in 'STM'. +-- +-- @since 0.1.0.0 +checkExitCodeSTM :: Process stdin stdout stderr -> STM () +checkExitCodeSTM p = do + ec <- readTMVar (pExitCode p) + case ec of + ExitSuccess -> return () + _ -> throwSTM ExitCodeException + { eceExitCode = ec + , eceProcessConfig = clearStreams (pConfig p) + , eceStdout = L.empty + , eceStderr = L.empty + } + +-- | Internal +clearStreams :: ProcessConfig stdin stdout stderr -> ProcessConfig () () () +clearStreams pc = pc + { pcStdin = inherit + , pcStdout = inherit + , pcStderr = inherit + } + +-- | Get the child's standard input stream value. +-- +-- @since 0.1.0.0 +getStdin :: Process stdin stdout stderr -> stdin +getStdin = pStdin + +-- | Get the child's standard output stream value. +-- +-- @since 0.1.0.0 +getStdout :: Process stdin stdout stderr -> stdout +getStdout = pStdout + +-- | Get the child's standard error stream value. +-- +-- @since 0.1.0.0 +getStderr :: Process stdin stdout stderr -> stderr +getStderr = pStderr + +-- | Exception thrown by 'checkExitCode' in the event of a non-success +-- exit code. Note that 'checkExitCode' is called by other functions +-- as well, like 'runProcess_' or 'readProcess_'. +-- +-- @since 0.1.0.0 +data ExitCodeException = ExitCodeException + { eceExitCode :: ExitCode + , eceProcessConfig :: ProcessConfig () () () + , eceStdout :: L.ByteString + , eceStderr :: L.ByteString + } + deriving Typeable +instance Exception ExitCodeException +instance Show ExitCodeException where + show ece = concat + [ "Received " + , show (eceExitCode ece) + , " when running\n" + , show (eceProcessConfig ece) + , if L.null (eceStdout ece) + then "" + else "Standard output:\n\n" ++ L8.unpack (eceStdout ece) + , if L.null (eceStderr ece) + then "" + else "Standard error:\n\n" ++ L8.unpack (eceStderr ece) + ] + +-- | Wrapper for when an exception is thrown when reading from a child +-- process, used by 'byteStringOutput'. +-- +-- @since 0.1.0.0 +data ByteStringOutputException = ByteStringOutputException SomeException (ProcessConfig () () ()) + deriving (Show, Typeable) +instance Exception ByteStringOutputException diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/System/Process/TypedSpec.hs b/test/System/Process/TypedSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Process/TypedSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Process.TypedSpec (spec) where + +import System.Process.Typed +import System.IO +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Network.HTTP.Simple +import Control.Concurrent.Async (Concurrently (..)) +import Test.Hspec +import System.Exit +import System.IO.Temp +import qualified Data.ByteString as S +import Data.String (IsString) +import Data.Monoid ((<>)) +import qualified Data.Conduit.List as CL +import qualified Data.ByteString.Base64 as B64 + +#if !MIN_VERSION_base(4, 8, 0) +import Control.Applicative ((*>)) +#endif + +spec :: Spec +spec = do + it "bytestring stdin" $ do + let bs :: IsString s => s + bs = "this is a test" + res <- readProcess (setStdin bs "cat") + res `shouldBe` (ExitSuccess, bs, "") + + it "useHandleOpen" $ withSystemTempFile "use-handle-open" $ \fp h -> do + let bs :: IsString s => s + bs = "this is a test 2" + S.hPut h bs + hClose h + res <- withBinaryFile fp ReadMode $ \h' -> do + res <- readProcess (setStdin (useHandleOpen h') "cat") + isOpen <- hIsOpen h' + isOpen `shouldBe` True + return res + res `shouldBe` (ExitSuccess, bs, "") + + it "useHandleClose" $ withSystemTempFile "use-handle-close" $ \fp h -> do + let bs :: IsString s => s + bs = "this is a test 3" + S.hPut h bs + hClose h + res <- withBinaryFile fp ReadMode $ \h' -> do + res <- readProcess (setStdin (useHandleClose h') "cat") + isOpen <- hIsOpen h' + isOpen `shouldBe` False + return res + res `shouldBe` (ExitSuccess, bs, "") + + it "useHandleOpen+Close" $ withSystemTempFile "use-handle-open-close" $ \fp h -> do + let bs1, bs2 :: IsString s => s + bs1 = "this is a test 4\n" + bs2 = "this is a test 5\n" + + runProcess_ + ( setStdout (useHandleOpen h) + $ setStdin bs1 "cat") + runProcess_ + ( setStdout (useHandleClose h) + $ setStdin bs2 "cat") + + res <- S.readFile fp + res `shouldBe` bs1 <> bs2 + + it "unchecked exit code" $ do + res <- runProcess "false" + res `shouldBe` ExitFailure 1 + + it "checked exit code" $ + runProcess_ "false" `shouldThrow` \ExitCodeException{} -> True + + it "async" $ withSystemTempFile "httpbin" $ \fp h -> do + bss <- withProcess (setStdin createSink $ setStdout createSource "base64") $ \p -> + runConcurrently $ + Concurrently + ( httpSink "https://raw.githubusercontent.com/fpco/typed-process/master/README.md" $ \_res -> + CB.conduitHandle h .| getStdin p) *> + Concurrently + ( runConduit + $ getStdout p + .| CL.consume) + hClose h + let encoded = S.filter (/= 10) $ S.concat bss + raw <- S.readFile fp + encoded `shouldBe` B64.encode raw diff --git a/typed-process.cabal b/typed-process.cabal new file mode 100644 --- /dev/null +++ b/typed-process.cabal @@ -0,0 +1,51 @@ +name: typed-process +version: 0.1.0.0 +synopsis: Run external processes, with strong typing of streams +description: Please see README.md +homepage: https://github.com/fpco/typed-process#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +category: System +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: System.Process.Typed + build-depends: base >= 4.7 && < 5 + , async + , bytestring + , conduit + , conduit-extra + , exceptions + , process >= 1.2 + , stm + , transformers + if os(windows) + cpp-options: -DWINDOWS + default-language: Haskell2010 + +test-suite typed-process-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: System.Process.TypedSpec + build-depends: base + , async + , base64-bytestring + , bytestring + , conduit + , conduit-extra + , hspec + , http-conduit >= 2.1.10 + , temporary + , typed-process + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/fpco/typed-process