{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Coquina
(
MonadShell(..)
, tellStdout
, tellStderr
, readStdout
, readStderr
, Shell(..)
, runShell
, execShell
, hoistShell
, run
, shellCreateProcess
, shellCreateProcessWith
, shellCreateProcessWithEnv
, runCreateProcess
, runCreateProcessWithEnv
, shellCreateProcessWithStdOut
, inTempDirectory
, StreamingProcess(..)
, shellStreamableProcess
, shellStreamableProcessBuffered
, 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
class Monad m => MonadShell m where
tellOutput :: (Text, Text) -> m ()
readOutput :: m a -> m ((Text, Text), a)
tellStdout :: MonadShell m => Text -> m ()
tellStdout :: forall (m :: * -> *). MonadShell m => LogSource -> m ()
tellStdout LogSource
s = (LogSource, LogSource) -> m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
s, LogSource
forall a. Monoid a => a
mempty)
tellStderr :: MonadShell m => Text -> m ()
tellStderr :: forall (m :: * -> *). MonadShell m => LogSource -> m ()
tellStderr LogSource
s = (LogSource, LogSource) -> m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
forall a. Monoid a => a
mempty, LogSource
s)
readStdout :: MonadShell m => m a -> m (Text, a)
readStdout :: forall (m :: * -> *) a. MonadShell m => m a -> m (LogSource, a)
readStdout m a
f = do
((LogSource
out, LogSource
_), a
a) <- m a -> m ((LogSource, LogSource), a)
forall a. m a -> m ((LogSource, LogSource), a)
forall (m :: * -> *) a.
MonadShell m =>
m a -> m ((LogSource, LogSource), a)
readOutput m a
f
(LogSource, a) -> m (LogSource, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogSource
out, a
a)
readStderr :: MonadShell m => m a -> m (Text, a)
readStderr :: forall (m :: * -> *) a. MonadShell m => m a -> m (LogSource, a)
readStderr m a
f = do
((LogSource
_, LogSource
err), a
a) <- m a -> m ((LogSource, LogSource), a)
forall a. m a -> m ((LogSource, LogSource), a)
forall (m :: * -> *) a.
MonadShell m =>
m a -> m ((LogSource, LogSource), a)
readOutput m a
f
(LogSource, a) -> m (LogSource, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogSource
err, a
a)
newtype Shell m a = Shell { forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (LogSource, LogSource) 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 (LogSource, LogSource) m) a -> Shell m a
forall (m :: * -> *) a.
ExceptT Int (WriterT (LogSource, LogSource) m) a -> Shell m a
Shell (ExceptT Int (WriterT (LogSource, LogSource) m) a -> Shell m a)
-> (m a -> ExceptT Int (WriterT (LogSource, LogSource) m) a)
-> m a
-> Shell m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (LogSource, LogSource) m a
-> ExceptT Int (WriterT (LogSource, LogSource) 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 (LogSource, LogSource) m a
-> ExceptT Int (WriterT (LogSource, LogSource) m) a)
-> (m a -> WriterT (LogSource, LogSource) m a)
-> m a
-> ExceptT Int (WriterT (LogSource, LogSource) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT (LogSource, LogSource) m a
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT (LogSource, LogSource) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance Monad m => MonadShell (Shell m) where
tellOutput :: (LogSource, LogSource) -> Shell m ()
tellOutput = ExceptT Int (WriterT (LogSource, LogSource) m) () -> Shell m ()
forall (m :: * -> *) a.
ExceptT Int (WriterT (LogSource, LogSource) m) a -> Shell m a
Shell (ExceptT Int (WriterT (LogSource, LogSource) m) () -> Shell m ())
-> ((LogSource, LogSource)
-> ExceptT Int (WriterT (LogSource, LogSource) m) ())
-> (LogSource, LogSource)
-> Shell m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogSource, LogSource)
-> ExceptT Int (WriterT (LogSource, LogSource) m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
readOutput :: forall a. Shell m a -> Shell m ((LogSource, LogSource), a)
readOutput Shell m a
f = ExceptT
Int (WriterT (LogSource, LogSource) m) ((LogSource, LogSource), a)
-> Shell m ((LogSource, LogSource), a)
forall (m :: * -> *) a.
ExceptT Int (WriterT (LogSource, LogSource) m) a -> Shell m a
Shell (ExceptT
Int (WriterT (LogSource, LogSource) m) ((LogSource, LogSource), a)
-> Shell m ((LogSource, LogSource), a))
-> ExceptT
Int (WriterT (LogSource, LogSource) m) ((LogSource, LogSource), a)
-> Shell m ((LogSource, LogSource), a)
forall a b. (a -> b) -> a -> b
$ do
(a
a, (LogSource, LogSource)
out) <- ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT
Int (WriterT (LogSource, LogSource) m) (a, (LogSource, LogSource))
forall a.
ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT
Int (WriterT (LogSource, LogSource) m) (a, (LogSource, LogSource))
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT
Int (WriterT (LogSource, LogSource) m) (a, (LogSource, LogSource)))
-> ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT
Int (WriterT (LogSource, LogSource) m) (a, (LogSource, LogSource))
forall a b. (a -> b) -> a -> b
$ Shell m a -> ExceptT Int (WriterT (LogSource, LogSource) m) a
forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (LogSource, LogSource) m) a
unShell Shell m a
f
((LogSource, LogSource), a)
-> ExceptT
Int (WriterT (LogSource, LogSource) m) ((LogSource, LogSource), a)
forall a. a -> ExceptT Int (WriterT (LogSource, LogSource) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogSource, LogSource)
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
listen :: forall a. Shell m a -> Shell m (a, w)
listen Shell m a
x = do
((LogSource
out, LogSource
err, Either Int a
r), w
w) <- m ((LogSource, LogSource, Either Int a), w)
-> Shell m ((LogSource, LogSource, 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 ((LogSource, LogSource, Either Int a), w)
-> Shell m ((LogSource, LogSource, Either Int a), w))
-> m ((LogSource, LogSource, Either Int a), w)
-> Shell m ((LogSource, LogSource, Either Int a), w)
forall a b. (a -> b) -> a -> b
$ m (LogSource, LogSource, Either Int a)
-> m ((LogSource, LogSource, 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 (LogSource, LogSource, Either Int a)
-> m ((LogSource, LogSource, Either Int a), w))
-> m (LogSource, LogSource, Either Int a)
-> m ((LogSource, LogSource, Either Int a), w)
forall a b. (a -> b) -> a -> b
$ Shell m a -> m (LogSource, LogSource, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (LogSource, LogSource, Either Int a)
runShell Shell m a
x
(LogSource, LogSource) -> Shell m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
out, LogSource
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
(LogSource
out, LogSource
err, Either Int a
e) <- m (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, 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 (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, Either Int a))
-> m (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, Either Int a)
forall a b. (a -> b) -> a -> b
$ m ((LogSource, LogSource, Either Int a), w -> w)
-> m (LogSource, LogSource, 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 ((LogSource, LogSource, Either Int a), w -> w)
-> m (LogSource, LogSource, Either Int a))
-> m ((LogSource, LogSource, Either Int a), w -> w)
-> m (LogSource, LogSource, Either Int a)
forall a b. (a -> b) -> a -> b
$
Shell m (a, w -> w)
-> m (LogSource, LogSource, Either Int (a, w -> w))
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (LogSource, LogSource, Either Int a)
runShell Shell m (a, w -> w)
a m (LogSource, LogSource, Either Int (a, w -> w))
-> ((LogSource, LogSource, Either Int (a, w -> w))
-> m ((LogSource, LogSource, Either Int a), w -> w))
-> m ((LogSource, LogSource, 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
(LogSource
out, LogSource
err, Left Int
ec) -> ((LogSource, LogSource, Either Int a), w -> w)
-> m ((LogSource, LogSource, Either Int a), w -> w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogSource
out, LogSource
err, Int -> Either Int a
forall a b. a -> Either a b
Left Int
ec), w -> w
forall a. a -> a
id)
(LogSource
out, LogSource
err, Right (a
x, w -> w
f)) -> ((LogSource, LogSource, Either Int a), w -> w)
-> m ((LogSource, LogSource, Either Int a), w -> w)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogSource
out, LogSource
err, a -> Either Int a
forall a b. b -> Either a b
Right a
x), w -> w
f)
(LogSource, LogSource) -> Shell m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
out, LogSource
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
runShell :: Monad m => Shell m a -> m (Text, Text, Either Int a)
runShell :: forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (LogSource, LogSource, Either Int a)
runShell (Shell ExceptT Int (WriterT (LogSource, LogSource) m) a
s) = do
(Either Int a
e, (LogSource
out, LogSource
err)) <- WriterT (LogSource, LogSource) m (Either Int a)
-> m (Either Int a, (LogSource, LogSource))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (LogSource, LogSource) m (Either Int a)
-> m (Either Int a, (LogSource, LogSource)))
-> WriterT (LogSource, LogSource) m (Either Int a)
-> m (Either Int a, (LogSource, LogSource))
forall a b. (a -> b) -> a -> b
$ ExceptT Int (WriterT (LogSource, LogSource) m) a
-> WriterT (LogSource, LogSource) m (Either Int a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Int (WriterT (LogSource, LogSource) m) a
s
(LogSource, LogSource, Either Int a)
-> m (LogSource, LogSource, Either Int a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogSource
out, LogSource
err, Either Int a
e)
execShell :: Monad m => Shell m a -> m (ExitCode, Text, Text)
execShell :: forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (ExitCode, LogSource, LogSource)
execShell Shell m a
s = do
(LogSource
out, LogSource
err, Either Int a
r) <- Shell m a -> m (LogSource, LogSource, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (LogSource, LogSource, Either Int a)
runShell Shell m a
s
case Either Int a
r of
Left Int
ec -> (ExitCode, LogSource, LogSource)
-> m (ExitCode, LogSource, LogSource)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
ec, LogSource
out, LogSource
err)
Right a
_ -> (ExitCode, LogSource, LogSource)
-> m (ExitCode, LogSource, LogSource)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, LogSource
out, LogSource
err)
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 (LogSource, LogSource) n) a -> Shell n a
forall (m :: * -> *) a.
ExceptT Int (WriterT (LogSource, LogSource) m) a -> Shell m a
Shell (ExceptT Int (WriterT (LogSource, LogSource) n) a -> Shell n a)
-> ExceptT Int (WriterT (LogSource, LogSource) n) a -> Shell n a
forall a b. (a -> b) -> a -> b
$ (WriterT (LogSource, LogSource) m (Either Int a)
-> WriterT (LogSource, LogSource) n (Either Int a))
-> ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT Int (WriterT (LogSource, LogSource) 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, (LogSource, LogSource))
-> n (Either Int a, (LogSource, LogSource)))
-> WriterT (LogSource, LogSource) m (Either Int a)
-> WriterT (LogSource, LogSource) 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, (LogSource, LogSource))
-> n (Either Int a, (LogSource, LogSource))
forall x. m x -> n x
f) (ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT Int (WriterT (LogSource, LogSource) n) a)
-> ExceptT Int (WriterT (LogSource, LogSource) m) a
-> ExceptT Int (WriterT (LogSource, LogSource) n) a
forall a b. (a -> b) -> a -> b
$ Shell m a -> ExceptT Int (WriterT (LogSource, LogSource) m) a
forall (m :: * -> *) a.
Shell m a -> ExceptT Int (WriterT (LogSource, LogSource) m) a
unShell Shell m a
s
shellCreateProcess :: MonadIO m => CreateProcess -> Shell m ()
shellCreateProcess :: forall (m :: * -> *). MonadIO m => CreateProcess -> Shell m ()
shellCreateProcess = Map String String -> CreateProcess -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Shell m ()
shellCreateProcessWithEnv Map String String
forall a. Monoid a => a
mempty
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
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
shellStreamableProcess
:: (MonadIO m, MonadMask m)
=> (ByteString -> IO ())
-> (ByteString -> IO ())
-> 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
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
(LogSource, LogSource) -> m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (ByteString -> LogSource
T.decodeUtf8 ByteString
stdoutFinal, ByteString -> LogSource
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
shellStreamableProcessBuffered
:: (MonadIO m, MonadMask m)
=> CreateProcess
-> Shell m (StreamingProcess m, IO ByteString, IO ByteString)
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)
shellCreateProcessWith
:: MonadIO m
=> (CreateProcess -> IO (ExitCode, Text, Text))
-> CreateProcess
-> Shell m ()
shellCreateProcessWith :: forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, LogSource, LogSource))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, LogSource, LogSource)
f CreateProcess
p = do
(ExitCode
ex, LogSource
out, LogSource
err) <- IO (ExitCode, LogSource, LogSource)
-> Shell m (ExitCode, LogSource, LogSource)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, LogSource, LogSource)
-> Shell m (ExitCode, LogSource, LogSource))
-> IO (ExitCode, LogSource, LogSource)
-> Shell m (ExitCode, LogSource, LogSource)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> IO (ExitCode, LogSource, LogSource)
f CreateProcess
p
(LogSource, LogSource) -> Shell m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
out, LogSource
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
$ LogSource -> IO ()
T.putStrLn (LogSource -> IO ()) -> LogSource -> IO ()
forall a b. (a -> b) -> a -> b
$ [LogSource] -> LogSource
forall a. Monoid a => [a] -> a
mconcat
[ LogSource
"Command failed: "
, String -> LogSource
T.pack (String -> LogSource) -> String -> LogSource
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String
showCommand CreateProcess
p
, LogSource
"\n"
, LogSource
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 ()
shellCreateProcessWithEnv
:: MonadIO m
=> Map String String
-> CreateProcess
-> Shell m ()
shellCreateProcessWithEnv :: forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Shell m ()
shellCreateProcessWithEnv Map String String
envOverrides = (CreateProcess -> IO (ExitCode, LogSource, LogSource))
-> CreateProcess -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, LogSource, LogSource))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, LogSource, LogSource)
f
where
f :: CreateProcess -> IO (ExitCode, LogSource, LogSource)
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 -> IO (ExitCode, LogSource, LogSource)
readAndDecodeCreateProcess (CreateProcess -> IO (ExitCode, LogSource, LogSource))
-> CreateProcess -> IO (ExitCode, LogSource, LogSource)
forall a b. (a -> b) -> a -> b
$ CreateProcess
cmd { env = envWithOverrides }
runCreateProcessWithEnv :: Map String String -> CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcessWithEnv :: Map String String
-> CreateProcess -> IO (ExitCode, LogSource, LogSource)
runCreateProcessWithEnv Map String String
menv CreateProcess
p = Shell IO () -> IO (ExitCode, LogSource, LogSource)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (ExitCode, LogSource, LogSource)
execShell (Shell IO () -> IO (ExitCode, LogSource, LogSource))
-> Shell IO () -> IO (ExitCode, LogSource, LogSource)
forall a b. (a -> b) -> a -> b
$ Map String String -> CreateProcess -> Shell IO ()
forall (m :: * -> *).
MonadIO m =>
Map String String -> CreateProcess -> Shell m ()
shellCreateProcessWithEnv Map String String
menv CreateProcess
p
runCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)
runCreateProcess :: CreateProcess -> IO (ExitCode, LogSource, LogSource)
runCreateProcess = Map String String
-> CreateProcess -> IO (ExitCode, LogSource, LogSource)
runCreateProcessWithEnv Map String String
forall a. Monoid a => a
mempty
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, LogSource, LogSource))
-> CreateProcess -> Shell m ()
forall (m :: * -> *).
MonadIO m =>
(CreateProcess -> IO (ExitCode, LogSource, LogSource))
-> CreateProcess -> Shell m ()
shellCreateProcessWith CreateProcess -> IO (ExitCode, LogSource, LogSource)
forall {b}.
IsString b =>
CreateProcess -> IO (ExitCode, b, LogSource)
f CreateProcess
cp'
where
f :: CreateProcess -> IO (ExitCode, b, LogSource)
f CreateProcess
cmd = CreateProcess
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ExitCode, b, LogSource))
-> IO (ExitCode, b, LogSource)
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, LogSource))
-> IO (ExitCode, b, LogSource))
-> (Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> ProcessHandle
-> IO (ExitCode, b, LogSource))
-> IO (ExitCode, b, LogSource)
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
LogSource
err <- Handle -> IO LogSource
waitReadHandle Handle
errh
ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
Handle -> IO ()
hClose Handle
hndl
(ExitCode, b, LogSource) -> IO (ExitCode, b, LogSource)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ec, b
"", LogSource
err)
Maybe Handle
_ -> String -> IO (ExitCode, b, LogSource)
forall a. HasCallStack => String -> a
error String
"shellCreateProcessWithStdOut: Failed to get std_err handle"
waitReadHandle :: Handle -> IO Text
waitReadHandle :: Handle -> IO LogSource
waitReadHandle Handle
h = do
LogSource
c <- (ByteString -> LogSource) -> IO ByteString -> IO LogSource
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> LogSource
T.decodeUtf8 (IO ByteString -> IO LogSource) -> IO ByteString -> IO LogSource
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
$ LogSource -> ()
forall a. NFData a => a -> ()
rnf LogSource
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
LogSource -> IO LogSource
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LogSource
c
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
(LogSource
out, LogSource
err, Either Int a
r) <- IO (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, Either Int a)
forall a. IO a -> Shell m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, Either Int a))
-> IO (LogSource, LogSource, Either Int a)
-> Shell m (LogSource, LogSource, Either Int a)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> IO (LogSource, LogSource, Either Int a))
-> IO (LogSource, LogSource, Either Int a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
label ((String -> IO (LogSource, LogSource, Either Int a))
-> IO (LogSource, LogSource, Either Int a))
-> (String -> IO (LogSource, LogSource, Either Int a))
-> IO (LogSource, LogSource, Either Int a)
forall a b. (a -> b) -> a -> b
$ \String
fp -> Shell IO a -> IO (LogSource, LogSource, Either Int a)
forall (m :: * -> *) a.
Monad m =>
Shell m a -> m (LogSource, LogSource, Either Int a)
runShell (Shell IO a -> IO (LogSource, LogSource, Either Int a))
-> Shell IO a -> IO (LogSource, LogSource, Either Int a)
forall a b. (a -> b) -> a -> b
$ String -> Shell IO a
f String
fp
(LogSource, LogSource) -> Shell m ()
forall (m :: * -> *).
MonadShell m =>
(LogSource, LogSource) -> m ()
tellOutput (LogSource
out, LogSource
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
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
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