{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-|
  Description:
    A monad for running shell commands in Haskell and combining their output.

Coquina provides a convenient interface for running shell commands in Haskell.
The core functionality of Coquina is the ability to run a sequence of 'Shell'
operations, inspect the output of each operation, combine their results (i.e.,
their exit codes, stdout, and stderr), and stop execution if one of them fails.
See the readme for an example.
-}
module Coquina
  (
  -- * The Shell Monad
    MonadShell(..)
  , tellStdout
  , tellStderr
  , readStdout
  , readStderr
  , Shell(..)
  , runShell
  , execShell
  , hoistShell
  -- * Constructing Shell actions
  , run
  , shellCreateProcess
  , shellCreateProcessWith
  , shellCreateProcessWithEnv
  , runCreateProcess
  , runCreateProcessWithEnv
  , shellCreateProcessWithStdOut
  -- * Running in a temporary directory
  , inTempDirectory
  -- * Streamable Shell processes
  , StreamingProcess(..)
  , shellStreamableProcess
  , shellStreamableProcessBuffered
    -- * Miscellaneous
  , logCommand
  , showCommand
  ) where

import Coquina.Internal (readAndDecodeCreateProcess, withForkWait)

import qualified Control.Concurrent.Async as Async
import Control.DeepSeq (rnf)
import Control.Exception (evaluate)
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, finally)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad.Fix
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Except (mapExceptT)
import Control.Monad.Writer
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T (pack)
import qualified Data.Text.Encoding as T (decodeUtf8)
import qualified Data.Text.IO as T (putStrLn)
import GHC.Generics (Generic)
import GHC.IO.Handle (BufferMode(..), Handle, hClose, hIsOpen, hIsReadable, hSetBuffering)
import System.Environment (getEnvironment)
import System.Exit (ExitCode(..))
import System.IO.Temp (withSystemTempDirectory)
import System.Process

instance MonadLogger m => MonadLogger (Shell m) where

-- | A class that supports reading and writing stdout and stderr
class Monad m => MonadShell m where
  tellOutput :: (Text, Text) -> m ()
  readOutput :: m a -> m ((Text, Text), a)

-- | Write to stdout
tellStdout :: MonadShell m => Text -> m ()
tellStdout :: forall (m :: * -> *). MonadShell m => Text -> m ()
tellStdout Text
s = (Text, Text) -> m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
s, Text
forall a. Monoid a => a
mempty)

-- | Write to stderr
tellStderr :: MonadShell m => Text -> m ()
tellStderr :: forall (m :: * -> *). MonadShell m => Text -> m ()
tellStderr Text
s = (Text, Text) -> m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
forall a. Monoid a => a
mempty, Text
s)

-- | Read the stdout of a command
readStdout :: MonadShell m => m a -> m (Text, a)
readStdout :: forall (m :: * -> *) a. MonadShell m => m a -> m (Text, a)
readStdout m a
f = do
  ((Text
out, Text
_), a
a) <- m a -> m ((Text, Text), a)
forall a. m a -> m ((Text, Text), a)
forall (m :: * -> *) a. MonadShell m => m a -> m ((Text, Text), a)
readOutput m a
f
  (Text, a) -> m (Text, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
out, a
a)

-- | Read the stderr of a command
readStderr :: MonadShell m => m a -> m (Text, a)
readStderr :: forall (m :: * -> *) a. MonadShell m => m a -> m (Text, a)
readStderr m a
f = do
  ((Text
_, Text
err), a
a) <- m a -> m ((Text, Text), a)
forall a. m a -> m ((Text, Text), a)
forall (m :: * -> *) a. MonadShell m => m a -> m ((Text, Text), a)
readOutput m a
f
  (Text, a) -> m (Text, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
err, a
a)

