{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}

-- | See documentation for "Shh".
module Shh.Internal where

import Prelude hiding (lines, unlines)

import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.DeepSeq (force,NFData)
import Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as ByteString
import Data.ByteString.Lazy (ByteString, hGetContents, toStrict, fromStrict)
import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy.Char8 as BC8
import qualified Data.ByteString.Lazy.Search as Search
import Data.ByteString.Lazy.UTF8 (toString)
import Data.Char (isLower, isSpace, isAlphaNum, ord)
import Data.List (intercalate)
import qualified Data.List.Split as Split
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Typeable
import GHC.IO.BufferedIO
import GHC.IO.Device as IODevice hiding (read)
import GHC.IO.Encoding
import GHC.Foreign (peekCStringLen, newCStringLen)
import GHC.IO.Exception (IOErrorType(ResourceVanished))
import GHC.IO.Handle hiding (hGetContents)
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import GHC.IO.Handle.Types (Handle(..))
import GHC.Stack
import Language.Haskell.TH
import qualified System.Directory as Dir
import System.Environment (getEnv, setEnv)
import System.Exit (ExitCode(..))
import System.FilePath (takeFileName, (</>))
import System.IO (IOMode(..), withFile, withBinaryFile, stderr, stdout, stdin)
import System.IO.Unsafe (unsafePerformIO)
import System.IO.Error
import System.Posix.Signals
import System.Process
import Text.Printf

-- $setup
-- For doc-tests. Not sure I can use TH in doc tests.
-- >>> :seti -XOverloadedStrings
-- >>> import Data.Monoid
-- >>> import Data.ByteString.Lazy.Char8 (lines)
-- >>> let cat = exe "cat"
-- >>> let echo = exe "echo"
-- >>> let false = exe "false"
-- >>> let head = exe "head"
-- >>> let md5sum = exe "md5sum"
-- >>> let printf = exe "printf"
-- >>> let sleep = exe "sleep"
-- >>> let true = exe "true"
-- >>> let wc = exe "wc"
-- >>> let xargs = exe "xargs"
-- >>> let yes = exe "yes"
-- >>> let some_command = writeOutput "this is stdout" >> (writeOutput "this is stderr" &> StdErr)

-- | This function needs to be called in order to use the library successfully
-- from GHCi. If you use the @formatPrompt@ function from the @shh-extras@
-- package, this will be automatically called for you.
initInteractive :: IO ()
initInteractive :: IO ()
initInteractive = do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
LineBuffering

-- | When a process exits with a non-zero exit code
-- we throw this @Failure@ exception.
--
-- The only exception to this is when a process is terminated
-- by @SIGPIPE@ in a pipeline, in which case we ignore it.
data Failure = Failure
    { Failure -> ByteString
failureProg   :: ByteString
    , Failure -> [ByteString]
failureArgs   :: [ByteString]
    , Failure -> CallStack
failureStack  :: CallStack
    , Failure -> Int
failureCode   :: Int
    -- | Failure can optionally contain the stderr of a process.
    , Failure -> Maybe ByteString
failureStdErr :: Maybe ByteString
    }

instance Show Failure where
    show :: Failure -> String
show Failure
f = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        [ String
"Command `"
        ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " (ByteString -> String
toString (Failure -> ByteString
failureProg Failure
f) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
forall a. Show a => a -> String
show (Failure -> [ByteString]
failureArgs Failure
f))]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
        [ String
"` failed [exit "
        , Int -> String
forall a. Show a => a -> String
show (Failure -> Int
failureCode Failure
f)
        , String
"] at "
        , CallStack -> String
prettyCallStack (Failure -> CallStack
failureStack Failure
f)
        ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((ByteString -> [String]) -> Maybe ByteString -> [String])
-> Maybe ByteString -> (ByteString -> [String]) -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([String]
-> (ByteString -> [String]) -> Maybe ByteString -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []) (Failure -> Maybe ByteString
failureStdErr Failure
f) (\ByteString
s ->
           [String
"\n-- stderr --\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
toString ByteString
s])

instance Exception Failure

-- | This class is used to allow most of the operators in Shh to be
-- polymorphic in their return value. This makes using them in an `IO` context
-- easier (we can avoid having to prepend everything with a `runProc`).
class Shell f where
    runProc :: HasCallStack => Proc a -> f a

-- | Helper function that creates and potentially executes a @`Proc`@
buildProc :: Shell f => (Handle -> Handle -> Handle -> IO a) -> f a
buildProc :: (Handle -> Handle -> Handle -> IO a) -> f a
buildProc = Proc a -> f a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> f a)
-> ((Handle -> Handle -> Handle -> IO a) -> Proc a)
-> (Handle -> Handle -> Handle -> IO a)
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle -> Handle -> Handle -> IO a) -> Proc a
forall a. (Handle -> Handle -> Handle -> IO a) -> Proc a
Proc

-- | Like @`|>`@ except that it keeps both return results. Be aware
-- that the @fst@ element of this tuple may be hiding a @SIGPIPE@
-- exception that will explode on you once you look at it.
--
-- You probably want to use @`|>`@ unless you know you don't.
pipe :: Shell f => Proc a -> Proc b -> f (a, b)
pipe :: Proc a -> Proc b -> f (a, b)
pipe (Proc Handle -> Handle -> Handle -> IO a
a) (Proc Handle -> Handle -> Handle -> IO b
b) = (Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b)
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b))
-> (Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b)
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e ->
    (Handle -> Handle -> IO (a, b)) -> IO (a, b)
forall a. (Handle -> Handle -> IO a) -> IO a
withPipe ((Handle -> Handle -> IO (a, b)) -> IO (a, b))
-> (Handle -> Handle -> IO (a, b)) -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ \Handle
r Handle
w -> do
        let
            a' :: IO a
a' = Handle -> Handle -> Handle -> IO a
a Handle
i Handle
w Handle
e IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
w
            b' :: IO b
b' = Handle -> Handle -> Handle -> IO b
b Handle
r Handle
o Handle
e IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
r
        IO a -> IO b -> IO (a, b)
forall a b. IO a -> IO b -> IO (a, b)
concurrently IO a
a' IO b
b'

-- | Like @`pipe`@, but plumbs stderr. See the warning in @`pipe`@.
pipeErr :: Shell f => Proc a -> Proc b -> f (a, b)
pipeErr :: Proc a -> Proc b -> f (a, b)
pipeErr (Proc Handle -> Handle -> Handle -> IO a
a) (Proc Handle -> Handle -> Handle -> IO b
b) = (Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b)
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b))
-> (Handle -> Handle -> Handle -> IO (a, b)) -> f (a, b)
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> do
    (Handle -> Handle -> IO (a, b)) -> IO (a, b)
forall a. (Handle -> Handle -> IO a) -> IO a
withPipe ((Handle -> Handle -> IO (a, b)) -> IO (a, b))
-> (Handle -> Handle -> IO (a, b)) -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ \Handle
r Handle
w -> do
        let
            a' :: IO a
a' = Handle -> Handle -> Handle -> IO a
a Handle
i Handle
o Handle
w IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
w
            b' :: IO b
b' = Handle -> Handle -> Handle -> IO b
b Handle
r Handle
o Handle
e IO b -> IO () -> IO b
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
r
        IO a -> IO b -> IO (a, b)
forall a b. IO a -> IO b -> IO (a, b)
concurrently IO a
a' IO b
b'


-- | Use this to send the output of on process into the input of another.
-- This is just like a shell's `|` operator.
--
-- The result is polymorphic in its output, and can result in either
-- another `Proc a` or an `IO a` depending on the context in which it is
-- used.
--
-- If any intermediate process throws an exception, the whole pipeline
-- is canceled.
--
-- The result of the last process in the chain is the result returned
-- by the pipeline. 
--
-- >>> echo "Hello" |> wc
--       1       1       6
(|>) :: Shell f => Proc a -> Proc b -> f b
Proc a
a |> :: Proc a -> Proc b -> f b
|> Proc b
b = Proc b -> f b
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc b -> f b) -> Proc b -> f b
forall a b. (a -> b) -> a -> b
$ ((a, b) -> b) -> Proc (a, b) -> Proc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd (Proc a
a Proc a -> Proc b -> Proc (a, b)
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f (a, b)
`pipe` Proc b
b)
infixl 1 |>


-- | Similar to `|!>` except that it connects stderr to stdin of the
-- next process in the chain.
--
-- NB: The next command to be `|>` on will recapture the stdout of
-- both preceding processes, because they are both going to the same
-- handle!
--                                            
-- See the `&>` and `&!>` operators for redirection.
--
-- >>> echo "Ignored" |!> wc "-c"
-- Ignored
-- 0
(|!>) :: Shell f => Proc a -> Proc b -> f b
Proc a
a |!> :: Proc a -> Proc b -> f b
|!> Proc b
b = Proc b -> f b
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc b -> f b) -> Proc b -> f b
forall a b. (a -> b) -> a -> b
$ ((a, b) -> b) -> Proc (a, b) -> Proc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd (Proc a
a Proc a -> Proc b -> Proc (a, b)
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f (a, b)
`pipeErr` Proc b
b)
infixl 1 |!>

-- | Things that can be converted to a @`FilePath`@.
--
-- The results must use the file system encoding. Use this
-- if you want to pass a @ByteString@ to @`System.IO.openFile`@,
-- or if you want to turn a @FilePath@ into a @ByteString@.
--
-- If you never change the file system encoding, it should be safe to use
-- @`unsafePerformIO`@ on these functions.
class ToFilePath a where
    toFilePath :: a -> IO FilePath
    fromFilePath :: FilePath -> IO a

instance ToFilePath FilePath where
    toFilePath :: String -> IO String
toFilePath = String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    fromFilePath :: String -> IO String
fromFilePath = String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToFilePath ByteString.ByteString where
    toFilePath :: ByteString -> IO String
toFilePath ByteString
bs = do
        TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
        ByteString -> (CStringLen -> IO String) -> IO String
