{-# LANGUAGE RankNTypes #-}

{-| This module provides `ByteString` analogs of several utilities in
    "Turtle.Prelude".  The main difference is that the chunks of bytes read by
    these utilities are not necessarily aligned to line boundaries.
-}

module Turtle.Bytes (
    -- * Byte operations
      stdin
    , input
    , inhandle
    , stdout
    , output
    , outhandle
    , append
    , stderr
    , strict
    , compress
    , decompress
    , WindowBits(..)
    , Zlib.defaultWindowBits
    , fromUTF8
    , toUTF8

    -- * Subprocess management
    , proc
    , shell
    , procs
    , shells
    , inproc
    , inshell
    , inprocWithErr
    , inshellWithErr
    , procStrict
    , shellStrict
    , procStrictWithErr
    , shellStrictWithErr

    , system
    , stream
    , streamWithErr
    , systemStrict
    , systemStrictWithErr
    ) where

import Control.Applicative
import Control.Concurrent.Async (Async, Concurrently(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (MonadManaged(..))
import Data.ByteString (ByteString)
import Data.Monoid
import Data.Streaming.Zlib (Inflate, Popper, PopperRes(..), WindowBits(..))
import Data.Text (Text)
import Data.Text.Encoding (Decoding(..))
import System.Exit (ExitCode(..))
import System.IO (Handle)
import Turtle.Internal (ignoreSIGPIPE)
import Turtle.Prelude (ProcFailed(..), ShellFailed(..))
import Turtle.Shell (Shell(..), FoldShell(..), fold, sh)

import qualified Control.Concurrent.Async      as Async
import qualified Control.Concurrent.STM        as STM
import qualified Control.Concurrent.MVar       as MVar
import qualified Control.Concurrent.STM.TQueue as TQueue
import qualified Control.Exception             as Exception
import qualified Control.Foldl
import qualified Control.Monad
import qualified Control.Monad.Managed         as Managed
import qualified Data.ByteString
import qualified Data.Streaming.Zlib           as Zlib
import qualified Data.Text
import qualified Data.Text.Encoding            as Encoding
import qualified Data.Text.Encoding.Error      as Encoding.Error
import qualified Foreign
import qualified System.IO
import qualified System.Process                as Process
import qualified Turtle.Prelude

{-| Read chunks of bytes from standard input

    The chunks are not necessarily aligned to line boundaries
-}
stdin :: Shell ByteString
stdin :: Shell ByteString
stdin = Handle -> Shell ByteString
inhandle Handle
System.IO.stdin

{-| Read chunks of bytes from a file

    The chunks are not necessarily aligned to line boundaries
-}
input :: FilePath -> Shell ByteString
input :: FilePath -> Shell ByteString
input FilePath
file = do
    handle <- Managed Handle -> Shell Handle
forall a. Managed a -> Shell a
forall (m :: * -> *) a. MonadManaged m => Managed a -> m a
using (FilePath -> Managed Handle
forall (managed :: * -> *).
MonadManaged managed =>
FilePath -> managed Handle
Turtle.Prelude.readonly FilePath
file)
    inhandle handle

{-| Read chunks of bytes from a `Handle`

    The chunks are not necessarily aligned to line boundaries
-}
inhandle :: Handle -> Shell ByteString
inhandle :: Handle -> Shell ByteString
inhandle Handle
handle = (forall r. FoldShell ByteString r -> IO r) -> Shell ByteString
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> ByteString -> IO x
step x
begin x -> IO r
done) -> do
    let loop :: x -> IO r
loop x
x = do
            eof <- Handle -> IO Bool
System.IO.hIsEOF Handle
handle
            if eof
                then done x
                else do
                    bytes <- Data.ByteString.hGetSome handle defaultChunkSize
                    x'    <- step x bytes
                    loop $! x'
    x -> IO r
loop (x -> IO r) -> x -> IO r
forall a b. (a -> b) -> a -> b
$! x
begin )
  where
    -- Copied from `Data.ByteString.Lazy.Internal`
    defaultChunkSize :: Int
    defaultChunkSize :: Int
defaultChunkSize = Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (Int
forall a. HasCallStack => a
undefined :: Int)

{-| Stream chunks of bytes to standard output

    The chunks are not necessarily aligned to line boundaries
-}
stdout :: MonadIO io => Shell ByteString -> io ()
stdout :: forall (io :: * -> *). MonadIO io => Shell ByteString -> io ()
stdout Shell ByteString
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    bytes <- Shell ByteString
s
    liftIO (Data.ByteString.hPut System.IO.stdout bytes) )

{-| Stream chunks of bytes to a file

    The chunks do not need to be aligned to line boundaries
-}
output :: MonadIO io => FilePath -> Shell ByteString -> io ()
output :: forall (io :: * -> *).
MonadIO io =>
FilePath -> Shell ByteString -> io ()
output FilePath
file Shell ByteString
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    handle <- Managed Handle -> Shell Handle
forall a. Managed a -> Shell a
forall (m :: * -> *) a. MonadManaged m => Managed a -> m a
using (FilePath -> Managed Handle
forall (managed :: * -> *).
MonadManaged managed =>
FilePath -> managed Handle
Turtle.Prelude.writeonly FilePath
file)
    bytes  <- s
    liftIO (Data.ByteString.hPut handle bytes) )