-- | An action that supports running commands, reading their output, and emitting output
newtype Shell m a = Shell { forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (Text, Text) m) a
unShell :: ExceptT Int (WriterT (Text, Text) m) a }
  deriving ((forall a b. (a -> b) -> Shell m a -> Shell m b)
-> (forall a b. a -> Shell m b -> Shell m a) -> Functor (Shell m)
forall a b. a -> Shell m b -> Shell m a
forall a b. (a -> b) -> Shell m a -> Shell m b
forall (m :: * -> *) a b. Functor m => a -> Shell m b -> Shell m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Shell m a -> Shell m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Shell m a -> Shell m b
fmap :: forall a b. (a -> b) -> Shell m a -> Shell m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Shell m b -> Shell m a
<$ :: forall a b. a -> Shell m b -> Shell m a
Functor, Functor (Shell m)
Functor (Shell m) =>
(forall a. a -> Shell m a)
-> (forall a b. Shell m (a -> b) -> Shell m a -> Shell m b)
-> (forall a b c.
    (a -> b -> c) -> Shell m a -> Shell m b -> Shell m c)
-> (forall a b. Shell m a -> Shell m b -> Shell m b)
-> (forall a b. Shell m a -> Shell m b -> Shell m a)
-> Applicative (Shell m)
forall a. a -> Shell m a
forall a b. Shell m a -> Shell m b -> Shell m a
forall a b. Shell m a -> Shell m b -> Shell m b
forall a b. Shell m (a -> b) -> Shell m a -> Shell m b
forall a b c. (a -> b -> c) -> Shell m a -> Shell m b -> Shell m c
forall (m :: * -> *). Monad m => Functor (Shell m)
forall (m :: * -> *) a. Monad m => a -> Shell m a
forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m a
forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m b
forall (m :: * -> *) a b.
Monad m =>
Shell m (a -> b) -> Shell m a -> Shell m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Shell m a -> Shell m b -> Shell m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> Shell m a
pure :: forall a. a -> Shell m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Shell m (a -> b) -> Shell m a -> Shell m b
<*> :: forall a b. Shell m (a -> b) -> Shell m a -> Shell m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Shell m a -> Shell m b -> Shell m c
liftA2 :: forall a b c. (a -> b -> c) -> Shell m a -> Shell m b -> Shell m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m b
*> :: forall a b. Shell m a -> Shell m b -> Shell m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m a
<* :: forall a b. Shell m a -> Shell m b -> Shell m a
Applicative, Applicative (Shell m)
Applicative (Shell m) =>
(forall a b. Shell m a -> (a -> Shell m b) -> Shell m b)
-> (forall a b. Shell m a -> Shell m b -> Shell m b)
-> (forall a. a -> Shell m a)
-> Monad (Shell m)
forall a. a -> Shell m a
forall a b. Shell m a -> Shell m b -> Shell m b
forall a b. Shell m a -> (a -> Shell m b) -> Shell m b
forall (m :: * -> *). Monad m => Applicative (Shell m)
forall (m :: * -> *) a. Monad m => a -> Shell m a
forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m b
forall (m :: * -> *) a b.
Monad m =>
Shell m a -> (a -> Shell m b) -> Shell m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Shell m a -> (a -> Shell m b) -> Shell m b
>>= :: forall a b. Shell m a -> (a -> Shell m b) -> Shell m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Shell m a -> Shell m b -> Shell m b
>> :: forall a b. Shell m a -> Shell m b -> Shell m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Shell m a
return :: forall a. a -> Shell m a
Monad, Monad (Shell m)
Monad (Shell m) =>
(forall a. IO a -> Shell m a) -> MonadIO (Shell m)
forall a. IO a -> Shell m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (Shell m)
forall (m :: * -> *) a. MonadIO m => IO a -> Shell m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Shell m a
liftIO :: forall a. IO a -> Shell m a
MonadIO, MonadError Int, Monad (Shell m)
Monad (Shell m) =>
(forall e a. (HasCallStack, Exception e) => e -> Shell m a)
-> MonadThrow (Shell m)
forall e a. (HasCallStack, Exception e) => e -> Shell m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (Shell m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> Shell m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> Shell m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Shell m a
MonadThrow, MonadThrow (Shell m)
MonadThrow (Shell m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 Shell m a -> (e -> Shell m a) -> Shell m a)
-> MonadCatch (Shell m)
forall e a.
(HasCallStack, Exception e) =>
Shell m a -> (e -> Shell m a) -> Shell m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (Shell m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
Shell m a -> (e -> Shell m a) -> Shell m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
Shell m a -> (e -> Shell m a) -> Shell m a
catch :: forall e a.
(HasCallStack, Exception e) =>
Shell m a -> (e -> Shell m a) -> Shell m a
MonadCatch, MonadCatch (Shell m)
MonadCatch (Shell m) =>
(forall b.
 HasCallStack =>
 ((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b)
-> (forall b.
    HasCallStack =>
    ((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b)
-> (forall a b c.
    HasCallStack =>
    Shell m a
    -> (a -> ExitCase b -> Shell m c)
    -> (a -> Shell m b)
    -> Shell m (b, c))
-> MonadMask (Shell m)
forall b.
HasCallStack =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
forall a b c.
HasCallStack =>
Shell m a
-> (a -> ExitCase b -> Shell m c)
-> (a -> Shell m b)
-> Shell m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (Shell m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
Shell m a
-> (a -> ExitCase b -> Shell m c)
-> (a -> Shell m b)
-> Shell m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
mask :: forall b.
HasCallStack =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Shell m a -> Shell m a) -> Shell m b) -> Shell m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
Shell m a
-> (a -> ExitCase b -> Shell m c)
-> (a -> Shell m b)
-> Shell m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Shell m a
-> (a -> ExitCase b -> Shell m c)
-> (a -> Shell m b)
-> Shell m (b, c)
MonadMask)

instance MonadTrans Shell where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Shell m a
lift = ExceptT Int (WriterT (Text, Text) m) a -> Shell m a
forall (m :: * -> *) a.
ExceptT Int (WriterT (Text, Text) m) a -> Shell m a
Shell (ExceptT Int (WriterT (Text, Text) m) a -> Shell m a)
-> (m a -> ExceptT Int (WriterT (Text, Text) m) a)
-> m a
-> Shell m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Text, Text) m a -> ExceptT Int (WriterT (Text, Text) m) a
forall (m :: * -> *) a. Monad m => m a -> ExceptT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Text, Text) m a
 -> ExceptT Int (WriterT (Text, Text) m) a)
-> (m a -> WriterT (Text, Text) m a)
-> m a
-> ExceptT Int (WriterT (Text, Text) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT (Text, Text) m a
forall (m :: * -> *) a. Monad m => m a -> WriterT (Text, Text) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance Monad m => MonadShell (Shell m) where
  tellOutput :: (Text, Text) -> Shell m ()
tellOutput = ExceptT Int (WriterT (Text, Text) m) () -> Shell m ()
forall (m :: * -> *) a.
ExceptT Int (WriterT (Text, Text) m) a -> Shell m a
Shell (ExceptT Int (WriterT (Text, Text) m) () -> Shell m ())
-> ((Text, Text) -> ExceptT Int (WriterT (Text, Text) m) ())
-> (Text, Text)
-> Shell m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> ExceptT Int (WriterT (Text, Text) m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  readOutput :: forall a. Shell m a -> Shell m ((Text, Text), a)
readOutput Shell m a
f = ExceptT Int (WriterT (Text, Text) m) ((Text, Text), a)
-> Shell m ((Text, Text), a)
forall (m :: * -> *) a.
ExceptT Int (WriterT (Text, Text) m) a -> Shell m a
Shell (ExceptT Int (WriterT (Text, Text) m) ((Text, Text), a)
 -> Shell m ((Text, Text), a))
-> ExceptT Int (WriterT (Text, Text) m) ((Text, Text), a)
-> Shell m ((Text, Text), a)
forall a b. (a -> b) -> a -> b
$ do
    (a
a, (Text, Text)
out) <- ExceptT Int (WriterT (Text, Text) m) a
-> ExceptT Int (WriterT (Text, Text) m) (a, (Text, Text))
forall a.
ExceptT Int (WriterT (Text, Text) m) a
-> ExceptT Int (WriterT (Text, Text) m) (a, (Text, Text))
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (ExceptT Int (WriterT (Text, Text) m) a
 -> ExceptT Int (WriterT (Text, Text) m) (a, (Text, Text)))
-> ExceptT Int (WriterT (Text, Text) m) a
-> ExceptT Int (WriterT (Text, Text) m) (a, (Text, Text))
forall a b. (a -> b) -> a -> b
$ Shell m a -> ExceptT Int (WriterT (Text, Text) m) a
forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (Text, Text) m) a
unShell Shell m a
f
    ((Text, Text), a)
-> ExceptT Int (WriterT (Text, Text) m) ((Text, Text), a)
forall a. a -> ExceptT Int (WriterT (Text, Text) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, Text)
out, a
a)

instance MonadWriter w m => MonadWriter w (Shell m) where
  tell :: w -> Shell m ()
tell = m () -> Shell m ()
forall (m :: * -> *) a. Monad m => m a -> Shell m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> Shell m ()) -> (w -> m ()) -> w -> Shell m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  -- NB: If the Shell action fails, the listen fails as well
  listen :: forall a. Shell m a -> Shell m (a, w)
listen Shell m a
x = do
    ((Text
out, Text
err, Either Int a
r), w
w) <- m ((Text, Text, Either Int a), w)
-> Shell m ((Text, Text, Either Int a), w)
forall (m :: * -> *) a. Monad m => m a -> Shell m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ((Text, Text, Either Int a), w)
 -> Shell m ((Text, Text, Either Int a), w))