forall a. ByteString -> (CStringLen -> IO a) -> IO a
ByteString.useAsCStringLen ByteString
bs (TextEncoding -> CStringLen -> IO String
peekCStringLen TextEncoding
enc)
    fromFilePath :: String -> IO ByteString
fromFilePath String
fp = do
        TextEncoding
enc <- IO TextEncoding
getFileSystemEncoding
        TextEncoding -> String -> IO CStringLen
newCStringLen TextEncoding
enc String
fp IO CStringLen -> (CStringLen -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CStringLen -> IO ByteString
ByteString.unsafePackMallocCStringLen

instance ToFilePath ByteString where
    toFilePath :: ByteString -> IO String
toFilePath = ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath (ByteString -> IO String)
-> (ByteString -> ByteString) -> ByteString -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict
    fromFilePath :: String -> IO ByteString
fromFilePath = (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
fromStrict (IO ByteString -> IO ByteString)
-> (String -> IO ByteString) -> String -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
forall a. ToFilePath a => String -> IO a
fromFilePath

--
-- | Redirect stdout of this process to another location
--
-- >>> echo "Ignore me" &> Append "/dev/null"
(&>) :: Shell f => Proc a -> Stream -> f a
Proc a
p &> :: Proc a -> Stream -> f a
&> Stream
StdOut = Proc a -> f a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc Proc a
p
(Proc Handle -> Handle -> Handle -> IO a
f) &> Stream
StdErr = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
_ Handle
e -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
e Handle
e
(Proc Handle -> Handle -> Handle -> IO a
f) &> (Truncate ByteString
path) = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
_ Handle
e -> do
    String
path' <- ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath ByteString
path
    String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path' IOMode
WriteMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
h Handle
e
(Proc Handle -> Handle -> Handle -> IO a
f) &> (Append ByteString
path) = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
_ Handle
e -> do
    String
path' <- ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath ByteString
path
    String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path' IOMode
AppendMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
h Handle
e
infixl 9 &>

-- | Redirect stderr of this process to another location
--
-- >>> echo "Shh" &!> StdOut
-- Shh
(&!>) :: Shell f => Proc a -> Stream -> f a
Proc a
p &!> :: Proc a -> Stream -> f a
&!> Stream
StdErr = Proc a -> f a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc Proc a
p
(Proc Handle -> Handle -> Handle -> IO a
f) &!> Stream
StdOut = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
_ -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
o
(Proc Handle -> Handle -> Handle -> IO a
f) &!> (Truncate ByteString
path) = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
_ -> do
    String
path' <- ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath ByteString
path
    String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path' IOMode
WriteMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
h
(Proc Handle -> Handle -> Handle -> IO a
f) &!> (Append ByteString
path) = (Handle -> Handle -> Handle -> IO a) -> f a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> f a)
-> (Handle -> Handle -> Handle -> IO a) -> f a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
_ -> do
    String
path' <- ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath ByteString
path
    String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
path' IOMode
AppendMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
h
infixl 9 &!>

-- | Lift a Haskell function into a @`Proc`@. The handles are the @stdin@
-- @stdout@ and @stderr@ of the resulting @`Proc`@
nativeProc :: (Shell f, NFData a) => (Handle -> Handle -> Handle -> IO a) -> f a
nativeProc :: (Handle -> Handle -> Handle -> IO a) -> f a
nativeProc Handle -> Handle -> Handle -> IO a
f = Proc a -> f a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> f a) -> Proc a -> f a
forall a b. (a -> b) -> a -> b
$ (Handle -> Handle -> Handle -> IO a) -> Proc a
forall a. (Handle -> Handle -> Handle -> IO a) -> Proc a
Proc ((Handle -> Handle -> Handle -> IO a) -> Proc a)
-> (Handle -> Handle -> Handle -> IO a) -> Proc a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> (IOError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO a
forall a. IOError -> IO a
handler (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    -- We duplicate these so that you can't accidentally close the
    -- real ones.
    Handle
-> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
forall a.
Handle
-> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicates Handle
i Handle
o Handle
e ((Handle -> Handle -> Handle -> IO a) -> IO a)
-> (Handle -> Handle -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
i' Handle
o' Handle
e' -> do
        (Handle -> Handle -> Handle -> IO a
f Handle
i' Handle
o' Handle
e' IO a -> (a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
forall a. a -> IO a
C.evaluate (a -> IO a) -> (a -> a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. NFData a => a -> a
force)
            IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
i'
            IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
o'
            IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
e'

    where
        -- The resource vanished error only occurs when upstream pipe closes.
        -- This can only happen with the `|>` combinator, which will discard
        -- the result of this `Proc` anyway. If the return value is somehow
        -- inspected, or maybe if the exception is somehow legitimate, we
        -- simply package it up as an exploding return value. `runProc` will
        -- make sure to evaluate all `Proc`'s to WHNF in order to uncover it.
        -- This should never happen. *nervous*
        handler :: IOError -> IO a
        handler :: IOError -> IO a
handler IOError
e
            | IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished = a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOError -> a
forall a e. Exception e => e -> a
throw IOError
e)
            | Bool
otherwise = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
e

-- | Flipped version of `|>` with lower precedence.
--
-- >>> captureTrim <| (echo "Hello" |> wc "-c")
-- "6"
(<|) :: Shell f => Proc a -> Proc b -> f a
<| :: Proc a -> Proc b -> f a
(<|) = (Proc b -> Proc a -> f a) -> Proc a -> Proc b -> f a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Proc b -> Proc a -> f a
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
(|>)
infixr 1 <|

-- | Create a pipe, and close both ends on exception. The first argument
-- is the read end, the second is the write end.
--
-- >>> withPipe $ \r w -> hPutStr w "test" >> hClose w >> hGetLine r
-- "test"
withPipe :: (Handle -> Handle -> IO a) -> IO a
withPipe :: (Handle -> Handle -> IO a) -> IO a
withPipe Handle -> Handle -> IO a
k =
    IO (Handle, Handle)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        IO (Handle, Handle)
createPipe
        (\(Handle
r,Handle
w) -> Handle -> IO ()
hClose Handle
r IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
w)
        (\(Handle
r,Handle
w) -> Handle -> Handle -> IO a
k Handle
r Handle
w)

-- | Simple @`Proc`@ that writes its argument to its @stdout@. This behaves
-- very much like the standard @printf@ utility, except that there is no
-- restriction as to what can be in the argument.
--
-- NB: @String@ arguments are encoded as UTF8, while @ByteString@ is passed
-- through. Be aware if you are using @OverloadedStrings@ that you will get
-- wrong results if using unicode in your string literal and it inferes
-- anything other than @String@.
--
-- >>> writeOutput "Hello"
-- Hello
writeOutput :: (ExecArg a, Shell io) => a -> io ()
writeOutput :: a -> io ()
writeOutput a
s = (Handle -> Handle -> Handle -> IO ()) -> io ()
forall (f :: * -> *) a.
(Shell f, NFData a) =>
(Handle -> Handle -> Handle -> IO a) -> f a
nativeProc ((Handle -> Handle -> Handle -> IO ()) -> io ())
-> (Handle -> Handle -> Handle -> IO ()) -> io ()
forall a b. (a -> b) -> a -> b
$ \Handle
_ Handle
o Handle
_ -> do
    (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
BS.hPutStr Handle
o) (a -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg a
s)

-- | Simple @`Proc`@ that writes its argument to its @stderr@.
-- See also @`writeOutput`@.
--
-- >>> writeError "Hello" &> devNull
-- Hello
writeError :: (ExecArg a, Shell io) => a -> io ()
writeError :: a -> io ()
writeError a
s = (Handle -> Handle -> Handle -> IO ()) -> io ()
forall (f :: * -> *) a.
(Shell f, NFData a) =>
(Handle -> Handle -> Handle -> IO a) -> f a
nativeProc ((Handle -> Handle -> Handle -> IO ()) -> io ())
-> (Handle -> Handle -> Handle -> IO ()) -> io ()
forall a b. (a -> b) -> a -> b
$ \Handle
_ Handle
_ Handle
e -> do
   (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
BS.hPutStr Handle
e) (a -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg a
s)

-- | Simple @`Proc`@ that reads its input, and can react to it with an IO
-- action. Does not write anything to its output. See also @`capture`@.
--
-- @`readInput`@ uses lazy IO to read its stdin, and works with infinite
-- inputs.
--
-- >>> yes |> readInput (pure . unlines . take 3 . lines)
-- "y\ny\ny\n"
readInput :: (NFData a, Shell io) => (ByteString -> IO a) -> io a
readInput :: (ByteString -> IO a) -> io a
readInput ByteString -> IO a
f = (Handle -> Handle -> Handle -> IO a) -> io a
forall (f :: * -> *) a.
(Shell f, NFData a) =>
(Handle -> Handle -> Handle -> IO a) -> f a
nativeProc ((Handle -> Handle -> Handle -> IO a) -> io a)
-> (Handle -> Handle -> Handle -> IO a) -> io a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
_ Handle
_ -> do
    Handle -> IO ByteString
hGetContents Handle
i IO ByteString -> (ByteString -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO a
f

-- | Join a list of @ByteString@s with newline characters, terminating it
-- with a newline.
unlines :: [ByteString] -> ByteString
unlines :: [ByteString] -> ByteString
unlines = Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> ([ByteString] -> Builder) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([ByteString] -> [Builder]) -> [ByteString] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
l -> ByteString -> Builder
lazyByteString ByteString
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\n')

-- | Like @`readInput`@, but @`endBy`@s the string.
--
-- >>> yes |> readInputEndBy "\n" (pure . take 3)
-- ["y","y","y"]
readInputEndBy :: (NFData a, Shell io) => ByteString -> ([ByteString] -> IO a) -> io a
readInputEndBy :: ByteString -> ([ByteString] -> IO a) -> io a
readInputEndBy ByteString
s [ByteString] -> IO a
f = (ByteString -> IO a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput ([ByteString] -> IO a
f ([ByteString] -> IO a)
-> (ByteString -> [ByteString]) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> [ByteString]
endBy ByteString
s)

-- | Like @`readInput`@, but @`endBy`@s the string on the 0 byte.
--
-- >>> writeOutput "1\0\&2\0" |> readInputEndBy0 pure
-- ["1","2"]
readInputEndBy0 :: (NFData a, Shell io) => ([ByteString] -> IO a) -> io a
readInputEndBy0 :: ([ByteString] -> IO a) -> io a
readInputEndBy0 = ByteString -> ([ByteString] -> IO a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
ByteString -> ([ByteString] -> IO a) -> io a
readInputEndBy ByteString
"\0"

-- | Like @`readInput`@, but @`endBy`@s the string on new lines.
--
-- >>> writeOutput "a\nb\n" |> readInputLines pure
-- ["a","b"]
readInputLines :: (NFData a, Shell io) => ([ByteString] -> IO a) -> io a
readInputLines :: ([ByteString] -> IO a) -> io a
readInputLines = ByteString -> ([ByteString] -> IO a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
ByteString -> ([ByteString] -> IO a) -> io a
readInputEndBy ByteString
"\n"

-- | Creates a pure @`Proc`@ that simple transforms the @stdin@ and writes
-- it to @stdout@. The input can be infinite.
--
-- >>> yes |> pureProc (BS.take 4) |> capture
-- "y\ny\n"
pureProc :: Shell io => (ByteString -> ByteString) -> io ()
pureProc :: (ByteString -> ByteString) -> io ()
pureProc ByteString -> ByteString
f = (Handle -> Handle -> Handle -> IO ()) -> io ()
forall (f :: * -> *) a.
(Shell f, NFData a) =>
(Handle -> Handle -> Handle -> IO a) -> f a
nativeProc ((Handle -> Handle -> Handle -> IO ()) -> io ())
-> (Handle -> Handle -> Handle -> IO ()) -> io ()
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
_ -> do
    ByteString
s <- Handle -> IO ByteString
hGetContents Handle
i
    Handle -> ByteString -> IO ()
BS.hPutStr Handle
o (ByteString -> ByteString
f ByteString
s)

-- | Captures the stdout of a process and prefixes all the lines with
-- the given string.
--
-- >>> some_command |> prefixLines "stdout: " |!> prefixLines "stderr: " &> StdErr
-- stdout: this is stdout
-- stderr: this is stderr
prefixLines :: Shell io => ByteString -> io ()
prefixLines :: ByteString -> io ()
prefixLines ByteString
s = (ByteString -> ByteString) -> io ()
forall (io :: * -> *).
Shell io =>
(ByteString -> ByteString) -> io ()
pureProc ((ByteString -> ByteString) -> io ())
-> (ByteString -> ByteString) -> io ()
forall a b. (a -> b) -> a -> b
$ \ByteString
inp -> Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (ByteString -> Builder) -> [ByteString] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
l -> ByteString -> Builder
lazyByteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
l Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\n') (ByteString -> [ByteString]
BC8.lines ByteString
inp)

-- | Provide the stdin of a `Proc` from a `ByteString`
--
-- Same as @`writeOutput` s |> p@
writeProc :: Shell io => Proc a -> ByteString -> io a
writeProc :: Proc a -> ByteString -> io a
writeProc Proc a
p ByteString
s = ByteString -> Proc ()
forall a (io :: * -> *). (ExecArg a, Shell io) => a -> io ()
writeOutput ByteString
s Proc () -> Proc a -> io a
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
|> Proc a
p

-- | Run a process and capture its output lazily. Once the continuation
-- is completed, the handles are closed. However, the process is run
-- until it naturally terminates in order to capture the correct exit
-- code. Most utilities behave correctly with this (e.g. @cat@ will
-- terminate if you close the handle).
--
-- Same as @p |> readInput f@
withRead :: (Shell f, NFData b) => Proc a -> (ByteString -> IO b) -> f b
withRead :: Proc a -> (ByteString -> IO b) -> f b
withRead Proc a
p ByteString -> IO b
f = Proc a
p Proc a -> Proc b -> f b
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
|> (ByteString -> IO b) -> Proc b
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput ByteString -> IO b
f

-- | Type used to represent destinations for redirects. @`Truncate` file@
-- is like @> file@ in a shell, and @`Append` file@ is like @>> file@.
data Stream = StdOut | StdErr | Truncate ByteString | Append ByteString

-- | Shortcut for @`Truncate` "\/dev\/null"@
-- 
-- >>> echo "Hello" &> devNull
devNull :: Stream
devNull :: Stream
devNull = ByteString -> Stream
Truncate ByteString
"/dev/null"

-- | Type representing a series or pipeline (or both) of shell commands.
--
-- @Proc@'s can communicate to each other via @stdin@, @stdout@ and @stderr@
-- and can communicate to Haskell via their parameterised return type, or by
-- throwing an exception.
newtype Proc a = Proc (Handle -> Handle -> Handle -> IO a)
    deriving a -> Proc b -> Proc a
(a -> b) -> Proc a -> Proc b
(forall a b. (a -> b) -> Proc a -> Proc b)
-> (forall a b. a -> Proc b -> Proc a) -> Functor Proc
forall a b. a -> Proc b -> Proc a
forall a b. (a -> b) -> Proc a -> Proc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Proc b -> Proc a
$c<$ :: forall a b. a -> Proc b -> Proc a
fmap :: (a -> b) -> Proc a -> Proc b
$cfmap :: forall a b. (a -> b) -> Proc a -> Proc b
Functor

instance MonadIO Proc where
    liftIO :: IO a -> Proc a
liftIO IO a
a = (Handle -> Handle -> Handle -> IO a) -> Proc a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> Proc a)
-> (Handle -> Handle -> Handle -> IO a) -> Proc a
forall a b. (a -> b) -> a -> b
$ \Handle
_ Handle
_ Handle
_ -> IO a
a

-- | The `Semigroup` instance for `Proc` pipes the stdout of one process
-- into the stdin of the next. However, consider using `|>` instead which
-- behaves when used in an `IO` context. If you use `<>` in an IO monad
-- you will be using the `IO` instance of semigroup which is a sequential
-- execution. `|>` prevents that error.
instance Semigroup (Proc a) where
    <> :: Proc a -> Proc a -> Proc a
(<>) = Proc a -> Proc a -> Proc a
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
(|>)

instance (a ~ ()) => Monoid (Proc a) where
    mempty :: Proc a
mempty = (Handle -> Handle -> Handle -> IO ()) -> Proc ()
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO ()) -> Proc ())
-> (Handle -> Handle -> Handle -> IO ()) -> Proc ()
forall a b. (a -> b) -> a -> b
$ \Handle
_ Handle
_ Handle
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance Applicative Proc where
    pure :: a -> Proc a
pure a
a = (Handle -> Handle -> Handle -> IO a) -> Proc a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> Proc a)
-> (Handle -> Handle -> Handle -> IO a) -> Proc a
forall a b. (a -> b) -> a -> b
$ \Handle
_ Handle
_ Handle
_  -> do
        a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

    Proc (a -> b)
f <*> :: Proc (a -> b) -> Proc a -> Proc b
<*> Proc a
a = do
        a -> b
f' <- Proc (a -> b)
f
        a -> b
f' (a -> b) -> Proc a -> Proc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proc a
a
        
instance Monad Proc where
    (Proc Handle -> Handle -> Handle -> IO a
a) >>= :: Proc a -> (a -> Proc b) -> Proc b
>>= a -> Proc b
f = (Handle -> Handle -> Handle -> IO b) -> Proc b
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO b) -> Proc b)
-> (Handle -> Handle -> Handle -> IO b) -> Proc b
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> do
        a