{-| Stream chunks of bytes to a `Handle`

    The chunks do not need to be aligned to line boundaries
-}
outhandle :: MonadIO io => Handle -> Shell ByteString -> io ()
outhandle :: forall (io :: * -> *).
MonadIO io =>
Handle -> Shell ByteString -> io ()
outhandle Handle
handle Shell ByteString
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    bytes <- Shell ByteString
s
    liftIO (Data.ByteString.hPut handle bytes) )

{-| Append chunks of bytes to append to a file

    The chunks do not need to be aligned to line boundaries
-}
append :: MonadIO io => FilePath -> Shell ByteString -> io ()
append :: forall (io :: * -> *).
MonadIO io =>
FilePath -> Shell ByteString -> io ()
append FilePath
file Shell ByteString
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    handle <- Managed Handle -> Shell Handle
forall a. Managed a -> Shell a
forall (m :: * -> *) a. MonadManaged m => Managed a -> m a
using (FilePath -> Managed Handle
forall (managed :: * -> *).
MonadManaged managed =>
FilePath -> managed Handle
Turtle.Prelude.appendonly FilePath
file)
    bytes  <- s
    liftIO (Data.ByteString.hPut handle bytes) )

{-| Stream chunks of bytes to standard error

    The chunks do not need to be aligned to line boundaries
-}
stderr :: MonadIO io => Shell ByteString -> io ()
stderr :: forall (io :: * -> *). MonadIO io => Shell ByteString -> io ()
stderr Shell ByteString
s = Shell () -> io ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
    bytes <- Shell ByteString
s
    liftIO (Data.ByteString.hPut System.IO.stderr bytes) )

-- | Read in a stream's contents strictly
strict :: MonadIO io => Shell ByteString -> io ByteString
strict :: forall (io :: * -> *).
MonadIO io =>
Shell ByteString -> io ByteString
strict Shell ByteString
s = do
    listOfByteStrings <- Shell ByteString -> Fold ByteString [ByteString] -> io [ByteString]
forall (io :: * -> *) a b.
MonadIO io =>
Shell a -> Fold a b -> io b
fold Shell ByteString
s Fold ByteString [ByteString]
forall a. Fold a [a]
Control.Foldl.list
    return (Data.ByteString.concat listOfByteStrings)

{-| Run a command using @execvp@, retrieving the exit code

    The command inherits @stdout@ and @stderr@ for the current process
-}
proc
    :: MonadIO io
    => Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io ExitCode
    -- ^ Exit code
proc :: forall (io :: * -> *).
MonadIO io =>
Text -> [Text] -> Shell ByteString -> io ExitCode
proc Text
cmd [Text]
args =
    CreateProcess -> Shell ByteString -> io ExitCode
forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io ExitCode
system
        ( (FilePath -> [FilePath] -> CreateProcess
Process.proc (Text -> FilePath
Data.Text.unpack Text
cmd) ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Data.Text.unpack [Text]
args))
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.Inherit
            , Process.std_err = Process.Inherit
            } )

{-| Run a command line using the shell, retrieving the exit code

    This command is more powerful than `proc`, but highly vulnerable to code
    injection if you template the command line with untrusted input

    The command inherits @stdout@ and @stderr@ for the current process
-}
shell
    :: MonadIO io
    => Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io ExitCode
    -- ^ Exit code
shell :: forall (io :: * -> *).
MonadIO io =>
Text -> Shell ByteString -> io ExitCode
shell Text
cmdline =
    CreateProcess -> Shell ByteString -> io ExitCode
forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io ExitCode
system
        ( (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Data.Text.unpack Text
cmdline))
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.Inherit
            , Process.std_err = Process.Inherit
            } )

{-| This function is identical to `proc` except this throws `ProcFailed` for
    non-zero exit codes
-}
procs
    :: MonadIO io
    => Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io ()
procs :: forall (io :: * -> *).
MonadIO io =>
Text -> [Text] -> Shell ByteString -> io ()
procs Text
cmd [Text]
args Shell ByteString
s = do
    exitCode <- Text -> [Text] -> Shell ByteString -> io ExitCode
forall (io :: * -> *).
MonadIO io =>
Text -> [Text] -> Shell ByteString -> io ExitCode
proc Text
cmd [Text]
args Shell ByteString
s
    case exitCode of
        ExitCode
ExitSuccess -> () -> io ()
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ExitCode
_           -> IO () -> io ()
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcFailed -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO (Text -> [Text] -> ExitCode -> ProcFailed
ProcFailed Text
cmd [Text]
args ExitCode
exitCode))

{-| This function is identical to `shell` except this throws `ShellFailed` for
    non-zero exit codes
-}
shells
    :: MonadIO io
    => Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io ()
    -- ^ Exit code
shells :: forall (io :: * -> *).
MonadIO io =>
Text -> Shell ByteString -> io ()
shells Text
cmdline Shell ByteString
s = do
    exitCode <- Text -> Shell ByteString -> io ExitCode
forall (io :: * -> *).
MonadIO io =>
Text -> Shell ByteString -> io ExitCode
shell Text
cmdline Shell ByteString
s
    case exitCode of
        ExitCode
ExitSuccess -> () -> io ()
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ExitCode
_           -> IO () -> io ()
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ShellFailed -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO (Text -> ExitCode -> ShellFailed
ShellFailed Text
cmdline ExitCode
exitCode))

{-| Run a command using @execvp@, retrieving the exit code and stdout as a
    non-lazy blob of Text

    The command inherits @stderr@ for the current process
-}
procStrict
    :: MonadIO io
    => Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString)
    -- ^ Exit code and stdout