-> m ((Text, Text, Either Int a), w)
-> Shell m ((Text, Text, Either Int a), w)
forall a b. (a -> b) -> a -> b
$ m (Text, Text, Either Int a) -> m ((Text, Text, Either Int a), w)
forall a. m a -> m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m (Text, Text, Either Int a) -> m ((Text, Text, Either Int a), w))
-> m (Text, Text, Either Int a)
-> m ((Text, Text, Either Int a), w)
forall a b. (a -> b) -> a -> b
$ Shell m a -> m (Text, Text, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (Text, Text, Either Int a)
runShell Shell m a
x
    (Text, Text) -> Shell m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
out, Text
err)
    case Either Int a
r of
      Left Int
ec -> Int -> Shell m (a, w)
forall a. Int -> Shell m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Int
ec
      Right a
v -> (a, w) -> Shell m (a, w)
forall a. a -> Shell m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
v, w
w)
  pass :: forall a. Shell m (a, w -> w) -> Shell m a
pass Shell m (a, w -> w)
a = do
    (Text
out, Text
err, Either Int a
e) <- m (Text, Text, Either Int a) -> Shell m (Text, Text, Either Int a)
forall (m :: * -> *) a. Monad m => m a -> Shell m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Text, Text, Either Int a)
 -> Shell m (Text, Text, Either Int a))