ar <- Handle -> Handle -> Handle -> IO a
a Handle
i Handle
o Handle
e
        let
            Proc Handle -> Handle -> Handle -> IO b
f' = a -> Proc b
f a
ar
        Handle -> Handle -> Handle -> IO b
f' Handle
i Handle
o Handle
e

instance Shell IO where
    runProc :: Proc a -> IO a
runProc = Handle -> Handle -> Handle -> Proc a -> IO a
forall a. Handle -> Handle -> Handle -> Proc a -> IO a
runProc' Handle
stdin Handle
stdout Handle
stderr

instance Shell Proc where
    runProc :: Proc a -> Proc a
runProc = Proc a -> Proc a
forall a. a -> a
id

-- | Run's a `Proc` in `IO`. Like `runProc`, but you get to choose the handles.
-- This is UNSAFE to expose externally, because there are restrictions on what
-- the Handle can be. Within shh, we never call `runProc'` with invalid handles,
-- so we ignore that corner case (see `hDup`).
runProc' :: Handle -> Handle -> Handle -> Proc a -> IO a
runProc' :: Handle -> Handle -> Handle -> Proc a -> IO a
runProc' Handle
i Handle
o Handle
e (Proc Handle -> Handle -> Handle -> IO a
f) = do
    -- Flush stdout and stderr so that sequencing commands with
    -- Haskell IO functions looks right.
    Handle -> IO ()
hFlush Handle
stdout
    Handle -> IO ()
hFlush Handle
stderr
    a
r <- Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
e
    -- Evaluate to WHNF to uncover any ResourceVanished exceptions
    -- that may be hiding in there from `nativeProc`. These should
    -- not happen under normal circumstances, but we would at least
    -- like to have the exception thrown ASAP if, for whatever reason,
    -- it does happen.
    a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! a
r