procStrict :: forall (io :: * -> *).
MonadIO io =>
Text -> [Text] -> Shell ByteString -> io (ExitCode, ByteString)
procStrict Text
cmd [Text]
args =
    CreateProcess -> Shell ByteString -> io (ExitCode, ByteString)
forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io (ExitCode, ByteString)
systemStrict (FilePath -> [FilePath] -> CreateProcess
Process.proc (Text -> FilePath
Data.Text.unpack Text
cmd) ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Data.Text.unpack [Text]
args))

{-| Run a command line using the shell, retrieving the exit code and stdout as a
    non-lazy blob of Text

    This command is more powerful than `proc`, but highly vulnerable to code
    injection if you template the command line with untrusted input

    The command inherits @stderr@ for the current process
-}
shellStrict
    :: MonadIO io
    => Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString)
    -- ^ Exit code and stdout
shellStrict :: forall (io :: * -> *).
MonadIO io =>
Text -> Shell ByteString -> io (ExitCode, ByteString)
shellStrict Text
cmdline = CreateProcess -> Shell ByteString -> io (ExitCode, ByteString)
forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io (ExitCode, ByteString)
systemStrict (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Data.Text.unpack Text
cmdline))

{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr
    as a non-lazy blob of Text
-}
procStrictWithErr
    :: MonadIO io
    => Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString, ByteString)
    -- ^ (Exit code, stdout, stderr)
procStrictWithErr :: forall (io :: * -> *).
MonadIO io =>
Text
-> [Text]
-> Shell ByteString
-> io (ExitCode, ByteString, ByteString)
procStrictWithErr Text
cmd [Text]
args =
    CreateProcess
-> Shell ByteString -> io (ExitCode, ByteString, ByteString)
forall (io :: * -> *).
MonadIO io =>
CreateProcess
-> Shell ByteString -> io (ExitCode, ByteString, ByteString)
systemStrictWithErr (FilePath -> [FilePath] -> CreateProcess
Process.proc (Text -> FilePath
Data.Text.unpack Text
cmd) ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Data.Text.unpack [Text]
args))

{-| Run a command line using the shell, retrieving the exit code, stdout, and
    stderr as a non-lazy blob of Text

    This command is more powerful than `proc`, but highly vulnerable to code
    injection if you template the command line with untrusted input
-}
shellStrictWithErr
    :: MonadIO io
    => Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString, ByteString)
    -- ^ (Exit code, stdout, stderr)
shellStrictWithErr :: forall (io :: * -> *).
MonadIO io =>
Text -> Shell ByteString -> io (ExitCode, ByteString, ByteString)
shellStrictWithErr Text
cmdline =
    CreateProcess
-> Shell ByteString -> io (ExitCode, ByteString, ByteString)
forall (io :: * -> *).
MonadIO io =>
CreateProcess
-> Shell ByteString -> io (ExitCode, ByteString, ByteString)
systemStrictWithErr (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Data.Text.unpack Text
cmdline))

-- | Halt an `Async` thread, re-raising any exceptions it might have thrown
halt :: Async a -> IO ()
halt :: forall a. Async a -> IO ()
halt Async a
a = do
    m <- Async a -> IO (Maybe (Either SomeException a))
forall a. Async a -> IO (Maybe (Either SomeException a))
Async.poll Async a
a
    case m of
        Maybe (Either SomeException a)
Nothing        -> Async a -> IO ()
forall a. Async a -> IO ()
Async.cancel Async a
a
        Just (Left  SomeException
e) -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO SomeException
e
        Just (Right a
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-| `system` generalizes `shell` and `proc` by allowing you to supply your own
    custom `CreateProcess`.  This is for advanced users who feel comfortable
    using the lower-level @process@ API
-}
system
    :: MonadIO io
    => Process.CreateProcess
    -- ^ Command
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io ExitCode
    -- ^ Exit code
system :: forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io ExitCode
system CreateProcess
p Shell ByteString
s = IO ExitCode -> io ExitCode
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (do
    let open :: IO (Maybe Handle, ProcessHandle)
open = do
            (m, Nothing, Nothing, ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
p
            case m of
                Just Handle
hIn -> Handle -> BufferMode -> IO ()
System.IO.hSetBuffering Handle
hIn (Maybe Int -> BufferMode
System.IO.BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
                Maybe Handle
_        -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            return (m, ph)

    -- Prevent double close
    mvar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
MVar.newMVar Bool
False
    let close Handle
handle = do
            MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar Bool
mvar (\Bool
finalized -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless Bool
finalized
                    (IO () -> IO ()
ignoreSIGPIPE (Handle -> IO ()
System.IO.hClose Handle
handle))
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True )
    let close' (Just Handle
hIn, ProcessHandle
ph) = do
            Handle -> IO ()
close Handle
hIn
            ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph
        close' (Maybe Handle
Nothing , ProcessHandle
ph) = do
            ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph

    let handle (Just Handle
hIn, ProcessHandle
ph) = do
            let feedIn :: (forall a. IO a -> IO a) -> IO ()
                feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn forall a. IO a -> IO a
restore =
                    IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()
ignoreSIGPIPE (Handle -> Shell ByteString -> IO ()
forall (io :: * -> *).
MonadIO io =>
Handle -> Shell ByteString -> io ()
outhandle Handle
hIn Shell ByteString
s))
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
close Handle
hIn
            ((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
feedIn IO a -> IO a
forall a. IO a -> IO a
restore) (\Async ()
a ->
                    IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
restore (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
ph) IO ExitCode -> IO () -> IO ExitCode
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async () -> IO ()
forall a. Async a -> IO ()
halt Async ()
a ) )
        handle (Maybe Handle
Nothing , ProcessHandle
ph) = do
            ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