-> m (Text, Text, Either Int a)
-> Shell m (Text, Text, Either Int a)
forall a b. (a -> b) -> a -> b
$ m ((Text, Text, Either Int a), w -> w)
-> m (Text, Text, Either Int a)
forall a. m (a, w -> w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m ((Text, Text, Either Int a), w -> w)
 -> m (Text, Text, Either Int a))
-> m ((Text, Text, Either Int a), w -> w)
-> m (Text, Text, Either Int a)
forall a b. (a -> b) -> a -> b
$
      Shell m (a, w -> w) -> m (Text, Text, Either Int (a, w -> w))
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (Text, Text, Either Int a)
runShell Shell m (a, w -> w)
a m (Text, Text, Either Int (a, w -> w))
-> ((Text, Text, Either Int (a, w -> w))
    -> m ((Text, Text, Either Int a), w -> w))
-> m ((Text, Text, Either Int a), w -> w)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Text
out, Text
err, Left Int
ec) -> ((Text, Text, Either Int a), w -> w)
-> m ((Text, Text, Either Int a), w -> w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text
out, Text
err, Int -> Either Int a
forall a b. a -> Either a b
Left Int
ec), w -> w
forall a. a -> a
id)
        (Text
out, Text
err, Right (a
x, w -> w
f)) -> ((Text, Text, Either Int a), w -> w)
-> m ((Text, Text, Either Int a), w -> w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text
out, Text
err, a -> Either Int a
forall a b. b -> Either a b
Right a
x), w -> w
f)
    (Text, Text) -> Shell m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
out, Text
err)
    case Either Int a
e of
      Left Int
ec -> Int -> Shell m a
forall a. Int -> Shell m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Int
ec
      Right a
v -> a -> Shell m a
forall a. a -> Shell m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Run a shell action, producing stdout, stderr, and a result.
runShell :: Monad m => Shell m a -> m (Text, Text, Either Int a)
runShell :: forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (Text, Text, Either Int a)
runShell (Shell ExceptT Int (WriterT (Text, Text) m) a
s) = do
  (Either Int a
e, (Text
out, Text
err)) <- WriterT (Text, Text) m (Either Int a)
-> m (Either Int a, (Text, Text))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Text, Text) m (Either Int a)
 -> m (Either Int a, (Text, Text)))