-- | Create a `Proc` from a command and a list of arguments.
-- The boolean represents whether we should delegate control-c
-- or not. Most uses of @`mkProc'`@ in Shh do not delegate control-c.
{-# DEPRECATED mkProc' "Use mkProcWith instead" #-}
mkProc' :: HasCallStack => Bool -> ByteString -> [ByteString] -> Proc ()
mkProc' :: Bool -> ByteString -> [ByteString] -> Proc ()
mkProc' Bool
delegate = HasCallStack =>
ProcOptions -> ByteString -> [ByteString] -> Proc ()
ProcOptions -> ByteString -> [ByteString] -> Proc ()
mkProcWith ProcOptions
defaultProcOptions { delegateCtlc :: Bool
delegateCtlc = Bool
delegate }

-- | Options for making processes.
data ProcOptions = ProcOptions
    { ProcOptions -> Bool
delegateCtlc :: Bool -- ^ Delegate control-c handling to the child.
    , ProcOptions -> Bool
closeFds     :: Bool -- ^ Close file descriptors before @exec@ing.
    }

-- | Default ProcOptions as used by most of this library.
defaultProcOptions :: ProcOptions
defaultProcOptions :: ProcOptions
defaultProcOptions = ProcOptions :: Bool -> Bool -> ProcOptions
ProcOptions
    { delegateCtlc :: Bool
delegateCtlc = Bool
True
    , closeFds :: Bool
closeFds     = Bool
True
    }

-- | Create a `Proc` with custom options.
mkProcWith :: HasCallStack => ProcOptions -> ByteString -> [ByteString] -> Proc ()
mkProcWith :: ProcOptions -> ByteString -> [ByteString] -> Proc ()
mkProcWith ProcOptions
options ByteString
cmd [ByteString]
args = (Handle -> Handle -> Handle -> IO ()) -> Proc ()
forall a. (Handle -> Handle -> Handle -> IO a) -> Proc a
Proc ((Handle -> Handle -> Handle -> IO ()) -> Proc ())
-> (Handle -> Handle -> Handle -> IO ()) -> Proc ()
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> do
    String
cmd' <- ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath ByteString
cmd
    [String]
args' <- (ByteString -> IO String) -> [ByteString] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> IO String
forall a. ToFilePath a => a -> IO String
toFilePath [ByteString]
args
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ExitCode)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
cmd' (String -> [String] -> CreateProcess
proc String
cmd' [String]
args')
            { std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
i
            , std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
o
            , std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
e
            , close_fds :: Bool
close_fds = ProcOptions -> Bool
closeFds ProcOptions
options
            , delegate_ctlc :: Bool
delegate_ctlc = ProcOptions -> Bool
delegateCtlc ProcOptions
options
            }
        )
        (\(Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
ph) -> ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph)
        (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
  -> IO ())
 -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe Handle
