{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CApiFFI #-}
module GHCup.Prelude.Process.Posix where
import GHCup.Utils.Dirs
import GHCup.Prelude.File
import GHCup.Prelude.File.Posix
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent
import Control.Concurrent.Async
import qualified Control.Exception as E
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.IORef
import Data.Sequence ( Seq, (|>) )
import Data.List
import Data.Word8
import GHC.IO.Exception
import System.IO ( stderr )
import System.IO.Error hiding ( catchIOError )
import System.FilePath
import System.Posix.Directory
import System.Posix.IO
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types
import qualified Control.Exception as EX
import qualified Data.Sequence as Sq
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process as SPP
import qualified System.Console.Terminal.Size as TP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
executeOut :: MonadIO m
=> FilePath
-> [String]
-> Maybe FilePath
-> m CapturedProcess
executeOut :: forall (m :: * -> *).
MonadIO m =>
FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
executeOut FilePath
path [FilePath]
args Maybe FilePath
chdir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO CapturedProcess
captureOutStreams forall a b. (a -> b) -> a -> b
$ do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
path Bool
True [FilePath]
args forall a. Maybe a
Nothing
execLogged :: ( MonadReader env m
, HasSettings env
, HasLog env
, HasDirs env
, MonadIO m
, MonadThrow m)
=> FilePath
-> [String]
-> Maybe FilePath
-> FilePath
-> Maybe [(String, String)]
-> m (Either ProcessError ())
execLogged :: forall env (m :: * -> *).
(MonadReader env m, HasSettings env, HasLog env, HasDirs env,
MonadIO m, MonadThrow m) =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
execLogged FilePath
exe [FilePath]
args Maybe FilePath
chdir FilePath
lfile Maybe [(FilePath, FilePath)]
env = do
Settings {Bool
Integer
Maybe PlatformRequest
GPGSetting
Downloader
KeepDirs
MetaMode
URLSource
DownloadMirrors
$sel:mirrors:Settings :: Settings -> DownloadMirrors
$sel:platformOverride:Settings :: Settings -> Maybe PlatformRequest
$sel:noColor:Settings :: Settings -> Bool
$sel:gpgSetting:Settings :: Settings -> GPGSetting
$sel:noNetwork:Settings :: Settings -> Bool
$sel:urlSource:Settings :: Settings -> URLSource
$sel:verbose:Settings :: Settings -> Bool
$sel:downloader:Settings :: Settings -> Downloader
$sel:keepDirs:Settings :: Settings -> KeepDirs
$sel:noVerify:Settings :: Settings -> Bool
$sel:metaMode:Settings :: Settings -> MetaMode
$sel:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
mirrors :: DownloadMirrors
platformOverride :: Maybe PlatformRequest
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaMode :: MetaMode
metaCache :: Integer
cache :: Bool
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
Dirs {FilePath
GHCupPath
$sel:tmpDir:Dirs :: Dirs -> GHCupPath
$sel:recycleDir:Dirs :: Dirs -> GHCupPath
$sel:dbDir:Dirs :: Dirs -> GHCupPath
$sel:confDir:Dirs :: Dirs -> GHCupPath
$sel:logsDir:Dirs :: Dirs -> GHCupPath
$sel:cacheDir:Dirs :: Dirs -> GHCupPath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> GHCupPath
tmpDir :: GHCupPath
recycleDir :: GHCupPath
dbDir :: GHCupPath
confDir :: GHCupPath
logsDir :: GHCupPath
cacheDir :: GHCupPath
binDir :: FilePath
baseDir :: GHCupPath
..} <- forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ FilePath
"Running " forall a. Semigroup a => a -> a -> a
<> FilePath
exe forall a. Semigroup a => a -> a -> a
<> FilePath
" with arguments " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show [FilePath]
args
let logfile :: FilePath
logfile = GHCupPath -> FilePath
fromGHCupPath GHCupPath
logsDir FilePath -> FilePath -> FilePath
</> FilePath
lfile forall a. Semigroup a => a -> a -> a
<> FilePath
".log"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
logfile OpenMode
WriteOnly (forall a. a -> Maybe a
Just FileMode
newFilePerms) OpenFileFlags
defaultFileFlags{ append :: Bool
append = Bool
True })
Fd -> IO ()
closeFd
(Bool -> Bool -> Fd -> IO (Either ProcessError ())
action Bool
verbose Bool
noColor)
where
action :: Bool -> Bool -> Fd -> IO (Either ProcessError ())
action Bool
verbose Bool
no_color Fd
fd = do
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes forall a b. (a -> b) -> a -> b
$ \(Fd
stdoutRead, Fd
stdoutWrite) -> do
MVar Bool
pState <- forall a. IO (MVar a)
newEmptyMVar
MVar ()
done <- forall a. IO (MVar a)
newEmptyMVar
forall (f :: * -> *) a. Functor f => f a -> f ()
void
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => (e -> IO a) -> IO a -> IO a
EX.handle (\(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO a
EX.finally
(if Bool
verbose
then Fd -> Fd -> IO ()
tee Fd
fd Fd
stdoutRead
else Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
printToRegion Fd
fd Fd
stdoutRead Int
6 MVar Bool
pState Bool
no_color
)
(forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
stdoutWrite Fd
stdOutput
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
stdoutWrite Fd
stdError
Fd -> IO ()
closeFd Fd
stdoutRead
Fd -> IO ()
closeFd Fd
stdoutWrite
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
exe (Bool -> Bool
not (FilePath
"./" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
exe)) [FilePath]
args Maybe [(FilePath, FilePath)]
env
Fd -> IO ()
closeFd Fd
stdoutWrite
Either ProcessError ()
e <- FilePath
-> [FilePath] -> Maybe ProcessStatus -> Either ProcessError ()
toProcessError FilePath
exe [FilePath]
args forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
SPP.getProcessStatus Bool
True Bool
True ProcessID
pid
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
pState (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) (forall a b. a -> b -> a
const Bool
True) Either ProcessError ()
e)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO (Either a b)
race (forall a. MVar a -> IO a
takeMVar MVar ()
done) (Int -> IO ()
threadDelay (Int
1000000 forall a. Num a => a -> a -> a
* Int
3))
Fd -> IO ()
closeFd Fd
stdoutRead
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ProcessError ()
e
tee :: Fd -> Fd -> IO ()
tee :: Fd -> Fd -> IO ()
tee Fd
fileFd = forall (m :: * -> *) a.
MonadIO m =>
(ByteString -> m a) -> Fd -> m ()
readTilEOF ByteString -> IO ()
lineAction
where
lineAction :: ByteString -> IO ()
lineAction :: ByteString -> IO ()
lineAction ByteString
bs' = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
fileFd (ByteString
bs' forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
stdOutput (ByteString
bs' forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
printToRegion Fd
fileFd Fd
fdIn Int
size MVar Bool
pState Bool
no_color = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
size] forall a b. (a -> b) -> a -> b
$ \Int
_ -> Handle -> ByteString -> IO ()
BS.hPut Handle
stderr ByteString
"\n"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT forall a. Monoid a => a
mempty
forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle
(\(SomeException
ex :: SomeException) -> do
Bool
ps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar Bool
pState
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ps (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
stderr (ByteString
pos1 forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineUp Int
size forall a. Semigroup a => a -> a -> a
<> ByteString
clearScreen))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
ex
) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
(ByteString -> m a) -> Fd -> m ()
readTilEOF forall (m :: * -> *).
(MonadMask m, MonadIO m) =>
ByteString -> StateT (Seq ByteString) m ()
lineAction Fd
fdIn
where
clearScreen :: ByteString
clearScreen :: ByteString
clearScreen = ByteString
"\x1b[0J"
clearLine :: ByteString
clearLine :: ByteString
clearLine = ByteString
"\x1b[2K"
moveLineUp :: Int -> ByteString
moveLineUp :: Int -> ByteString
moveLineUp Int
n = ByteString
"\x1b[" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
n)) forall a. Semigroup a => a -> a -> a
<> ByteString
"A"
moveLineDown :: Int -> ByteString
moveLineDown :: Int -> ByteString
moveLineDown Int
n = ByteString
"\x1b[" forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
n)) forall a. Semigroup a => a -> a -> a
<> ByteString
"B"
pos1 :: ByteString
pos1 :: ByteString
pos1 = ByteString
"\r"
overwriteNthLine :: Int -> ByteString -> ByteString
overwriteNthLine :: Int -> ByteString -> ByteString
overwriteNthLine Int
n ByteString
str = ByteString
pos1 forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineUp Int
n forall a. Semigroup a => a -> a -> a
<> ByteString
clearLine forall a. Semigroup a => a -> a -> a
<> ByteString
str forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineDown Int
n forall a. Semigroup a => a -> a -> a
<> ByteString
pos1
blue :: ByteString -> ByteString
blue :: ByteString -> ByteString
blue ByteString
bs
| Bool
no_color = ByteString
bs
| Bool
otherwise = ByteString
"\x1b[0;34m" forall a. Semigroup a => a -> a -> a
<> ByteString
bs forall a. Semigroup a => a -> a -> a
<> ByteString
"\x1b[0m"
lineAction :: (MonadMask m, MonadIO m)
=> ByteString
-> StateT (Seq ByteString) m ()
lineAction :: forall (m :: * -> *).
(MonadMask m, MonadIO m) =>
ByteString -> StateT (Seq ByteString) m ()
lineAction = \ByteString
bs' -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
fileFd (ByteString
bs' forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. a -> Seq a -> Seq a
swapRegs ByteString
bs')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall n. Integral n => IO (Maybe (Window n))
TP.size forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Window Int)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (TP.Window Int
_ Int
w) -> do
Seq ByteString
regs <- forall (m :: * -> *) s. Monad m => StateT s m s
get
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. Seq a -> Seq b -> Seq (a, b)
Sq.zip Seq ByteString
regs (forall a. [a] -> Seq a
Sq.fromList [Int
0..(forall a. Seq a -> Int
Sq.length Seq ByteString
regs forall a. Num a => a -> a -> a
- Int
1)])) forall a b. (a -> b) -> a -> b
$ \(ByteString
bs, Int
i) -> do
Handle -> ByteString -> IO ()
BS.hPut Handle
stderr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
overwriteNthLine (Int
size forall a. Num a => a -> a -> a
- Int
i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
trim Int
w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
blue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ByteString
b -> ByteString
"[ " forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack FilePath
lfile) forall a. Semigroup a => a -> a -> a
<> ByteString
" ] " forall a. Semigroup a => a -> a -> a
<> ByteString
b)
forall a b. (a -> b) -> a -> b
$ ByteString
bs
swapRegs :: a -> Seq a -> Seq a
swapRegs :: forall a. a -> Seq a -> Seq a
swapRegs a
bs = \Seq a
regs -> if
| forall a. Seq a -> Int
Sq.length Seq a
regs forall a. Ord a => a -> a -> Bool
< Int
size -> Seq a
regs forall a. Seq a -> a -> Seq a
|> a
bs
| Bool
otherwise -> forall a. Int -> Seq a -> Seq a
Sq.drop Int
1 Seq a
regs forall a. Seq a -> a -> Seq a
|> a
bs
trim :: Int -> ByteString -> ByteString
trim :: Int -> ByteString -> ByteString
trim Int
w = \ByteString
bs -> if
| ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
w Bool -> Bool -> Bool
&& Int
w forall a. Ord a => a -> a -> Bool
> Int
5 -> Int -> ByteString -> ByteString
BS.take (Int
w forall a. Num a => a -> a -> a
- Int
4) ByteString
bs forall a. Semigroup a => a -> a -> a
<> ByteString
"..."
| Bool
otherwise -> ByteString
bs
readLine :: MonadIO m
=> Fd
-> ByteString
-> m (ByteString, ByteString, Bool)
readLine :: forall (m :: * -> *).
MonadIO m =>
Fd -> ByteString -> m (ByteString, ByteString, Bool)
readLine Fd
fd = ByteString -> m (ByteString, ByteString, Bool)
go
where
go :: ByteString -> m (ByteString, ByteString, Bool)
go ByteString
inBs = do
Maybe ByteString
mbs <- if ByteString -> Int
BS.length ByteString
inBs forall a. Eq a => a -> a -> Bool
== Int
0
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else forall a. IOException -> IO a
ioError IOException
e)
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
forall a b. (a -> b) -> a -> b
$ Fd -> ByteCount -> IO ByteString
SPIB.fdRead Fd
fd ByteCount
512
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
inBs
case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
"", ByteString
"", Bool
True)
Just ByteString
bs -> do
let (ByteString
line, ByteString
rest) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.span (forall a. Eq a => a -> a -> Bool
/= Word8
_lf) ByteString
bs
if
| ByteString -> Int
BS.length ByteString
rest forall a. Eq a => a -> a -> Bool
/= Int
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
line, HasCallStack => ByteString -> ByteString
BS.tail ByteString
rest, Bool
False)
| Bool
otherwise -> (\(ByteString
l, ByteString
r, Bool
b) -> (ByteString
line forall a. Semigroup a => a -> a -> a
<> ByteString
l, ByteString
r, Bool
b)) forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ByteString -> m (ByteString, ByteString, Bool)
go forall a. Monoid a => a
mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF :: forall (m :: * -> *) a.
MonadIO m =>
(ByteString -> m a) -> Fd -> m ()
readTilEOF ~ByteString -> m a
action' Fd
fd' = ByteString -> m ()
go forall a. Monoid a => a
mempty
where
go :: ByteString -> m ()
go ByteString
bs' = do
(ByteString
bs, ByteString
rest, Bool
eof) <- forall (m :: * -> *).
MonadIO m =>
Fd -> ByteString -> m (ByteString, ByteString, Bool)
readLine Fd
fd' ByteString
bs'
if Bool
eof
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IOException -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOException
mkIOError IOErrorType
eofErrorType FilePath
"" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
else forall (f :: * -> *) a. Functor f => f a -> f ()
void (ByteString -> m a
action' ByteString
bs) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> m ()
go ByteString
rest
captureOutStreams :: IO a
-> IO CapturedProcess
captureOutStreams :: forall a. IO a -> IO CapturedProcess
captureOutStreams IO a
action = do
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes forall a b. (a -> b) -> a -> b
$ \(Fd
parentStdoutRead, Fd
childStdoutWrite) ->
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes forall a b. (a -> b) -> a -> b
$ \(Fd
parentStderrRead, Fd
childStderrWrite) -> do
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
childStdoutWrite Fd
stdOutput
Fd -> IO ()
closeFd Fd
childStdoutWrite
Fd -> IO ()
closeFd Fd
parentStdoutRead
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
childStderrWrite Fd
stdError
Fd -> IO ()
closeFd Fd
childStderrWrite
Fd -> IO ()
closeFd Fd
parentStderrRead
a
a <- IO a
action
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
E.evaluate a
a
Fd -> IO ()
closeFd Fd
childStdoutWrite
Fd -> IO ()
closeFd Fd
childStderrWrite
IORef ByteString
refOut <- forall a. a -> IO (IORef a)
newIORef ByteString
BL.empty
IORef ByteString
refErr <- forall a. a -> IO (IORef a)
newIORef ByteString
BL.empty
MVar ()
done <- forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <-
IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => (e -> IO a) -> IO a -> IO a
EX.handle (\(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
EX.finally (forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IORef ByteString -> IORef ByteString -> IO ()
writeStds Fd
parentStdoutRead Fd
parentStderrRead IORef ByteString
refOut IORef ByteString
refErr
Maybe ProcessStatus
status <- Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
SPP.getProcessStatus Bool
True Bool
True ProcessID
pid
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. IO a -> IO b -> IO (Either a b)
race (forall a. MVar a -> IO a
takeMVar MVar ()
done) (Int -> IO ()
threadDelay (Int
1000000 forall a. Num a => a -> a -> a
* Int
3))
case Maybe ProcessStatus
status of
Just (SPP.Exited ExitCode
es) -> do
ByteString
stdout' <- forall a. IORef a -> IO a
readIORef IORef ByteString
refOut
ByteString
stderr' <- forall a. IORef a -> IO a
readIORef IORef ByteString
refErr
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CapturedProcess { $sel:_exitCode:CapturedProcess :: ExitCode
_exitCode = ExitCode
es
, $sel:_stdOut:CapturedProcess :: ByteString
_stdOut = ByteString
stdout'
, $sel:_stdErr:CapturedProcess :: ByteString
_stdErr = ByteString
stderr'
}
Maybe ProcessStatus
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"No such PID " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show ProcessID
pid)
where
writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
writeStds :: Fd -> Fd -> IORef ByteString -> IORef ByteString -> IO ()
writeStds Fd
pout Fd
perr IORef ByteString
rout IORef ByteString
rerr = do
MVar ()
doneOut <- forall a. IO (MVar a)
newEmptyMVar
forall (f :: * -> *) a. Functor f => f a -> f ()
void
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
eofErrorType
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
EX.finally (forall a. MVar a -> a -> IO ()
putMVar MVar ()
doneOut ())
forall a b. (a -> b) -> a -> b
$ forall {a} {b}. (ByteString -> IO a) -> Fd -> IO b
readTilEOF (\ByteString
x -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ByteString
rout (forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BL.fromStrict ByteString
x)) Fd
pout
MVar ()
doneErr <- forall a. IO (MVar a)
newEmptyMVar
forall (f :: * -> *) a. Functor f => f a -> f ()
void
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
eofErrorType
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
EX.finally (forall a. MVar a -> a -> IO ()
putMVar MVar ()
doneErr ())
forall a b. (a -> b) -> a -> b
$ forall {a} {b}. (ByteString -> IO a) -> Fd -> IO b
readTilEOF (\ByteString
x -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ByteString
rerr (forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BL.fromStrict ByteString
x)) Fd
perr
forall a. MVar a -> IO a
takeMVar MVar ()
doneOut
forall a. MVar a -> IO a
takeMVar MVar ()
doneErr
readTilEOF :: (ByteString -> IO a) -> Fd -> IO b
readTilEOF ~ByteString -> IO a
action' Fd
fd' = do
ByteString
bs <- Fd -> ByteCount -> IO ByteString
SPIB.fdRead Fd
fd' ByteCount
512
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ByteString -> IO a
action' ByteString
bs
(ByteString -> IO a) -> Fd -> IO b
readTilEOF ByteString -> IO a
action' Fd
fd'
actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes :: forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes (Fd, Fd) -> IO b
a =
IO (Fd, Fd)
createPipe forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Fd
p1, Fd
p2) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally ([Fd] -> IO ()
cleanup [Fd
p1, Fd
p2]) forall a b. (a -> b) -> a -> b
$ (Fd, Fd) -> IO b
a (Fd
p1, Fd
p2)
cleanup :: [Fd] -> IO ()
cleanup :: [Fd] -> IO ()
cleanup [Fd]
fds = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Fd]
fds forall a b. (a -> b) -> a -> b
$ \Fd
fd -> forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ Fd -> IO ()
closeFd Fd
fd
createRegularFileFd :: FileMode -> FilePath -> IO Fd
createRegularFileFd :: FileMode -> FilePath -> IO Fd
createRegularFileFd FileMode
fm FilePath
dest =
FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
dest OpenMode
WriteOnly (forall a. a -> Maybe a
Just FileMode
fm) OpenFileFlags
defaultFileFlags{ exclusive :: Bool
exclusive = Bool
True }
exec :: MonadIO m
=> String
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> m (Either ProcessError ())
exec :: forall (m :: * -> *).
MonadIO m =>
FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec FilePath
exe [FilePath]
args Maybe FilePath
chdir Maybe [(FilePath, FilePath)]
env = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess forall a b. (a -> b) -> a -> b
$ do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
exe (Bool -> Bool
not (FilePath
"./" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
exe)) [FilePath]
args Maybe [(FilePath, FilePath)]
env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
-> [FilePath] -> Maybe ProcessStatus -> Either ProcessError ()
toProcessError FilePath
exe [FilePath]
args) forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
SPP.getProcessStatus Bool
True Bool
True ProcessID
pid
toProcessError :: FilePath
-> [String]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError :: FilePath
-> [FilePath] -> Maybe ProcessStatus -> Either ProcessError ()
toProcessError FilePath
exe [FilePath]
args Maybe ProcessStatus
mps = case Maybe ProcessStatus
mps of
Just (SPP.Exited (ExitFailure Int
xi)) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> [FilePath] -> ProcessError
NonZeroExit Int
xi FilePath
exe [FilePath]
args
Just (SPP.Exited ExitCode
ExitSuccess ) -> forall a b. b -> Either a b
Right ()
Just (Terminated Signal
_ Bool
_ ) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
PTerminated FilePath
exe [FilePath]
args
Just (Stopped Signal
_ ) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
PStopped FilePath
exe [FilePath]
args
Maybe ProcessStatus
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
NoSuchPid FilePath
exe [FilePath]
args