ph

    Exception.bracket open close' handle )

{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to
    supply your own custom `CreateProcess`.  This is for advanced users who feel
    comfortable using the lower-level @process@ API
-}
systemStrict
    :: MonadIO io
    => Process.CreateProcess
    -- ^ Command
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString)
    -- ^ Exit code and stdout
systemStrict :: forall (io :: * -> *).
MonadIO io =>
CreateProcess -> Shell ByteString -> io (ExitCode, ByteString)
systemStrict CreateProcess
p Shell ByteString
s = IO (ExitCode, ByteString) -> io (ExitCode, ByteString)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (do
    let p' :: CreateProcess
p' = CreateProcess
p
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.CreatePipe
            , Process.std_err = Process.Inherit
            }

    let open :: IO (Handle, Handle, ProcessHandle)
open = do
            (Just hIn, Just hOut, Nothing, ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
p')
            System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)
            return (hIn, hOut, ph)

    -- Prevent double close
    mvar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
MVar.newMVar Bool
False
    let close Handle
handle = do
            MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar Bool
mvar (\Bool
finalized -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless Bool
finalized
                    (IO () -> IO ()
ignoreSIGPIPE (Handle -> IO ()
System.IO.hClose Handle
handle))
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True )

    Exception.bracket open (\(Handle
hIn, Handle
_, ProcessHandle
ph) -> Handle -> IO ()
close Handle
hIn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph) (\(Handle
hIn, Handle
hOut, ProcessHandle
ph) -> do
        let feedIn :: (forall a. IO a -> IO a) -> IO ()
            feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn forall a. IO a -> IO a
restore =
                IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()
ignoreSIGPIPE (Handle -> Shell ByteString -> IO ()
forall (io :: * -> *).
MonadIO io =>
Handle -> Shell ByteString -> io ()
outhandle Handle
hIn Shell ByteString
s))
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
close Handle
hIn

        IO ExitCode -> IO ByteString -> IO (ExitCode, ByteString)
forall a b. IO a -> IO b -> IO (a, b)
Async.concurrently
            (((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
feedIn IO a -> IO a
forall a. IO a -> IO a
restore) (\Async ()
a ->
                    IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
restore (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
ph) IO ExitCode -> IO () -> IO ExitCode
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async () -> IO ()
forall a. Async a -> IO ()
halt Async ()
a ) ))
            (Handle -> IO ByteString
Data.ByteString.hGetContents Handle
hOut) ) )

{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and
    `procStrictWithErr` by allowing you to supply your own custom
    `CreateProcess`.  This is for advanced users who feel comfortable using
    the lower-level @process@ API
-}
systemStrictWithErr
    :: MonadIO io
    => Process.CreateProcess
    -- ^ Command
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> io (ExitCode, ByteString, ByteString)
    -- ^ Exit code and stdout
systemStrictWithErr :: forall (io :: * -> *).
MonadIO io =>
CreateProcess
-> Shell ByteString -> io (ExitCode, ByteString, ByteString)
systemStrictWithErr CreateProcess
p Shell ByteString
s = IO (ExitCode, ByteString, ByteString)
-> io (ExitCode, ByteString, ByteString)
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (do
    let p' :: CreateProcess
p' = CreateProcess
p
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.CreatePipe
            , Process.std_err = Process.CreatePipe
            }

    let open :: IO (Handle, Handle, Handle, ProcessHandle)
open = do
            (Just hIn, Just hOut, Just hErr, ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
p')
            System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)
            return (hIn, hOut, hErr, ph)

    -- Prevent double close
    mvar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
MVar.newMVar Bool
False
    let close Handle
handle = do
            MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar Bool
mvar (\Bool
finalized -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless Bool
finalized
                    (IO () -> IO ()
ignoreSIGPIPE (Handle -> IO ()
System.IO.hClose Handle
handle))
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True )

    Exception.bracket open (\(Handle
hIn, Handle
_, Handle
_, ProcessHandle
ph) -> Handle -> IO ()
close Handle
hIn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph) (\(Handle
hIn, Handle
hOut, Handle
hErr, ProcessHandle
ph) -> do
        let feedIn :: (forall a. IO a -> IO a) -> IO ()
            feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn forall a. IO a -> IO a
restore =
                IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()
ignoreSIGPIPE (Handle -> Shell ByteString -> IO ()
forall (io :: * -> *).
MonadIO io =>
Handle -> Shell ByteString -> io ()
outhandle Handle
hIn Shell ByteString
s))
                IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