-> WriterT (Text, Text) m (Either Int a)
-> m (Either Int a, (Text, Text))
forall a b. (a -> b) -> a -> b
$ ExceptT Int (WriterT (Text, Text) m) a
-> WriterT (Text, Text) m (Either Int a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Int (WriterT (Text, Text) m) a
s
  (Text, Text, Either Int a) -> m (Text, Text, Either Int a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
out, Text
err, Either Int a
e)

-- | Run a shell action, producing an exit code, stdout, and stderr
execShell :: Monad m => Shell m a -> m (ExitCode, Text, Text)
execShell :: forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (ExitCode, Text, Text)
execShell Shell m a
s = do
  (Text
out, Text
err, Either Int a
r) <- Shell m a -> m (Text, Text, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (Text, Text, Either Int a)
runShell Shell m a
s
  case Either Int a
r of
    Left Int
ec -> (ExitCode, Text, Text) -> m (ExitCode, Text, Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
ec, Text
out, Text
err)
    Right a
_ -> (ExitCode, Text, Text) -> m (ExitCode, Text, Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, Text
out, Text
err)

-- | Hoist a shell action into another monad
hoistShell :: (forall x. m x -> n x) -> Shell m a -> Shell n a
hoistShell :: forall (m :: * -> *) (n :: * -> *) a.
(forall x. m x -> n x) -> Shell m a -> Shell n a
hoistShell forall x. m x -> n x
f Shell m a
s = ExceptT Int (WriterT (Text, Text) n) a -> Shell n a
forall (m :: * -> *) a.
ExceptT Int (WriterT (Text, Text) m) a -> Shell m a
Shell (ExceptT Int (WriterT (Text, Text) n) a -> Shell n a)
-> ExceptT Int (WriterT (Text, Text) n) a -> Shell n a
forall a b. (a -> b) -> a -> b
$ (WriterT (Text, Text) m (Either Int a)
 -> WriterT (Text, Text) n (Either Int a))
-> ExceptT Int (WriterT (Text, Text) m) a
-> ExceptT Int (WriterT (Text, Text) n) a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((m (Either Int a, (Text, Text)) -> n (Either Int a, (Text, Text)))
-> WriterT (Text, Text) m (Either Int a)
-> WriterT (Text, Text) n (Either Int a)
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT m (Either Int a, (Text, Text)) -> n (Either Int a, (Text, Text))
forall x. m x -> n x
f) (ExceptT Int (WriterT (Text, Text) m) a
 -> ExceptT Int (WriterT (Text, Text) n) a)
-> ExceptT Int (WriterT (Text, Text) m) a
-> ExceptT Int (WriterT (Text, Text) n) a
forall a b. (a -> b) -> a -> b
$ Shell m a -> ExceptT Int (WriterT (Text, Text) m) a
forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (Text, Text) m) a
unShell Shell m a
s

-- | Run a 'CreateProcess' in a 'Shell'
shellCreateProcess :: MonadIO m => CreateProcess -> Shell m ()
shellCreateProcess :: forall (m :: * -> *). MonadIO m => CreateProcess -> Shell m ()
shellCreateProcess CreateProcess
p = Map String String -> CreateProcess -> Text -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Text -> Shell m ()
shellCreateProcessWithEnv Map String String
forall a. Monoid a => a
mempty CreateProcess
p Text
""

-- | Run a 'CreateProcess' in a 'Shell'
run :: MonadIO m => CreateProcess -> Shell m ()
run :: forall (m :: * -> *). MonadIO m => CreateProcess -> Shell m ()
run = CreateProcess -> Shell m ()
forall (m :: * -> *). MonadIO m => CreateProcess -> Shell m ()
shellCreateProcess

-- | Represents a process that is running and whose incremental output can
-- be retrieved before it completes. The '_streamingProcess_waitForProcess'
-- finalizer can be called to get the exit status of the process and to get
-- the final output.
data StreamingProcess m = StreamingProcess
  { forall (m :: * -> *). StreamingProcess m -> Shell m ExitCode
_streamingProcess_waitForProcess :: !(Shell m ExitCode)
  , forall (m :: * -> *). StreamingProcess m -> Shell m ()
_streamingProcess_terminateProcess :: !(Shell m ())
  , forall (m :: * -> *).
StreamingProcess m -> Shell m (Maybe ExitCode)
_streamingProcess_getProcessExitCode :: !(Shell m (Maybe ExitCode))
  } deriving (forall x. StreamingProcess m -> Rep (StreamingProcess m) x)
-> (forall x. Rep (StreamingProcess m) x -> StreamingProcess m)
-> Generic (StreamingProcess m)
forall x. Rep (StreamingProcess m) x -> StreamingProcess m
forall x. StreamingProcess m -> Rep (StreamingProcess m) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x.
Rep (StreamingProcess m) x -> StreamingProcess m
forall (m :: * -> *) x.
StreamingProcess m -> Rep (StreamingProcess m) x
$cfrom :: forall (m :: * -> *) x.
StreamingProcess m -> Rep (StreamingProcess m) x
from :: forall x. StreamingProcess m -> Rep (StreamingProcess m) x
$cto :: forall (m :: * -> *) x.
Rep (StreamingProcess m) x -> StreamingProcess m
to :: forall x. Rep (StreamingProcess m) x -> StreamingProcess m
Generic

-- | A process whose output can be inspected while it is still running.
shellStreamableProcess
  :: (MonadIO m, MonadMask m)
  => (ByteString -> IO ()) -- ^ Handle stdout
  -> (ByteString -> IO ()) -- ^ Handle stderr
  -> CreateProcess
  -> Shell m (StreamingProcess m)
shellStreamableProcess :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
(ByteString -> IO ())
-> (ByteString -> IO ())
-> CreateProcess
-> Shell m (StreamingProcess m)
shellStreamableProcess ByteString -> IO ()
handleStdout ByteString -> IO ()
handleStderr CreateProcess
p = do
  (Maybe Handle
_, Maybe Handle
mout, Maybe Handle
merr, ProcessHandle
ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> Shell
     m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> Shell
      m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> Shell
     m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
p
    { std_out = CreatePipe
    , std_err = CreatePipe
    }
  case (Maybe Handle
mout, Maybe Handle
merr) of
    (Just Handle
hout, Just Handle
herr) -> do
    -- TODO: This code is basically the same as that in Reflex.Process.createProcess, except for the action to take when new output is received
      let
        handleReader :: Handle -> (ByteString -> IO ()) -> IO ()
handleReader Handle
h (ByteString -> IO ()
handler :: ByteString -> IO ()) = do
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
          (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
go -> do
            Bool
open <- Handle -> IO Bool
hIsOpen Handle
h
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
open (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              Bool
readable <- Handle -> IO Bool
hIsReadable Handle
h
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
readable (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString
out <- Handle -> Int -> IO ByteString
BS.hGetSome Handle
h (Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
15 :: Int))
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
out) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  ByteString -> IO ()
handler ByteString
out
                  IO ()
go

        appendIORef :: IORef Builder -> ByteString -> IO ()
appendIORef IORef Builder
r ByteString
out = IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Builder
r (\Builder
v -> (Builder
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString ByteString
out, ()))

      IORef Builder
stdoutAcc <- IO (IORef Builder) -> Shell m (IORef Builder)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Builder) -> Shell m (IORef Builder))
-> IO (IORef Builder) -> Shell m (IORef Builder)
forall a b. (a -> b) -> a -> b
$ Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
      IORef Builder
stderrAcc <- IO (IORef Builder) -> Shell m (IORef Builder)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Builder) -> Shell m (IORef Builder))
-> IO (IORef Builder) -> Shell m (IORef Builder)
forall a b. (a -> b) -> a -> b
$ Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
      Async ()