_,Maybe Handle
_,Maybe Handle
_,ProcessHandle
ph) -> HasCallStack =>
ByteString -> [ByteString] -> ProcessHandle -> IO ()
ByteString -> [ByteString] -> ProcessHandle -> IO ()
waitProc ByteString
cmd [ByteString]
args ProcessHandle
ph IO () -> IO ExitCode -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` (ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph)

-- | Create a `Proc` from a command and a list of arguments. Does not delegate
-- control-c handling.
mkProc :: HasCallStack => ByteString -> [ByteString] -> Proc ()
mkProc :: ByteString -> [ByteString] -> Proc ()
mkProc = HasCallStack =>
ProcOptions -> ByteString -> [ByteString] -> Proc ()
ProcOptions -> ByteString -> [ByteString] -> Proc ()
mkProcWith ProcOptions
defaultProcOptions

-- | A special `Proc` which captures its stdin and presents it as a `ByteString`
-- to Haskell.
--
-- >>> printf "Hello" |> md5sum |> capture
-- "8b1a9953c4611296a827abf8c47804d7  -\n"
--
-- This is just @`readInput` pure@. Note that it is not lazy, and will read
-- the entire @ByteString@ into memory.
capture :: Shell io => io ByteString
capture :: io ByteString
capture = (ByteString -> IO ByteString) -> io ByteString
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Like @'capture'@, except that it @'trim'@s leading and trailing white
-- space.
--
-- >>> printf "Hello" |> md5sum |> captureTrim
-- "8b1a9953c4611296a827abf8c47804d7  -"
captureTrim :: Shell io => io ByteString
captureTrim :: io ByteString
captureTrim = (ByteString -> IO ByteString) -> io ByteString
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput (ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
trim)

-- | Like @'capture'@, but splits the input using the provided separator.
--
-- NB: This is strict. If you want a streaming version, use `readInput`
captureEndBy :: Shell io => ByteString -> io [ByteString]
captureEndBy :: ByteString -> io [ByteString]
captureEndBy ByteString
s = (ByteString -> IO [ByteString]) -> io [ByteString]
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput ([ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> [ByteString]
endBy ByteString
s)

-- | Same as @'captureEndBy' "\\0"@.
captureEndBy0 :: Shell io => io [ByteString]
captureEndBy0 :: io [ByteString]
captureEndBy0 = ByteString -> io [ByteString]
forall (io :: * -> *). Shell io => ByteString -> io [ByteString]
captureEndBy ByteString
"\0"

-- | Same as @'captureSplit' "\\n"@.
captureLines :: Shell io => io [ByteString]
captureLines :: io [ByteString]
captureLines = ByteString -> io [ByteString]
forall (io :: * -> *). Shell io => ByteString -> io [ByteString]
captureEndBy ByteString
"\n"

-- | Capture stdout, splitting it into words.
captureWords :: Shell io => io [ByteString]
captureWords :: io [ByteString]
captureWords = (ByteString -> IO [ByteString]) -> io [ByteString]
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput ([ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> IO [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BC8.words)

-- | Capture stdout, and attempt to @`read`@ it
captureRead :: (Shell io, Read a, NFData a) => io a
captureRead :: io a
captureRead = (ByteString -> IO a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> IO a) -> io a
readInput (a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (ByteString -> a) -> ByteString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. Read a => String -> a
read (String -> a) -> (ByteString -> String) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
toString)

-- | Apply a `Proc` to a `ByteString`. That is, feed the bytestring to
-- the @stdin@ of the process and read the @stdout@.
--
-- >> apply md5sum "Hello"
-- "8b1a9953c4611296a827abf8c47804d7  -\n"
apply :: (ExecArg a, Shell io) => Proc v -> a -> io ByteString
apply :: Proc v -> a -> io ByteString
apply Proc v
p a
b = a -> Proc ()
forall a (io :: * -> *). (ExecArg a, Shell io) => a -> io ()
writeOutput a
b Proc () -> Proc v -> Proc v
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
|> Proc v
p Proc v -> Proc ByteString -> io ByteString
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f b
|> Proc ByteString
forall (io :: * -> *). Shell io => io ByteString
capture

-- | Flipped, infix version of `writeProc`
(>>>) :: Shell io => ByteString -> Proc a -> io a
>>> :: ByteString -> Proc a -> io a
(>>>) = (Proc a -> ByteString -> io a) -> ByteString -> Proc a -> io a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Proc a -> ByteString -> io a
forall (io :: * -> *) a. Shell io => Proc a -> ByteString -> io a
writeProc


-- | Infix version of `writeProc`
(<<<) :: Shell io => Proc a -> ByteString -> io a
<<< :: Proc a -> ByteString -> io a
(<<<) = Proc a -> ByteString -> io a
forall (io :: * -> *) a. Shell io => Proc a -> ByteString -> io a
writeProc

-- | Wait on a given `ProcessHandle`, and throw an exception of
-- type `Failure` if its exit code is non-zero (ignoring SIGPIPE)
waitProc :: HasCallStack => ByteString -> [ByteString] -> ProcessHandle -> IO ()
waitProc :: ByteString -> [ByteString] -> ProcessHandle -> IO ()
waitProc ByteString
cmd [ByteString]
arg ProcessHandle
ph = ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitFailure Int
c
        | Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> CInt
forall a. Num a => a -> a
negate CInt
sigPIPE -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        | Bool
otherwise -> Failure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO ()) -> Failure -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
-> [ByteString] -> CallStack -> Int -> Maybe ByteString -> Failure
Failure ByteString
cmd [ByteString]
arg CallStack
HasCallStack => CallStack
callStack Int
c Maybe ByteString
forall a. Maybe a
Nothing
    ExitCode
ExitSuccess -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Drop trailing characters from a @ByteString@ while the given predicate
-- matches.
--
-- >>> dropWhileEnd isSpace "a line \n"
-- "a line"
dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd Char -> Bool
p ByteString
b = case ByteString -> Maybe (ByteString, Char)
BC8.unsnoc ByteString
b of
    Just (ByteString
i, Char
l) -> if Char -> Bool
p Char
l then (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd Char -> Bool
p ByteString
i else ByteString
b
    Maybe (ByteString, Char)
Nothing     -> ByteString
b

-- | Trim leading and tailing whitespace.
--
-- >>> trim " a string \n"
-- "a string"
trim :: ByteString -> ByteString
trim :: ByteString -> ByteString
trim = (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd Char -> Bool
isSpace (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BC8.dropWhile Char -> Bool
isSpace

-- | Run a `Proc` action, catching any `Failure` exceptions
-- and returning them.
tryFailure :: Shell m => Proc a -> m (Either Failure a)
tryFailure :: Proc a -> m (Either Failure a)
tryFailure (Proc Handle -> Handle -> Handle -> IO a
f) = (Handle -> Handle -> Handle -> IO (Either Failure a))
-> m (Either Failure a)
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO (Either Failure a))
 -> m (Either Failure a))
-> (Handle -> Handle -> Handle -> IO (Either Failure a))
-> m (Either Failure a)
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> IO a -> IO (Either Failure a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either Failure a)) -> IO a -> IO (Either Failure a)
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
e

-- | Like @`tryFailure`@ except that it takes an exception predicate which
-- selects which exceptions to catch. Any exception not matching the predicate
-- (returning @Nothing@) is re-thrown.
tryFailureJust :: Shell m => (Failure -> Maybe b) -> Proc a -> m (Either b a)
tryFailureJust :: (Failure -> Maybe b) -> Proc a -> m (Either b a)
tryFailureJust Failure -> Maybe b
pr (Proc Handle -> Handle -> Handle -> IO a
f) = (Handle -> Handle -> Handle -> IO (Either b a)) -> m (Either b a)
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO (Either b a)) -> m (Either b a))
-> (Handle -> Handle -> Handle -> IO (Either b a))
-> m (Either b a)
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> (Failure -> Maybe b) -> IO a -> IO (Either b a)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust Failure -> Maybe b
pr (Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
e)

-- | Run a `Proc` with an action to take if an exception is thrown.
catchFailure :: Shell m => Proc a -> (Failure -> Proc a) -> m a
catchFailure :: Proc a -> (Failure -> Proc a) -> m a
catchFailure (Proc Handle -> Handle -> Handle -> IO a
f) Failure -> Proc a
pr = (Handle -> Handle -> Handle -> IO a) -> m a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> m a)
-> (Handle -> Handle -> Handle -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> IO a -> (Failure -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
e) (Proc a -> IO a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> IO a) -> (Failure -> Proc a) -> Failure -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Proc a
pr)

-- | Like @`catchFailureJust`@ except that it takes an exception predicate
-- which selects which exceptions to catch. Any exceptions not matching the
-- predicate (returning @Nothing@) are re-thrown.
catchFailureJust :: Shell m => (Failure -> Maybe b) -> Proc a -> (b -> Proc a) -> m a
catchFailureJust :: (Failure -> Maybe b) -> Proc a -> (b -> Proc a) -> m a
catchFailureJust Failure -> Maybe b
pr (Proc Handle -> Handle -> Handle -> IO a
f) b -> Proc a
h = (Handle -> Handle -> Handle -> IO a) -> m a
forall (f :: * -> *) a.
Shell f =>
(Handle -> Handle -> Handle -> IO a) -> f a
buildProc ((Handle -> Handle -> Handle -> IO a) -> m a)
-> (Handle -> Handle -> Handle -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> (Failure -> Maybe b) -> IO a -> (b -> IO a) -> IO a
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust Failure -> Maybe b
pr (Handle -> Handle -> Handle -> IO a
f Handle
i Handle
o Handle
e) (Proc a -> IO a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> IO a) -> (b -> Proc a) -> b -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Proc a
h)

-- | Apply a function that translates non-0 exit codes to results. Any code
-- that returns a @Nothing@ will be thrown as a @`Failure`@.
translateCode' :: Shell m => (Int -> Maybe b) -> Proc a -> m (Either b a)
translateCode' :: (Int -> Maybe b) -> Proc a -> m (Either b a)
translateCode' Int -> Maybe b
f = (Failure -> Maybe b) -> Proc a -> m (Either b a)
forall (m :: * -> *) b a.
Shell m =>
(Failure -> Maybe b) -> Proc a -> m (Either b a)
tryFailureJust (Int -> Maybe b
f (Int -> Maybe b) -> (Failure -> Int) -> Failure -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Int
failureCode)

-- | Apply a function to non-0 exit codes to extract a result. If @Nothing@
-- is produced, the @`Failure`@ is thrown.
translateCode :: Shell m => (Int -> Maybe a) -> Proc a -> m a
translateCode :: (Int -> Maybe a) -> Proc a -> m a
translateCode Int -> Maybe a
f Proc a
p = (Failure -> Maybe a) -> Proc a -> (a -> Proc a) -> m a
forall (m :: * -> *) b a.
Shell m =>
(Failure -> Maybe b) -> Proc a -> (b -> Proc a) -> m a
catchFailureJust (Int -> Maybe a
f (Int -> Maybe a) -> (Failure -> Int) -> Failure -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Int
failureCode) Proc a
p a -> Proc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Capture the stderr of the proc, and attach it to any @`Failure`@
-- exceptions that are thrown. The stderr is also forwarded to downstream
-- processes, or the inherited stderr handle. Note that capturing stderr
-- inherently requires that the stderr is accumulated in memory, so be
-- careful about processes that dump a lot of information.
failWithStdErr :: Shell io => Proc a -> io a
failWithStdErr :: Proc a -> io a
failWithStdErr Proc a
p = Proc a -> io a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> io a) -> Proc a -> io a
forall a b. (a -> b) -> a -> b
$ do
    (Either Failure a, ByteString)
r <- Proc a -> Proc (Either Failure a)
forall (m :: * -> *) a. Shell m => Proc a -> m (Either Failure a)
tryFailure Proc a
p Proc (Either Failure a)
-> Proc ByteString -> Proc (Either Failure a, ByteString)
forall (f :: * -> *) a b. Shell f => Proc a -> Proc b -> f (a, b)
`pipeErr` (ByteString -> Proc ByteString) -> Proc ByteString
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> Proc a) -> io a
readInputP (\ByteString
i -> do
        ByteString -> Proc ()
forall a (io :: * -> *). (ExecArg a, Shell io) => a -> io ()
writeError ByteString
i
        ByteString -> Proc ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
i
        )
    case (Either Failure a, ByteString)
r of
        (Right a
a, ByteString
_) -> a -> Proc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        (Left Failure
f, ByteString
err) -> IO a -> Proc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Proc a) -> IO a -> Proc a
forall a b. (a -> b) -> a -> b
$ Failure -> IO a
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO a) -> Failure -> IO a
forall a b. (a -> b) -> a -> b
$ Failure
f {failureStdErr :: Maybe ByteString
failureStdErr = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
err}

-- | Run a `Proc` action, ignoring any `Failure` exceptions.
-- This can be used to prevent a process from interrupting a whole pipeline.
--
-- >>> false |> (sleep "0.1" >> echo 1)
-- *** Exception: Command `false` failed [exit 1] at CallStack (from HasCallStack):
-- ...
--
-- >>> (ignoreFailure false) |> (sleep "0.1" >> echo 1)
-- 1
ignoreFailure :: (Functor m, Shell m) => Proc a -> m ()
ignoreFailure :: Proc a -> m ()
ignoreFailure = m (Either Failure a) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either Failure a) -> m ())
-> (Proc a -> m (Either Failure a)) -> Proc a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proc a -> m (Either Failure a)
forall (m :: * -> *) a. Shell m => Proc a -> m (Either Failure a)
tryFailure

-- | Run a `Proc` action returning the exit code of the process instead of
-- throwing an exception.
--
-- >>> exitCode false
-- 1
exitCode :: (Functor m, Shell m) => Proc a -> m Int
exitCode :: Proc a -> m Int
exitCode = (Either Failure a -> Int) -> m (Either Failure a) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either Failure a -> Int
forall b. Either Failure b -> Int
getCode (m (Either Failure a) -> m Int)
-> (Proc a -> m (Either Failure a)) -> Proc a -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proc a -> m (Either Failure a)
forall (m :: * -> *) a. Shell m => Proc a -> m (Either Failure a)
tryFailure
    where
        getCode :: Either Failure b -> Int
getCode (Right b
_) = Int
0
        getCode (Left  Failure
f) = Failure -> Int
failureCode Failure
f

-- | Run the @`Proc`@, but don't throw an exception if it exits with the
-- given code. Note, that from this point on, if the proc did fail with the
-- code, everything else now sees it as having exited with 0. If you need
-- to know the code, you have to use `exitCode`.
ignoreCode :: (Monad m, Shell m) => Int -> Proc a -> m ()
ignoreCode :: Int -> Proc a -> m ()
ignoreCode Int
code Proc a
p = (Failure -> Maybe ()) -> Proc () -> (() -> Proc ()) -> m ()
forall (m :: * -> *) b a.
Shell m =>
(Failure -> Maybe b) -> Proc a -> (b -> Proc a) -> m a
catchFailureJust Failure -> Maybe ()
pr (Proc a -> Proc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Proc a
p) () -> Proc ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    where
        pr :: Failure -> Maybe ()
pr Failure
f
            | Failure -> Int
failureCode Failure
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
code = () -> Maybe ()
forall a. a -> Maybe a
Just ()
            | Bool
otherwise             = Maybe ()
forall a. Maybe a
Nothing

-- | A class for things that can be converted to arguments on the command
-- line. The default implementation is to use `show` and then encode it using
-- the file system encoding.
class ExecArg a where
    asArg :: a -> [ByteString]
    default asArg :: Show a => a -> [ByteString]
    asArg a
a = [IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
forall a. ToFilePath a => String -> IO a
fromFilePath (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
a]

    -- God, I hate that String is [Char]...
    asArgFromList :: [a] -> [ByteString]
    default asArgFromList :: Show a => [a] -> [ByteString]
    asArgFromList = (a -> [ByteString]) -> [a] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg

-- | The @Char@ and @String@ instances encode using the file system encoding.
instance ExecArg Char where
    asArg :: Char -> [ByteString]
asArg Char
s = [IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
forall a. ToFilePath a => String -> IO a
fromFilePath [Char
s]]
    asArgFromList :: String -> [ByteString]
asArgFromList String
s = [IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
forall a. ToFilePath a => String -> IO a
fromFilePath String
s]

-- | The @[Char]@/@String@ instance encodes using the file system encoding.
instance ExecArg a => ExecArg [a] where
    asArg :: [a] -> [ByteString]
asArg = [a] -> [ByteString]
forall a. ExecArg a => [a] -> [ByteString]
asArgFromList
    asArgFromList :: [[a]] -> [ByteString]
asArgFromList = ([a] -> [ByteString]) -> [[a]] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [a] -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg

instance ExecArg ByteString where
    asArg :: ByteString -> [ByteString]
asArg ByteString
s = [ByteString
s]

instance ExecArg ByteString.ByteString where
    asArg :: ByteString -> [ByteString]
asArg ByteString
s = [ByteString -> ByteString
BS.fromStrict ByteString
s]

instance ExecArg Int
instance ExecArg Integer
instance ExecArg Word

-- | A class for building up a command.
class Command a where
    toArgs :: HasCallStack => [ByteString] -> a

instance (a ~ ()) => Command (Proc a) where
    toArgs :: [ByteString] -> Proc a
toArgs (ByteString
cmd:[ByteString]
args) = HasCallStack => ByteString -> [ByteString] -> Proc ()
ByteString -> [ByteString] -> Proc ()
mkProc ByteString
cmd [ByteString]
args
    toArgs [ByteString]
_ = String -> Proc a
forall a. HasCallStack => String -> a
error String
"The impossible happened. How did you construct this?"

instance (ExecArg b, Command a) => Command (b -> a) where
    toArgs :: [ByteString] -> b -> a
toArgs [ByteString]
f b
i = [ByteString] -> a
forall a. (Command a, HasCallStack) => [ByteString] -> a
toArgs ([ByteString] -> a) -> [ByteString] -> a
forall a b. (a -> b) -> a -> b
$ [ByteString]
f [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ b -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg b
i

-- | Commands can be executed directly in IO
instance (a ~ ()) => Command (IO a) where
    toArgs :: [ByteString] -> IO a
toArgs = Proc a -> IO a
forall (f :: * -> *) a. (Shell f, HasCallStack) => Proc a -> f a
runProc (Proc a -> IO a)
-> ([ByteString] -> Proc a) -> [ByteString] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Proc a
forall a. (Command a, HasCallStack) => [ByteString] -> a
toArgs

instance Command [ByteString] where
    toArgs :: [ByteString] -> [ByteString]
toArgs = [ByteString] -> [ByteString]
forall a. a -> a
id

instance Command [ByteString.ByteString] where
    toArgs :: [ByteString] -> [ByteString]
toArgs = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
toStrict

-- | This type represents a partially built command. Further arguments
-- can be supplied to it, or it can be turned into a `Proc` or directly
-- executed in a context which supports that (such as `IO`).
type Cmd = HasCallStack => forall a. (Command a) => a

-- | This function turns a `Cmd` into a list of @`ByteString`@s.
--
-- >>> displayCommand $ echo "Hello, world!"
-- ["echo","Hello, world!"]
displayCommand :: Cmd -> [ByteString]
displayCommand :: Cmd -> [ByteString]
displayCommand = \Cmd
c -> [ByteString] -> [ByteString]
forall a. (Command a, HasCallStack) => [ByteString] -> a
toArgs [ByteString]
Cmd
c

-- | Get all executables on your `$PATH`.
pathBins :: IO [FilePath]
pathBins :: IO [String]
pathBins = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
takeFileName ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
pathBinsAbs

-- | Get all uniquely named executables on your `$PATH` as absolute
-- file names. The uniqueness is determined by the filename, and not
-- the whole path. First one found wins.
pathBinsAbs :: IO [FilePath]
pathBinsAbs :: IO [String]
pathBinsAbs = do
    [String]
pathsVar <- String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
Split.splitOn String
":" (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getEnv String
"PATH"
    [String]
paths <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
Dir.doesDirectoryExist [String]
pathsVar
    [String] -> IO [String]
findBinsIn [String]
paths

-- | Get all uniquely named executables from the list of directories. Returns
-- a list of absolute file names.
findBinsIn :: [FilePath] -> IO [FilePath]
findBinsIn :: [String] -> IO [String]
findBinsIn [String]
paths = do
    [String]
ps <- ShowS -> [String] -> [String]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubOn ShowS
takeFileName ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
d -> ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
x -> String
dString -> ShowS
forall a. [a] -> [a] -> [a]
++(Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:String
x)) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
Dir.getDirectoryContents String
d) [String]
paths
    (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (IO Bool -> IO Bool
tryBool (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Permissions -> Bool) -> IO Permissions -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Permissions -> Bool
Dir.executable (IO Permissions -> IO Bool)
-> (String -> IO Permissions) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Permissions
Dir.getPermissions) [String]
ps

    where
        -- TODO: Eventually replace this with nubOrdOn (containers 0.6.0.1 dep)
        ordNubOn :: Ord b => (a -> b) -> [a] -> [a]
        ordNubOn :: (a -> b) -> [a] -> [a]
ordNubOn a -> b
f [a]
as = ((b, a) -> a) -> [(b, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (b, a) -> a
forall a b. (a, b) -> b
snd ([(b, a)] -> [a]) -> ([(b, a)] -> [(b, a)]) -> [(b, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map b a -> [(b, a)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map b a -> [(b, a)])
-> ([(b, a)] -> Map b a) -> [(b, a)] -> [(b, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> [(b, a)] -> Map b a
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith a -> a -> a
forall a b. a -> b -> a
const ([(b, a)] -> [a]) -> [(b, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ [b] -> [a] -> [(b, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
as) [a]
as

        tryBool :: IO Bool -> IO Bool
        tryBool :: IO Bool -> IO Bool
tryBool IO Bool
a = IO Bool -> IO (Either SomeException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
try IO Bool
a IO (Either SomeException Bool)
-> (Either SomeException Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left (SomeException e
_) -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Right Bool
r -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
r

-- | Execute the given command. Further arguments can be passed in.
--
-- > exe "ls" "-l"
--
-- See also `loadExe` and `loadEnv`.
--
-- NB: It is recommended that you use the template haskell functions to load
-- executables from your path. If you do it manually, it is recommended to
-- use @withFrozenCallStack@ from @GHC.Stack@
--
-- > echo :: Cmd
-- > echo = withFrozenCallStack (exe "echo")
exe :: (Command a, ExecArg str, HasCallStack) => str -> a
exe :: str -> a
exe str
s = (HasCallStack => a) -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => a) -> a) -> (HasCallStack => a) -> a
forall a b. (a -> b) -> a -> b
$ [ByteString] -> a
forall a. (Command a, HasCallStack) => [ByteString] -> a
toArgs (str -> [ByteString]
forall a. ExecArg a => a -> [ByteString]
asArg str
s)

-- | Create a function for the executable named
loadExe :: ExecReference -> String -> Q [Dec]
loadExe :: ExecReference -> String -> Q [Dec]
loadExe ExecReference
ref String
s = ExecReference -> String -> String -> Q [Dec]
loadExeAs ExecReference
ref String
s String
s

-- | Specify how executables should be referenced.
data ExecReference
    = Absolute -- ^ Find executables on PATH, but store their absolute path
    | SearchPath -- ^ Always search on PATH

-- | Template Haskell function to create a function from a path that will be
-- called. This does not check for executability at compile time.
rawExe :: String -> String -> Q [Dec]
rawExe :: String -> String -> Q [Dec]
rawExe String
fnName String
executable = do
    let
        name :: Name
name = String -> Name
mkName String
fnName
        impl :: DecQ
impl = PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
name) (ExpQ -> BodyQ
normalB [|
            withFrozenCallStack $ exe executable
            |]) []
        typ :: Dec
typ = Name -> Type -> Dec
SigD Name
name (Name -> Type
ConT ''Cmd)
    Dec
i <- DecQ
impl
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
typ,Dec
i]

-- | @$(loadExeAs ref fnName executable)@ defines a function called @fnName@
-- which executes the path in @executable@. If @executable@ is an absolute path
-- it is used directly. If it is just an executable name, then it is searched
-- for in the PATH environment variable. If @ref@ is @SearchPath@, the short
-- name is retained, and your PATH will be searched at runtime. If @ref@
-- is @Absolute@, a executable name will be turned into an absolute path, which
-- will be used at runtime.
loadExeAs :: ExecReference -> String -> String -> Q [Dec]
loadExeAs :: ExecReference -> String -> String -> Q [Dec]
loadExeAs ExecReference
ref String
fnName String
executable = do
    -- TODO: Can we place haddock markup in TH generated functions.
    -- TODO: Can we place the man page for each function in there xD
    -- https://ghc.haskell.org/trac/ghc/ticket/5467
    IO (Maybe String) -> Q (Maybe String)
forall a. IO a -> Q a
runIO (String -> IO (Maybe String)
Dir.findExecutable String
executable) Q (Maybe String) -> (Maybe String -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe String
Nothing -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Attempted to load '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
executable String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"', but it is not executable"
        Just String
absExe ->
            String -> String -> Q [Dec]
rawExe String
fnName (case ExecReference
ref of { ExecReference
Absolute -> String
absExe; ExecReference
SearchPath -> String
executable })


-- | Takes a string, and makes a Haskell identifier out of it. If the string
-- is a path, the filename portion is used. The exact transformation is that
-- alphanumeric characters are unchanged, @-@ becomes @_@, and @'@ is used to
-- escape all other characters. @_@ becomes @'_@, @.@ becomes @''@ and
-- anthing else is becomes a hex encoded number surrounded by @'@ characters.
--
-- Justification for changing @-@ to @_@ is that @-@ appears far more commonly
-- in executable names than @_@ does, and so we give it the more ergonomic
-- encoding.
--
-- >>> encodeIdentifier "nix-shell"
-- "nix_shell"
--
-- >>> encodeIdentifier "R"
-- "_R"
--
-- >>> encodeIdentifier "x86_64-unknown-linux-gnu-gcc"
-- "x86'_64_unknown_linux_gnu_gcc"
--
-- >>> encodeIdentifier "release.sh"
-- "release''sh"
encodeIdentifier :: String -> String
encodeIdentifier :: ShowS
encodeIdentifier String
ident =
    let
        fixBody :: String -> String
        fixBody :: ShowS
fixBody (Char
c:String
cs)
            | Char -> Bool
isAlphaNum Char
c = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
fixBody String
cs
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'     = Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
fixBody String
cs
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'     = Char
'\'' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
fixBody String
cs
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'     = Char
'\'' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'\'' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
fixBody String
cs
            | Bool
otherwise    = String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"'%x'%s" (Char -> Int
ord Char
c) (ShowS
fixBody String
cs)
        fixBody [] = []

        fixStart :: String -> String
        fixStart :: ShowS
fixStart s :: String
s@(Char
c : String
_)
            | Char -> Bool
isLower Char
c = String
s
            | Bool
otherwise = Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
s
        fixStart [] = []

        i :: String
i = ShowS
fixStart ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
fixBody ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
ident
        -- Includes cd, which has to be a built-in
        reserved :: [String]
reserved = [ String
"import", String
"if", String
"else", String
"then", String
"do", String
"in", String
"let", String
"type"
            , String
"as", String
"case", String
"of", String
"class", String
"data", String
"default", String
"deriving"
            , String
"instance", String
"forall", String
"foreign", String
"hiding", String
"infix", String
"infixl"
            , String
"infixr", String
"mdo", String
"module", String
"newtype", String
"proc", String
"qualified"
            , String
"rec", String
"where", String
"cd"]
    in if String
i String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reserved then String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" else String
i


-- | Scans your '$PATH' environment variable and creates a function for each
-- executable found. Binaries that would not create valid Haskell identifiers
-- are encoded using the @'encodeIdentifier'@ function.
loadEnv :: ExecReference -> Q [Dec]
loadEnv :: ExecReference -> Q [Dec]
loadEnv ExecReference
ref = ExecReference -> ShowS -> Q [Dec]
loadAnnotatedEnv ExecReference
ref ShowS
encodeIdentifier

-- | Test to see if an executable can be found either on the $PATH or absolute.
checkExecutable :: FilePath -> IO Bool
checkExecutable :: String -> IO Bool
checkExecutable = (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe String) -> IO Bool)
-> (String -> IO (Maybe String)) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
Dir.findExecutable

-- | Load the given executables into the program, checking their executability
-- and creating a function @missingExecutables@ to do a runtime check for their
-- availability. Uses the @'encodeIdentifier'@ function to create function
-- names.
load :: ExecReference -> [FilePath] -> Q [Dec]
load :: ExecReference -> [String] -> Q [Dec]
load ExecReference
ref = ExecReference -> ShowS -> [String] -> Q [Dec]
loadAnnotated ExecReference
ref ShowS
encodeIdentifier

-- | Same as `load`, but allows you to modify the function names.
loadAnnotated :: ExecReference -> (String -> String) -> [FilePath] -> Q [Dec]
loadAnnotated :: ExecReference -> ShowS -> [String] -> Q [Dec]
loadAnnotated ExecReference
ref ShowS
f [String]
bins = do
    let pairs :: [(String, String)]
pairs = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
f [String]
bins) [String]
bins
    [Dec]
ds <- [[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, String) -> Q [Dec]) -> [(String, String)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String -> Q [Dec]) -> (String, String) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ExecReference -> String -> String -> Q [Dec]
loadExeAs ExecReference
ref)) [(String, String)]
pairs
    Dec
d <- PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP (String -> Name
mkName String
"missingExecutables")) (ExpQ -> BodyQ
normalB [|
                filterM (fmap not . checkExecutable) bins
            |]) []

    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec
dDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
ds)

-- | Like `loadEnv`, but allows you to modify the function name that would
-- be generated.
loadAnnotatedEnv :: ExecReference -> (String -> String) -> Q [Dec]
loadAnnotatedEnv :: ExecReference -> ShowS -> Q [Dec]
loadAnnotatedEnv ExecReference
ref ShowS
f = do
    [String]
bins <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO (IO [String] -> Q [String]) -> IO [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ case ExecReference
ref of
        ExecReference
Absolute -> IO [String]
pathBinsAbs
        ExecReference
SearchPath -> IO [String]
pathBins
    [[Dec]]
i <- [String] -> (String -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
bins ((String -> Q [Dec]) -> Q [[Dec]])
-> (String -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \String
bin -> do
        String -> String -> Q [Dec]
rawExe (ShowS
f ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
bin) String
bin
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
i)


-- | Split a string separated by the provided separator. A trailing separator
-- is ignored, and does not produce an empty string. Compatible with the
-- output of most CLI programs, such as @find -print0@.
--
-- >>> endBy "\n" "a\nb\n"
-- ["a","b"]
--
-- >>> endBy "\n" "a\nb"
-- ["a","b"]
--
-- >>> endBy "\n" "a\nb\n\n"
-- ["a","b",""]
endBy :: ByteString -> ByteString -> [ByteString]
endBy :: ByteString -> ByteString -> [ByteString]
endBy ByteString
s ByteString
str =
    let splits :: [ByteString]
splits = ByteString -> ByteString -> [ByteString]
Search.split (ByteString -> ByteString
toStrict ByteString
s) ByteString
str
    in [ByteString] -> [ByteString]
dropLastNull [ByteString]
splits

    where
        dropLastNull :: [ByteString] -> [ByteString]
        dropLastNull :: [ByteString] -> [ByteString]
dropLastNull []   = []
        dropLastNull [ByteString
""] = []
        dropLastNull (ByteString
a : [ByteString]
as) = ByteString
a ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
dropLastNull [ByteString]
as

-- | Load executables from the given directories
loadFromDirs :: [FilePath] -> Q [Dec]
loadFromDirs :: [String] -> Q [Dec]
loadFromDirs [String]
ps = [String] -> ShowS -> Q [Dec]
loadAnnotatedFromDirs [String]
ps ShowS
encodeIdentifier

-- | Load executables from the given directories appended with @"/bin"@.
--
-- Useful for use with Nix.
loadFromBins :: [FilePath] -> Q [Dec]
loadFromBins :: [String] -> Q [Dec]
loadFromBins = [String] -> Q [Dec]
loadFromDirs ([String] -> Q [Dec])
-> ([String] -> [String]) -> [String] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
</> String
"bin")

-- | Load executables from the given dirs, applying the given transformation
-- to the filenames.
loadAnnotatedFromDirs :: [FilePath] -> (String -> String) -> Q [Dec]
loadAnnotatedFromDirs :: [String] -> ShowS -> Q [Dec]
loadAnnotatedFromDirs [String]
ps ShowS
f = do
    [String]
bins <- IO [String] -> Q [String]
forall a. IO a -> Q a
runIO (IO [String] -> Q [String]) -> IO [String] -> Q [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
findBinsIn [String]
ps
    [[Dec]]
i <- [String] -> (String -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
bins ((String -> Q [Dec]) -> Q [[Dec]])
-> (String -> Q [Dec]) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \String
bin -> do
        String -> String -> Q [Dec]
rawExe (ShowS
f ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
bin) String
bin
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
i)

-- | Function that splits '\0' separated list of strings. Useful in conjunction
-- with @find . "-print0"@.
endBy0 :: ByteString -> [ByteString]
endBy0 :: ByteString -> [ByteString]
endBy0 = ByteString -> ByteString -> [ByteString]
endBy ByteString
"\0"

-- | Mimics the shell builtin "cd".
cd' :: FilePath -> IO ()
cd' :: String -> IO ()
cd' String
p = do
    String -> IO ()
Dir.setCurrentDirectory String
p
    String
a <- IO String
Dir.getCurrentDirectory
    String -> String -> IO ()
setEnv String
"PWD" String
a

-- | Helper class for variable number of arguments to @cd@ builtin.
class Cd a where
    -- | Mimics the shell builtin "cd". Be careful using this function
    -- in a program, as it doesn't play well with multiple threads. Best
    -- to just use it in an interactive shell or for very simple
    -- transliterations of shell scripts.
    cd :: a

instance (io ~ IO ()) => Cd io where
    cd :: io
cd = String -> IO String
getEnv String
"HOME" IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
cd'

instance {-# OVERLAPS #-} (io ~ IO (), path ~ FilePath) => Cd (path -> io) where
    cd :: path -> io
cd = path -> io
String -> IO ()
cd'

-- | @xargs1 n f@ runs @f@ for each item in the input separated by @n@. Similar
-- to the standard @xargs@ utility, but you get to choose the separator, and it
-- only does one argument per command. Compare the following two lines, which
-- do the same thing.
--
-- >>> printf "a\\0b" |> xargs "--null" "-L1" "echo" |> cat
-- a
-- b
-- >>> printf "a\\0b" |> xargs1 "\0" echo |> cat
-- a
-- b
--
-- One benefit of this method over the standard @xargs@ is that we can run
-- Haskell functions as well.
--
-- >>> yes |> head "-n" 5 |> xargs1 "\n" (const $ pure $ Sum 1)
-- Sum {getSum = 5}
xargs1 :: (NFData a, Monoid a) => ByteString -> (ByteString -> Proc a) -> Proc a
xargs1 :: ByteString -> (ByteString -> Proc a) -> Proc a
xargs1 ByteString
n ByteString -> Proc a
f = ByteString -> ([ByteString] -> Proc a) -> Proc a
forall a (io :: * -> *).
(NFData a, Shell io) =>
ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP ByteString
n (([a] -> a) -> Proc [a] -> Proc a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. Monoid a => [a] -> a
mconcat (Proc [a] -> Proc a)
-> ([ByteString] -> Proc [a]) -> [ByteString] -> Proc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Proc a) -> [ByteString] -> Proc [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ByteString -> Proc a
f)

-- | Simple @`Proc`@ that reads its input and can react to the output by
-- calling other @`Proc`@'s which can write something to its stdout.
-- The internal @`Proc`@ is given @/dev/null@ as its input.
readInputP :: (NFData a, Shell io) => (ByteString -> Proc a) -> io a
readInputP :: (ByteString -> Proc a) -> io a
readInputP ByteString -> Proc a
f = (Handle -> Handle -> Handle -> IO a) -> io a
forall (f :: * -> *) a.
(Shell f, NFData a) =>
(Handle -> Handle -> Handle -> IO a) -> f a
nativeProc ((Handle -> Handle -> Handle -> IO a) -> io a)
-> (Handle -> Handle -> Handle -> IO a) -> io a
forall a b. (a -> b) -> a -> b
$ \Handle
i Handle
o Handle
e -> do
    ByteString
s <- Handle -> IO ByteString
hGetContents Handle
i
    (Handle -> IO a) -> IO a
forall a. (Handle -> IO a) -> IO a
withNullInput ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
i' ->
        IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Handle -> Handle -> Handle -> Proc a -> IO a
forall a. Handle -> Handle -> Handle -> Proc a -> IO a
runProc' Handle
i' Handle
o Handle
e (ByteString -> Proc a
f ByteString
s)

-- | Like @`readInputP`@, but splits the input.
readInputEndByP :: (NFData a, Shell io) => ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP :: ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP ByteString
s [ByteString] -> Proc a
f = (ByteString -> Proc a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
(ByteString -> Proc a) -> io a
readInputP ([ByteString] -> Proc a
f ([ByteString] -> Proc a)
-> (ByteString -> [ByteString]) -> ByteString -> Proc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> [ByteString]
endBy ByteString
s)

-- | Like @`readInputP`@, but splits the input on 0 bytes.
readInputEndBy0P :: (NFData a, Shell io) => ([ByteString] -> Proc a) -> io a
readInputEndBy0P :: ([ByteString] -> Proc a) -> io a
readInputEndBy0P = ByteString -> ([ByteString] -> Proc a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP ByteString
"\0"

-- | Like @`readInputP`@, but splits the input on new lines.
readInputLinesP :: (NFData a, Shell io) => ([ByteString] -> Proc a) -> io a
readInputLinesP :: ([ByteString] -> Proc a) -> io a
readInputLinesP = ByteString -> ([ByteString] -> Proc a) -> io a
forall a (io :: * -> *).
(NFData a, Shell io) =>
ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP ByteString
"\n"

-- | Create a null file handle.
withNullInput :: (Handle -> IO a) -> IO a
withNullInput :: (Handle -> IO a) -> IO a
withNullInput = String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
"/dev/null" IOMode
ReadMode

-- | Bracket a @`hDup`@
withDuplicate :: Handle -> (Handle -> IO a) -> IO a
withDuplicate :: Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
h = IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Handle -> IO Handle
hDup Handle
h) Handle -> IO ()
hClose

-- | Bracket three @`hDup`@s
withDuplicates :: Handle -> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicates :: Handle
-> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicates Handle
a Handle
b Handle
c Handle -> Handle -> Handle -> IO a
f =
    Handle -> (Handle -> IO a) -> IO a
forall a. Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
a ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
a' -> Handle -> (Handle -> IO a) -> IO a
forall a. Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
b ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
b' -> Handle -> (Handle -> IO a) -> IO a
forall a. Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
c ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
c' -> Handle -> Handle -> Handle -> IO a
f Handle
a' Handle
b' Handle
c'

-- | Bracket two @`hDup`@s and provide a null input handle.
withDuplicateNullInput :: Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicateNullInput :: Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicateNullInput Handle
a Handle
b Handle -> Handle -> Handle -> IO a
f = do
    (Handle -> IO a) -> IO a
forall a. (Handle -> IO a) -> IO a
withNullInput ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
i -> do
        Handle -> (Handle -> IO a) -> IO a
forall a. Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
a ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
a' -> Handle -> (Handle -> IO a) -> IO a
forall a. Handle -> (Handle -> IO a) -> IO a
withDuplicate Handle
b ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
b' -> Handle -> Handle -> Handle -> IO a
f Handle
i Handle
a' Handle
b'

-- | Duplicate a @`Handle`@ without trying to flush buffers. Only works on @`FileHandle`@s.
--
-- hDuplicate tries to "flush" read buffers by seeking backwards, which doesn't
-- work for streams/pipes. Since we are simulating a @fork + exec@ in @`nativeProc`@,
-- losing the buffers is actually the expected behaviour. (System.Process doesn't
-- attempt to flush the buffers).
--
-- NB: An alternate solution that we could implement (even for System.Process forks)
-- is to create a fresh pipe and spawn an async task to forward buffered content
-- from the original handle if there is something in the buffer. My concern would
-- be that it might be a performance hit that people aren't expecting.
--
-- Code basically copied from
-- http://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.IO.Handle.html#hDuplicate
-- with minor modifications.
hDup :: Handle -> IO Handle
hDup :: Handle -> IO Handle
hDup h :: Handle
h@(FileHandle String
path MVar Handle__
m) = do
    String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle) -> IO Handle
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDup" Handle
h MVar Handle__
m ((Handle__ -> IO Handle) -> IO Handle)
-> (Handle__ -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$ \Handle__
h_ ->
        String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh String
path Handle
h Maybe (MVar Handle__)
forall a. Maybe a
Nothing Handle__
h_ (HandleFinalizer -> Maybe HandleFinalizer
forall a. a -> Maybe a
Just HandleFinalizer
handleFinalizer)
hDup h :: Handle
h@(DuplexHandle String
path MVar Handle__
r MVar Handle__
w) = do
    (FileHandle String
_ MVar Handle__
write_m) <-
        String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle) -> IO Handle
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDup" Handle
h MVar Handle__
w ((Handle__ -> IO Handle) -> IO Handle)
-> (Handle__ -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$ \Handle__
h_ ->
            String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh String
path Handle
h Maybe (MVar Handle__)
forall a. Maybe a
Nothing Handle__
h_ (HandleFinalizer -> Maybe HandleFinalizer
forall a. a -> Maybe a
Just HandleFinalizer
handleFinalizer)
    (FileHandle String
_ MVar Handle__
read_m) <-
        String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle) -> IO Handle
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDup" Handle
h MVar Handle__
r ((Handle__ -> IO Handle) -> IO Handle)
-> (Handle__ -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$ \Handle__
h_ ->
            String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh String
path Handle
h (MVar Handle__ -> Maybe (MVar Handle__)
forall a. a -> Maybe a
Just MVar Handle__
write_m) Handle__
h_  Maybe HandleFinalizer
forall a. Maybe a
Nothing
    Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> MVar Handle__ -> MVar Handle__ -> Handle
DuplexHandle String
path MVar Handle__
read_m MVar Handle__
write_m)

-- | Helper function for duplicating a Handle
dupHandleShh
    :: FilePath
    -> Handle
    -> Maybe (MVar Handle__)
    -> Handle__
    -> Maybe HandleFinalizer
    -> IO Handle
dupHandleShh :: String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh String
filepath Handle
h Maybe (MVar Handle__)
other_side h_ :: Handle__
h_@Handle__{dev
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
Maybe TextEncoding
Maybe (MVar Handle__)
HandleType
BufferMode
Newline
IORef (dec_state, Buffer Word8)
IORef (BufferList Char)
IORef (Buffer Char)
IORef (Buffer Word8)
haDevice :: ()
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer Char)
haBuffers :: Handle__ -> IORef (BufferList Char)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOtherSide :: Maybe (MVar Handle__)
haOutputNL :: Newline
haInputNL :: Newline
haCodec :: Maybe TextEncoding
haDecoder :: Maybe (TextDecoder dec_state)
haEncoder :: Maybe (TextEncoder enc_state)
haBuffers :: IORef (BufferList Char)
haCharBuffer :: IORef (Buffer Char)
haLastDecode :: IORef (dec_state, Buffer Word8)
haBufferMode :: BufferMode
haByteBuffer :: IORef (Buffer Word8)
haType :: HandleType
haDevice :: dev
..} Maybe HandleFinalizer
mb_finalizer = do
    case Maybe (MVar Handle__)
other_side of
        Maybe (MVar Handle__)
Nothing -> do
            dev
new_dev <- dev -> IO dev
forall a. IODevice a => a -> IO a
IODevice.dup dev
haDevice
            dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh_ dev
new_dev String
filepath Maybe (MVar Handle__)
other_side Handle__
h_ Maybe HandleFinalizer
mb_finalizer
        Just MVar Handle__
r  ->
            String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle) -> IO Handle
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"dupHandleShh" Handle
h MVar Handle__
r ((Handle__ -> IO Handle) -> IO Handle)
-> (Handle__ -> IO Handle) -> IO Handle
forall a b. (a -> b) -> a -> b
$ \Handle__{haDevice :: ()
haDevice=dev
dev} -> do
                dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh_ dev
dev String
filepath Maybe (MVar Handle__)
other_side Handle__
h_ Maybe HandleFinalizer
mb_finalizer

-- | Helper function for duplicating a Handle
dupHandleShh_
#if __GLASGOW_HASKELL__ < 900
    :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
#else
    :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
#endif
    -> FilePath
    -> Maybe (MVar Handle__)
    -> Handle__
    -> Maybe HandleFinalizer
    -> IO Handle
dupHandleShh_ :: dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh_ dev
new_dev String
filepath Maybe (MVar Handle__)
other_side Handle__{dev
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
Maybe TextEncoding
Maybe (MVar Handle__)
HandleType
BufferMode
Newline
IORef (dec_state, Buffer Word8)
IORef (BufferList Char)
IORef (Buffer Char)
IORef (Buffer Word8)
haOtherSide :: Maybe (MVar Handle__)
haOutputNL :: Newline
haInputNL :: Newline
haCodec :: Maybe TextEncoding
haDecoder :: Maybe (TextDecoder dec_state)
haEncoder :: Maybe (TextEncoder enc_state)
haBuffers :: IORef (BufferList Char)
haCharBuffer :: IORef (Buffer Char)
haLastDecode :: IORef (dec_state, Buffer Word8)
haBufferMode :: BufferMode
haByteBuffer :: IORef (Buffer Word8)
haType :: HandleType
haDevice :: dev
haDevice :: ()
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer Char)
haBuffers :: Handle__ -> IORef (BufferList Char)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
..} Maybe HandleFinalizer
mb_finalizer = do
    -- XXX wrong!
    Maybe TextEncoding
mb_codec <- if Maybe (TextEncoder enc_state) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TextEncoder enc_state)
haEncoder then (TextEncoding -> Maybe TextEncoding)
-> IO TextEncoding -> IO (Maybe TextEncoding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just IO TextEncoding
getLocaleEncoding else Maybe TextEncoding -> IO (Maybe TextEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TextEncoding
forall a. Maybe a
Nothing
    dev
-> String
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
mkHandle dev
new_dev String
filepath HandleType
haType Bool
True{-buffered-} Maybe TextEncoding
mb_codec
        NewlineMode :: Newline -> Newline -> NewlineMode
NewlineMode { inputNL :: Newline
inputNL = Newline
haInputNL, outputNL :: Newline
outputNL = Newline
haOutputNL }
        Maybe HandleFinalizer
mb_finalizer Maybe (MVar Handle__)
other_side