close Handle
hIn

        Concurrently (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall a. Concurrently a -> IO a
runConcurrently (Concurrently (ExitCode, ByteString, ByteString)
 -> IO (ExitCode, ByteString, ByteString))
-> Concurrently (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (,,)
            (ExitCode
 -> ByteString -> ByteString -> (ExitCode, ByteString, ByteString))
-> Concurrently ExitCode
-> Concurrently
     (ByteString -> ByteString -> (ExitCode, ByteString, ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ExitCode -> Concurrently ExitCode
forall a. IO a -> Concurrently a
Concurrently (((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                    IO () -> (Async () -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
feedIn IO a -> IO a
forall a. IO a -> IO a
restore) (\Async ()
a ->
                        IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
restore (ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
ph) IO ExitCode -> IO () -> IO ExitCode
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async () -> IO ()
forall a. Async a -> IO ()
halt Async ()
a ) ))
            Concurrently
  (ByteString -> ByteString -> (ExitCode, ByteString, ByteString))
-> Concurrently ByteString
-> Concurrently (ByteString -> (ExitCode, ByteString, ByteString))
forall a b.
Concurrently (a -> b) -> Concurrently a -> Concurrently b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ByteString -> Concurrently ByteString
forall a. IO a -> Concurrently a
Concurrently (Handle -> IO ByteString
Data.ByteString.hGetContents Handle
hOut)
            Concurrently (ByteString -> (ExitCode, ByteString, ByteString))
-> Concurrently ByteString
-> Concurrently (ExitCode, ByteString, ByteString)
forall a b.
Concurrently (a -> b) -> Concurrently a -> Concurrently b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ByteString -> Concurrently ByteString
forall a. IO a -> Concurrently a
Concurrently (Handle -> IO ByteString
Data.ByteString.hGetContents Handle
hErr) ) )

{-| Run a command using @execvp@, streaming @stdout@ as chunks of `ByteString`

    The command inherits @stderr@ for the current process
-}
inproc
    :: Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell ByteString
    -- ^ Chunks of bytes read from process output
inproc :: Text -> [Text] -> Shell ByteString -> Shell ByteString
inproc Text
cmd [Text]
args =
    CreateProcess -> Shell ByteString -> Shell ByteString
stream (FilePath -> [FilePath] -> CreateProcess
Process.proc (Text -> FilePath
Data.Text.unpack Text
cmd) ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Data.Text.unpack [Text]
args))

{-| Run a command line using the shell, streaming @stdout@ as chunks of
    `ByteString`

    This command is more powerful than `inproc`, but highly vulnerable to code
    injection if you template the command line with untrusted input

    The command inherits @stderr@ for the current process
-}
inshell
    :: Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell ByteString
    -- ^ Chunks of bytes read from process output
inshell :: Text -> Shell ByteString -> Shell ByteString
inshell Text
cmd = CreateProcess -> Shell ByteString -> Shell ByteString
stream (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Data.Text.unpack Text
cmd))

waitForProcessThrows :: Process.ProcessHandle -> IO ()
waitForProcessThrows :: ProcessHandle -> IO ()
waitForProcessThrows ProcessHandle
ph = do
    exitCode <- ProcessHandle -> IO ExitCode
Process.waitForProcess ProcessHandle
ph
    case exitCode of
        ExitCode
ExitSuccess   -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ExitFailure Int
_ -> ExitCode -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO ExitCode
exitCode

{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your
    own custom `CreateProcess`.  This is for advanced users who feel comfortable
    using the lower-level @process@ API

    Throws an `ExitCode` exception if the command returns a non-zero exit code
-}
stream
    :: Process.CreateProcess
    -- ^ Command
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell ByteString
    -- ^ Chunks of bytes read from process output
stream :: CreateProcess -> Shell ByteString -> Shell ByteString
stream CreateProcess
p Shell ByteString
s = do
    let p' :: CreateProcess
p' = CreateProcess
p
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.CreatePipe
            , Process.std_err = Process.Inherit
            }

    let open :: IO (Handle, Handle, ProcessHandle)
open = do
            (Just hIn, Just hOut, Nothing, ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
p')
            System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)
            return (hIn, hOut, ph)

    -- Prevent double close
    mvar <- IO (MVar Bool) -> Shell (MVar Bool)
forall a. IO a -> Shell a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
MVar.newMVar Bool
False)
    let close Handle
handle = do
            MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar Bool
mvar (\Bool
finalized -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless Bool
finalized (IO () -> IO ()
ignoreSIGPIPE (Handle -> IO ()
System.IO.hClose Handle
handle))
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True )

    (hIn, hOut, ph) <- using (Managed.managed (Exception.bracket open (\(Handle
hIn, Handle
_, ProcessHandle
ph) -> Handle -> IO ()
close Handle
hIn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph)))
    let feedIn :: (forall a. IO a -> IO a) -> IO ()
        feedIn forall a. IO a -> IO a
restore =
            IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()
ignoreSIGPIPE (Shell () -> IO ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
                bytes <- Shell ByteString
s
                liftIO (Data.ByteString.hPut hIn bytes) ) ) )
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
close Handle
hIn

    a <- using
        (Managed.managed (\Async () -> IO r
k ->
            ((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
feedIn IO a -> IO a
forall a. IO a -> IO a
restore) Async () -> IO r
k ) ))
    inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty)

{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing
    you to supply your own custom `CreateProcess`.  This is for advanced users
    who feel comfortable using the lower-level @process@ API

    Throws an `ExitCode` exception if the command returns a non-zero exit code
-}
streamWithErr
    :: Process.CreateProcess
    -- ^ Command
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell (Either ByteString ByteString)
    -- ^ Chunks of bytes read from process output
streamWithErr :: CreateProcess
-> Shell ByteString -> Shell (Either ByteString ByteString)
streamWithErr CreateProcess
p Shell ByteString
s = do
    let p' :: CreateProcess
p' = CreateProcess
p
            { Process.std_in  = Process.CreatePipe
            , Process.std_out = Process.CreatePipe
            , Process.std_err = Process.CreatePipe
            }

    let open :: IO (Handle, Handle, Handle, ProcessHandle)