outThread <- IO (Async ()) -> Shell m (Async ())
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> Shell m (Async ()))
-> IO (Async ()) -> Shell m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Handle -> (ByteString -> IO ()) -> IO ()
handleReader Handle
hout ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
out ->
        IORef Builder -> ByteString -> IO ()
appendIORef IORef Builder
stdoutAcc ByteString
out IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> IO ()
handleStdout ByteString
out
      Async ()
errThread <- IO (Async ()) -> Shell m (Async ())
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> Shell m (Async ()))
-> IO (Async ()) -> Shell m (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Handle -> (ByteString -> IO ()) -> IO ()
handleReader Handle
herr ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
out ->
        IORef Builder -> ByteString -> IO ()
appendIORef IORef Builder
stderrAcc ByteString
out IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> IO ()
handleStderr ByteString
out
      let finalize :: IO a -> m a
finalize IO a
f =
            IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
f
              m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async ()
outThread)
              m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async ()
errThread)
              m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` do
                ByteString
stdoutFinal <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
builderToStrictBS (Builder -> ByteString) -> IO Builder -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
stdoutAcc
                ByteString
stderrFinal <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
builderToStrictBS (Builder -> ByteString) -> IO Builder -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Builder -> IO Builder
forall a. IORef a -> IO a
readIORef IORef Builder
stderrAcc
                (Text, Text) -> m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (ByteString -> Text
T.decodeUtf8 ByteString
stdoutFinal, ByteString -> Text
T.decodeUtf8 ByteString
stderrFinal)
      StreamingProcess m -> Shell m (StreamingProcess m)
forall a. a -> Shell m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamingProcess m -> Shell m (StreamingProcess m))
-> StreamingProcess m -> Shell m (StreamingProcess m)
forall a b. (a -> b) -> a -> b
$ StreamingProcess
        { _streamingProcess_waitForProcess :: Shell m ExitCode
_streamingProcess_waitForProcess = IO ExitCode -> Shell m ExitCode
forall {m :: * -> *} {a}.
(MonadMask m, MonadIO m, MonadShell m) =>
IO a -> m a
finalize (IO ExitCode -> Shell m ExitCode)
-> IO ExitCode -> Shell m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
        , _streamingProcess_terminateProcess :: Shell m ()
_streamingProcess_terminateProcess = IO () -> Shell m ()
forall {m :: * -> *} {a}.
(MonadMask m, MonadIO m, MonadShell m) =>
IO a -> m a
finalize (IO () -> Shell m ()) -> IO () -> Shell m ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph
        , _streamingProcess_getProcessExitCode :: Shell m (Maybe ExitCode)
_streamingProcess_getProcessExitCode = IO (Maybe ExitCode) -> Shell m (Maybe ExitCode)
forall {m :: * -> *} {a}.
(MonadMask m, MonadIO m, MonadShell m) =>
IO a -> m a
finalize (IO (Maybe ExitCode) -> Shell m (Maybe ExitCode))
-> IO (Maybe ExitCode) -> Shell m (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
ph
        }
    (Maybe Handle, Maybe Handle)
_ -> String -> Shell m (StreamingProcess m)
forall a. HasCallStack => String -> a
error String
"shellStreamingProcess: Created pipes were not returned"
    where
      builderToStrictBS :: Builder -> ByteString
builderToStrictBS = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BS.toLazyByteString

-- | Like 'shellStreamableProcess' but instead of taking handlers for each
-- stream, it automatically buffers the output of each stream and returns
-- 'IO' actions to read and clear the buffer.
shellStreamableProcessBuffered
  :: (MonadIO m, MonadMask m)
  => CreateProcess
  -> Shell m (StreamingProcess m, IO ByteString, IO ByteString) -- ^ ('StreamingProcess', stdout, stderr)
shellStreamableProcessBuffered :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
CreateProcess
-> Shell m (StreamingProcess m, IO ByteString, IO ByteString)
shellStreamableProcessBuffered CreateProcess
p = do
  IORef Builder
stdoutBuf <- IO (IORef Builder) -> Shell m (IORef Builder)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Builder) -> Shell m (IORef Builder))
-> IO (IORef Builder) -> Shell m (IORef Builder)
forall a b. (a -> b) -> a -> b
$ Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
  IORef Builder
stderrBuf <- IO (IORef Builder) -> Shell m (IORef Builder)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Builder) -> Shell m (IORef Builder))
-> IO (IORef Builder) -> Shell m (IORef Builder)
forall a b. (a -> b) -> a -> b
$ Builder -> IO (IORef Builder)
forall a. a -> IO (IORef a)
newIORef Builder
forall a. Monoid a => a
mempty
  StreamingProcess m
sp <- (ByteString -> IO ())
-> (ByteString -> IO ())
-> CreateProcess
-> Shell m (StreamingProcess m)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
(ByteString -> IO ())
-> (ByteString -> IO ())
-> CreateProcess
-> Shell m (StreamingProcess m)
shellStreamableProcess (IORef Builder -> ByteString -> IO ()
updateBuf IORef Builder
stdoutBuf) (IORef Builder -> ByteString -> IO ()
updateBuf IORef Builder
stderrBuf) CreateProcess
p
  (StreamingProcess m, IO ByteString, IO ByteString)
-> Shell m (StreamingProcess m, IO ByteString, IO ByteString)
forall a. a -> Shell m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StreamingProcess m
sp, IORef Builder -> IO ByteString
eatBuf IORef Builder
stdoutBuf, IORef Builder -> IO ByteString
eatBuf IORef Builder
stderrBuf)
  where
    updateBuf :: IORef Builder -> ByteString -> IO ()
updateBuf IORef Builder
buf ByteString
new = IORef Builder -> (Builder -> (Builder, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Builder
buf ((Builder -> (Builder, ())) -> IO ())
-> (Builder -> (Builder, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Builder
old -> (Builder
old Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BS.byteString ByteString
new, ())
    eatBuf :: IORef Builder -> IO ByteString
eatBuf IORef Builder
buf = IORef Builder
-> (Builder -> (Builder, ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Builder
buf ((Builder -> (Builder, ByteString)) -> IO ByteString)
-> (Builder -> (Builder, ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Builder
out -> (Builder
forall a. Monoid a => a
mempty, ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BS.toLazyByteString Builder
out)


-- | Run a shell process using the given runner function
shellCreateProcessWith
  :: MonadIO m
  => (CreateProcess -> IO (ExitCode, Text, Text))
  -> CreateProcess
  -> Shell m ()
shellCreateProcessWith :: forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, Text, Text)
f CreateProcess
p = do
  (ExitCode
ex, Text
out, Text
err) <- IO (ExitCode, Text, Text) -> Shell m (ExitCode, Text, Text)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, Text, Text) -> Shell m (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text) -> Shell m (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> IO (ExitCode, Text, Text)
f CreateProcess
p
  (Text, Text) -> Shell m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
out, Text
err)
  case ExitCode
ex of
    ExitFailure Int
c -> do
      IO () -> Shell m ()
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Shell m ()) -> IO () -> Shell m ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Command failed: "
        , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String
showCommand CreateProcess
p
        , Text
"\n"
        , Text
err
        ]
      Int -> Shell m ()
forall a. Int -> Shell m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Int
c
    ExitCode
ExitSuccess -> () -> Shell m ()
forall a. a -> Shell m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Run a shell process with the given environment variables added to the existing environment
shellCreateProcessWithEnv
  :: MonadIO m
  => Map String String
  -> CreateProcess
  -> Text -- ^ stdin
  -> Shell m ()
shellCreateProcessWithEnv :: forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Text -> Shell m ()
shellCreateProcessWithEnv Map String String
envOverrides CreateProcess
cmd' Text
stdin = (CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, Text, Text)
f CreateProcess
cmd'
  where
    f :: CreateProcess -> IO (ExitCode, Text, Text)
f CreateProcess
cmd = do
      Maybe [(String, String)]
envWithOverrides <- IO (Maybe [(String, String)]) -> IO (Maybe [(String, String)])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [(String, String)]) -> IO (Maybe [(String, String)]))
-> IO (Maybe [(String, String)]) -> IO (Maybe [(String, String)])
forall a b. (a -> b) -> a -> b
$ if Map String String -> Bool
forall k a. Map k a -> Bool
Map.null Map String String
envOverrides
        then Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(String, String)] -> IO (Maybe [(String, String)]))
-> Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall a b. (a -> b) -> a -> b
$ CreateProcess -> Maybe [(String, String)]
env CreateProcess
cmd
        else [(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just ([(String, String)] -> Maybe [(String, String)])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> Maybe [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map String String -> [(String, String)])
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String String -> Map String String -> Map String String
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map String String
envOverrides (Map String String -> Map String String)
-> ([(String, String)] -> Map String String)
-> [(String, String)]
-> Map String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, String)] -> Maybe [(String, String)])
-> IO [(String, String)] -> IO (Maybe [(String, String)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
      CreateProcess -> Text -> IO (ExitCode, Text, Text)
readAndDecodeCreateProcess (CreateProcess
cmd { env = envWithOverrides }) Text
stdin

-- | Execute a shell process with environment variables
runCreateProcessWithEnv :: Map String String -> CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcessWithEnv :: Map String String -> CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcessWithEnv Map String String
menv CreateProcess
p = Shell IO () -> IO (ExitCode, Text, Text)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (ExitCode, Text, Text)
execShell (Shell IO () -> IO (ExitCode, Text, Text))
-> Shell IO () -> IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ Map String String -> CreateProcess -> Text -> Shell IO ()
forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Text -> Shell m ()
shellCreateProcessWithEnv Map String String
menv CreateProcess
p Text
""

-- | Execute a shell process
runCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcess = Map String String -> CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcessWithEnv Map String String
forall a. Monoid a => a
mempty

-- | Run a shell process with stdout directed to the provided handle
shellCreateProcessWithStdOut
  :: MonadIO m
  => Handle
  -> CreateProcess
  -> Shell m ()
shellCreateProcessWithStdOut :: forall (m :: * -> *).
MonadIO m =>
Handle -> CreateProcess -> Shell m ()
shellCreateProcessWithStdOut Handle
hndl CreateProcess
cp = do
  let cp' :: CreateProcess
cp' = CreateProcess
cp { std_out = UseHandle hndl, std_err = CreatePipe }
  (CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, Text, Text)
forall {b}. IsString b => CreateProcess -> IO (ExitCode, b, Text)
f CreateProcess
cp'
  where
    f :: CreateProcess -> IO (ExitCode, b, Text)
f CreateProcess
cmd = CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, b, Text))
-> IO (ExitCode, b, Text)
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
cmd ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (ExitCode, b, Text))
 -> IO (ExitCode, b, Text))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, b, Text))
-> IO (ExitCode, b, Text)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
merr ProcessHandle
p -> case Maybe Handle
merr of
      Just Handle
errh -> do
        Text
err <- Handle -> IO Text
waitReadHandle Handle
errh
        ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
        Handle -> IO ()
hClose Handle
hndl
        (ExitCode, b, Text) -> IO (ExitCode, b, Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ec, b
"", Text
err)
      Maybe Handle
_ -> String -> IO (ExitCode, b, Text)
forall a. HasCallStack => String -> a
error String
"shellCreateProcessWithStdOut: Failed to get std_err handle"
    waitReadHandle :: Handle -> IO Text
    waitReadHandle :: Handle -> IO Text
waitReadHandle Handle
h = do
      Text
c <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 (IO ByteString -> IO Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
BS.hGetContents Handle
h
      IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ()
forall a. NFData a => a -> ()
rnf Text
c) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
wait -> IO ()
wait IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
h
      Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
c

-- | Run a shell command with access to a temporary directory
inTempDirectory
  :: MonadIO m
  => String
  -> (FilePath -> Shell IO a)
  -> Shell m a
inTempDirectory :: forall (m :: * -> *) a.
MonadIO m =>
String -> (String -> Shell IO a) -> Shell m a
inTempDirectory String
label String -> Shell IO a
f = do
  (Text
out, Text
err, Either Int a
r) <- IO (Text, Text, Either Int a) -> Shell m (Text, Text, Either Int a)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Text, Either Int a)
 -> Shell m (Text, Text, Either Int a))
-> IO (Text, Text, Either Int a)
-> Shell m (Text, Text, Either Int a)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> IO (Text, Text, Either Int a))
-> IO (Text, Text, Either Int a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
label ((String -> IO (Text, Text, Either Int a))
 -> IO (Text, Text, Either Int a))
-> (String -> IO (Text, Text, Either Int a))
-> IO (Text, Text, Either Int a)
forall a b. (a -> b) -> a -> b
$ \String
fp -> Shell IO a -> IO (Text, Text, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (Text, Text, Either Int a)
runShell (Shell IO a -> IO (Text, Text, Either Int a))
-> Shell IO a -> IO (Text, Text, Either Int a)
forall a b. (a -> b) -> a -> b
$ String -> Shell IO a
f String
fp
  (Text, Text) -> Shell m ()
forall (m :: * -> *). MonadShell m => (Text, Text) -> m ()
tellOutput (Text
out, Text
err)
  case Either Int a
r of
    Left Int
ec -> Int -> Shell m a
forall a. Int -> Shell m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Int
ec
    Right a
x -> a -> Shell m a
forall a. a -> Shell m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Print a shell command
logCommand :: CreateProcess -> IO ()
logCommand :: CreateProcess -> IO ()
logCommand = String -> IO ()
putStrLn (String -> IO ())
-> (CreateProcess -> String) -> CreateProcess -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CreateProcess -> String
showCommand

-- | Convert a shell command to a string
showCommand :: CreateProcess -> String
showCommand :: CreateProcess -> String
showCommand CreateProcess
p = case CreateProcess -> CmdSpec
cmdspec CreateProcess
p of
  ShellCommand String
str -> String
str
  RawCommand String
exe [String]
args -> [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
" " ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
exe String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args