open = do
            (Just hIn, Just hOut, Just hErr, ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess CreateProcess
p')
            System.IO.hSetBuffering hIn (System.IO.BlockBuffering Nothing)
            return (hIn, hOut, hErr, ph)

    -- Prevent double close
    mvar <- IO (MVar Bool) -> Shell (MVar Bool)
forall a. IO a -> Shell a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
MVar.newMVar Bool
False)
    let close Handle
handle = do
            MVar Bool -> (Bool -> IO Bool) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ MVar Bool
mvar (\Bool
finalized -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.unless Bool
finalized (IO () -> IO ()
ignoreSIGPIPE (Handle -> IO ()
System.IO.hClose Handle
handle))
                Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True )

    (hIn, hOut, hErr, ph) <- using (Managed.managed (Exception.bracket open (\(Handle
hIn, Handle
_, Handle
_, ProcessHandle
ph) -> Handle -> IO ()
close Handle
hIn IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ()
Process.terminateProcess ProcessHandle
ph)))
    let feedIn :: (forall a. IO a -> IO a) -> IO ()
        feedIn forall a. IO a -> IO a
restore =
            IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()
ignoreSIGPIPE (Shell () -> IO ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
                bytes <- Shell ByteString
s
                liftIO (Data.ByteString.hPut hIn bytes) ) ) )
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` Handle -> IO ()
close Handle
hIn

    queue <- liftIO TQueue.newTQueueIO
    let forwardOut :: (forall a. IO a -> IO a) -> IO ()
        forwardOut forall a. IO a -> IO a
restore =
            IO () -> IO ()
forall a. IO a -> IO a
restore (Shell () -> IO ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
                bytes <- Handle -> Shell ByteString
inhandle Handle
hOut
                liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right bytes)))) ))
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TQueue (Maybe (Either ByteString ByteString))
-> Maybe (Either ByteString ByteString) -> STM ()
forall a. TQueue a -> a -> STM ()
TQueue.writeTQueue TQueue (Maybe (Either ByteString ByteString))
queue Maybe (Either ByteString ByteString)
forall a. Maybe a
Nothing)
    let forwardErr :: (forall a. IO a -> IO a) -> IO ()
        forwardErr forall a. IO a -> IO a
restore =
            IO () -> IO ()
forall a. IO a -> IO a
restore (Shell () -> IO ()
forall (io :: * -> *) a. MonadIO io => Shell a -> io ()
sh (do
                bytes <- Handle -> Shell ByteString
inhandle Handle
hErr
                liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left  bytes)))) ))
            IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TQueue (Maybe (Either ByteString ByteString))
-> Maybe (Either ByteString ByteString) -> STM ()
forall a. TQueue a -> a -> STM ()
TQueue.writeTQueue TQueue (Maybe (Either ByteString ByteString))
queue Maybe (Either ByteString ByteString)
forall a. Maybe a
Nothing)
    let drain = (forall r. FoldShell (Either ByteString ByteString) r -> IO r)
-> Shell (Either ByteString ByteString)
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell (\(FoldShell x -> Either ByteString ByteString -> IO x
step x
begin x -> IO r
done) -> do
            let loop :: x -> a -> IO x
loop x
x a
numNothing
                    | a
numNothing a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
2 = do
                        m <- STM (Maybe (Either ByteString ByteString))
-> IO (Maybe (Either ByteString ByteString))
forall a. STM a -> IO a
STM.atomically (TQueue (Maybe (Either ByteString ByteString))
-> STM (Maybe (Either ByteString ByteString))
forall a. TQueue a -> STM a
TQueue.readTQueue TQueue (Maybe (Either ByteString ByteString))
queue)
                        case m of
                            Maybe (Either ByteString ByteString)
Nothing -> x -> a -> IO x
loop x
x (a -> IO x) -> a -> IO x
forall a b. (a -> b) -> a -> b
$! a
numNothing a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
                            Just Either ByteString ByteString
e  -> do
                                x' <- x -> Either ByteString ByteString -> IO x
step x
x Either ByteString ByteString
e
                                loop x' numNothing
                    | Bool
otherwise      = x -> IO x
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return x
x
            x1 <- x -> Int -> IO x
forall {a}. (Ord a, Num a) => x -> a -> IO x
loop x
begin (Int
0 :: Int)
            done x1 )

    a <- using
        (Managed.managed (\Async () -> IO r
k ->
            ((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
feedIn IO a -> IO a
forall a. IO a -> IO a
restore) Async () -> IO r
k ) ))
    b <- using
        (Managed.managed (\Async () -> IO r
k ->
            ((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
forwardOut IO a -> IO a
forall a. IO a -> IO a
restore) Async () -> IO r
k ) ))
    c <- using
        (Managed.managed (\Async () -> IO r
k ->
            ((forall a. IO a -> IO a) -> IO r) -> IO r
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exception.mask (\forall a. IO a -> IO a
restore ->
                IO () -> (Async () -> IO r) -> IO r
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync ((forall a. IO a -> IO a) -> IO ()
forwardErr IO a -> IO a
forall a. IO a -> IO a
restore) Async () -> IO r
k ) ))
    let STM a
l `also` STM a
r = do
            _ <- STM a
l STM a -> STM a -> STM a
forall a. STM a -> STM a -> STM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (STM a
r STM a -> STM a -> STM a
forall a b. STM a -> STM b -> STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> STM a
forall a. STM a
STM.retry)
            _ <- r
            return ()
    let waitAll = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (Async () -> STM ()
forall a. Async a -> STM a
Async.waitSTM Async ()
a STM () -> STM () -> STM ()
forall {a} {a}. STM a -> STM a -> STM ()
`also` (Async () -> STM ()
forall a. Async a -> STM a
Async.waitSTM Async ()
b STM () -> STM () -> STM ()
forall {a} {a}. STM a -> STM a -> STM ()
`also` Async () -> STM ()
forall a. Async a -> STM a
Async.waitSTM Async ()
c))
    drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty)

{-| Run a command using the shell, streaming @stdout@ and @stderr@ as chunks of
    `ByteString`.  Chunks from @stdout@ are wrapped in `Right` and chunks from
    @stderr@ are wrapped in `Left`.

    Throws an `ExitCode` exception if the command returns a non-zero exit code
-}
inprocWithErr
    :: Text
    -- ^ Command
    -> [Text]
    -- ^ Arguments
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell (Either ByteString ByteString)
    -- ^ Chunks of either output (`Right`) or error (`Left`)
inprocWithErr :: Text
-> [Text]
-> Shell ByteString
-> Shell (Either ByteString ByteString)
inprocWithErr Text
cmd [Text]
args =
    CreateProcess
-> Shell ByteString -> Shell (Either ByteString ByteString)
streamWithErr (FilePath -> [FilePath] -> CreateProcess
Process.proc (Text -> FilePath
Data.Text.unpack Text
cmd) ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Data.Text.unpack [Text]
args))


{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as
    chunks of `ByteString`.  Chunks from @stdout@ are wrapped in `Right` and
    chunks from @stderr@ are wrapped in `Left`.

    This command is more powerful than `inprocWithErr`, but highly vulnerable to
    code injection if you template the command line with untrusted input

    Throws an `ExitCode` exception if the command returns a non-zero exit code
-}
inshellWithErr
    :: Text
    -- ^ Command line
    -> Shell ByteString
    -- ^ Chunks of bytes written to process input
    -> Shell (Either ByteString ByteString)
    -- ^ Chunks of either output (`Right`) or error (`Left`)
inshellWithErr :: Text -> Shell ByteString -> Shell (Either ByteString ByteString)
inshellWithErr Text
cmd = CreateProcess
-> Shell ByteString -> Shell (Either ByteString ByteString)
streamWithErr (FilePath -> CreateProcess
Process.shell (Text -> FilePath
Data.Text.unpack Text
cmd))

-- | Internal utility used by both `compress` and `decompress`
fromPopper :: Popper -> Shell ByteString
fromPopper :: Popper -> Shell ByteString
fromPopper Popper
popper = Shell ByteString
loop
  where
    loop :: Shell ByteString
loop = do
        result <- Popper -> Shell PopperRes
forall a. IO a -> Shell a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO Popper
popper

        case result of
            PopperRes
PRDone ->
                Shell ByteString
forall a. Shell a
forall (f :: * -> *) a. Alternative f => f a
empty
            PRNext ByteString
compressedByteString ->
                ByteString -> Shell ByteString
forall a. a -> Shell a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
compressedByteString Shell ByteString -> Shell ByteString -> Shell ByteString
forall a. Shell a -> Shell a -> Shell a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Shell ByteString
loop
            PRError ZlibException
exception ->
                IO ByteString -> Shell ByteString
forall a. IO a -> Shell a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ZlibException -> IO ByteString
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO ZlibException
exception)

{-| Compress a stream using @zlib@

    Note that this can decompress streams that are the concatenation of
    multiple compressed streams (just like @gzip@)

>>> let compressed = select [ "ABC", "DEF" ] & compress 0 defaultWindowBits
>>> compressed & decompress defaultWindowBits & view
"ABCDEF"
>>> (compressed <|> compressed) & decompress defaultWindowBits & view
"ABCDEF"
"ABCDEF"
-}
compress
    :: Int
    -- ^ Compression level
    -> WindowBits
    -- ^
    -> Shell ByteString
    -- ^
    -> Shell ByteString
compress :: Int -> WindowBits -> Shell ByteString -> Shell ByteString
compress Int
compressionLevel WindowBits
windowBits Shell ByteString
bytestrings = do
    deflate <- IO Deflate -> Shell Deflate
forall a. IO a -> Shell a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> WindowBits -> IO Deflate
Zlib.initDeflate Int
compressionLevel WindowBits
windowBits)

    let loop = do
            bytestring <- Shell ByteString
bytestrings

            popper <- liftIO (Zlib.feedDeflate deflate bytestring)

            fromPopper popper

    let wrapUp = do
            let popper :: Popper
popper = Popper -> Popper
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Deflate -> Popper
Zlib.finishDeflate Deflate
deflate)

            Popper -> Shell ByteString
fromPopper Popper
popper

    loop <|> wrapUp

data DecompressionState = Uninitialized | Decompressing Inflate

-- | Decompress a stream using @zlib@ (just like the @gzip@ command)
decompress :: WindowBits -> Shell ByteString -> Shell ByteString
decompress :: WindowBits -> Shell ByteString -> Shell ByteString
decompress WindowBits
windowBits (Shell forall r. FoldShell ByteString r -> IO r
k) = (forall r. FoldShell ByteString r -> IO r) -> Shell ByteString
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell FoldShell ByteString r -> IO r
forall r. FoldShell ByteString r -> IO r
k'
  where
    k' :: FoldShell ByteString b -> IO b
k' (FoldShell x -> ByteString -> IO x
step x
begin x -> IO b
done) = FoldShell ByteString b -> IO b
forall r. FoldShell ByteString r -> IO r
k (((x, DecompressionState)
 -> ByteString -> IO (x, DecompressionState))
-> (x, DecompressionState)
-> ((x, DecompressionState) -> IO b)
-> FoldShell ByteString b
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell (x, DecompressionState) -> ByteString -> IO (x, DecompressionState)
step' (x, DecompressionState)
begin' (x, DecompressionState) -> IO b
done')
      where
        begin' :: (x, DecompressionState)
begin' = (x
begin, DecompressionState
Uninitialized)

        step' :: (x, DecompressionState) -> ByteString -> IO (x, DecompressionState)
step' (x
x0, DecompressionState
Uninitialized) ByteString
compressedByteString = do
            inflate <- WindowBits -> IO Inflate
Zlib.initInflate WindowBits
windowBits

            step' (x0, Decompressing inflate) compressedByteString
        step' (x
x0, Decompressing Inflate
inflate) ByteString
compressedByteString = do
            popper <- Inflate -> ByteString -> IO Popper
Zlib.feedInflate Inflate
inflate ByteString
compressedByteString

            let loop x
x = do
                    result <- Popper
popper

                    case result of
                        PopperRes
PRDone -> do
                            compressedByteString' <- Inflate -> IO ByteString
Zlib.getUnusedInflate Inflate
inflate

                            if Data.ByteString.null compressedByteString'
                                then return (x, Decompressing inflate)
                                else do
                                    decompressedByteString <- Zlib.finishInflate inflate

                                    x' <- step x decompressedByteString

                                    step' (x', Uninitialized) compressedByteString'
                        PRNext ByteString
decompressedByteString -> do
                            x' <- x -> ByteString -> IO x
step x
x ByteString
decompressedByteString

                            loop x'
                        PRError ZlibException
exception -> do
                            ZlibException -> IO (x, DecompressionState)
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO ZlibException
exception

            loop x0

        done' :: (x, DecompressionState) -> IO b
done' (x
x0, DecompressionState
Uninitialized) = do
            x -> IO b
done x
x0
        done' (x
x0, Decompressing Inflate
inflate) = do
            decompressedByteString <- Inflate -> IO ByteString
Zlib.finishInflate Inflate
inflate

            x0' <- step x0 decompressedByteString

            done' (x0', Uninitialized)

{-| Decode a stream of bytes as UTF8 `Text`

    NOTE: This function will throw a pure exception (i.e. an `error`) if UTF8
    decoding fails (mainly due to limitations in the @text@ package's stream
    decoding API)
-}
toUTF8 :: Shell ByteString -> Shell Text
toUTF8 :: Shell ByteString -> Shell Text
toUTF8 (Shell forall r. FoldShell ByteString r -> IO r
k) = (forall r. FoldShell Text r -> IO r) -> Shell Text
forall a. (forall r. FoldShell a r -> IO r) -> Shell a
Shell FoldShell Text r -> IO r
forall r. FoldShell Text r -> IO r
k'
  where
    k' :: FoldShell Text b -> IO b
k' (FoldShell x -> Text -> IO x
step x
begin x -> IO b
done) =
        FoldShell ByteString b -> IO b
forall r. FoldShell ByteString r -> IO r
k (((ByteString, ByteString -> Decoding, x)
 -> ByteString -> IO (ByteString, ByteString -> Decoding, x))
-> (ByteString, ByteString -> Decoding, x)
-> ((ByteString, ByteString -> Decoding, x) -> IO b)
-> FoldShell ByteString b
forall a b x. (x -> a -> IO x) -> x -> (x -> IO b) -> FoldShell a b
FoldShell (ByteString, ByteString -> Decoding, x)
-> ByteString -> IO (ByteString, ByteString -> Decoding, x)
forall {a}.
Semigroup a =>
(a, a -> Decoding, x)
-> a -> IO (ByteString, ByteString -> Decoding, x)
step' (ByteString, ByteString -> Decoding, x)
begin' (ByteString, ByteString -> Decoding, x) -> IO b
forall {a} {b}. (a, b, x) -> IO b
done')
      where
        begin' :: (ByteString, ByteString -> Decoding, x)
begin' =
            (ByteString
forall a. Monoid a => a
mempty, OnDecodeError -> ByteString -> Decoding
Encoding.streamDecodeUtf8With OnDecodeError
Encoding.Error.strictDecode, x
begin)

        step' :: (a, a -> Decoding, x)
-> a -> IO (ByteString, ByteString -> Decoding, x)
step' (a
prefix, a -> Decoding
decoder, x
x) a
suffix = do
            let bytes :: a
bytes = a
prefix a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
suffix

            let Some Text
text ByteString
prefix' ByteString -> Decoding
decoder' = a -> Decoding
decoder a
bytes 

            x' <- x -> Text -> IO x
step x
x Text
text

            return (prefix', decoder', x')

        done' :: (a, b, x) -> IO b
done' (a
_, b
_, x
x) = do
            x -> IO b
done x
x

-- | Encode a stream of bytes as UTF8 `Text`
fromUTF8 :: Shell Text -> Shell ByteString
fromUTF8 :: Shell Text -> Shell ByteString
fromUTF8 = (Text -> ByteString) -> Shell Text -> Shell ByteString
forall a b. (a -> b) -> Shell a -> Shell b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
Encoding.encodeUtf8