{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module GHCup.Utils.File.Posix where
import GHCup.Utils.File.Common
import GHCup.Utils.Prelude
import GHCup.Utils.Logger
import GHCup.Types
import GHCup.Types.Optics
import Control.Concurrent
import Control.Concurrent.Async
import Control.Exception ( evaluate )
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
import System.FilePath
import System.Directory
import System.Posix.Directory
import System.Posix.Files
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 :: FilePath -> [FilePath] -> Maybe FilePath -> m CapturedProcess
executeOut FilePath
path [FilePath]
args Maybe FilePath
chdir = IO CapturedProcess -> m CapturedProcess
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CapturedProcess -> m CapturedProcess)
-> IO CapturedProcess -> m CapturedProcess
forall a b. (a -> b) -> a -> b
$ IO Any -> IO CapturedProcess
forall a. IO a -> IO CapturedProcess
captureOutStreams (IO Any -> IO CapturedProcess) -> IO Any -> IO CapturedProcess
forall a b. (a -> b) -> a -> b
$ do
IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO Any
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
path Bool
True [FilePath]
args Maybe [(FilePath, FilePath)]
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 :: 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
GPGSetting
Downloader
KeepDirs
URLSource
$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:metaCache:Settings :: Settings -> Integer
$sel:cache:Settings :: Settings -> Bool
noColor :: Bool
gpgSetting :: GPGSetting
noNetwork :: Bool
urlSource :: URLSource
verbose :: Bool
downloader :: Downloader
keepDirs :: KeepDirs
noVerify :: Bool
metaCache :: Integer
cache :: Bool
..} <- m Settings
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "settings" A_Lens env Settings) =>
m Settings
getSettings
Dirs {FilePath
$sel:recycleDir:Dirs :: Dirs -> FilePath
$sel:confDir:Dirs :: Dirs -> FilePath
$sel:logsDir:Dirs :: Dirs -> FilePath
$sel:cacheDir:Dirs :: Dirs -> FilePath
$sel:binDir:Dirs :: Dirs -> FilePath
$sel:baseDir:Dirs :: Dirs -> FilePath
recycleDir :: FilePath
confDir :: FilePath
logsDir :: FilePath
cacheDir :: FilePath
binDir :: FilePath
baseDir :: FilePath
..} <- m Dirs
forall env (m :: * -> *).
(MonadReader env m, LabelOptic' "dirs" A_Lens env Dirs) =>
m Dirs
getDirs
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exe FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" with arguments " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
args
let logfile :: FilePath
logfile = FilePath
logsDir FilePath -> FilePath -> FilePath
</> FilePath
lfile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".log"
IO (Either ProcessError ()) -> m (Either ProcessError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ProcessError ()) -> m (Either ProcessError ()))
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ IO Fd
-> (Fd -> IO ())
-> (Fd -> IO (Either ProcessError ()))
-> IO (Either ProcessError ())
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 (FileMode -> Maybe FileMode
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
((Fd, Fd) -> IO (Either ProcessError ()))
-> IO (Either ProcessError ())
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes (((Fd, Fd) -> IO (Either ProcessError ()))
-> IO (Either ProcessError ()))
-> ((Fd, Fd) -> IO (Either ProcessError ()))
-> IO (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ \(Fd
stdoutRead, Fd
stdoutWrite) -> do
MVar Bool
pState <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
EX.handle (\(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
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
)
(MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
stdoutWrite Fd
stdOutput
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
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
IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO Any
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
exe (Bool -> Bool
not (FilePath
"./" FilePath -> FilePath -> Bool
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 (Maybe ProcessStatus -> Either ProcessError ())
-> IO (Maybe ProcessStatus) -> IO (Either ProcessError ())
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
MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
pState ((ProcessError -> Bool)
-> (() -> Bool) -> Either ProcessError () -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ProcessError -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True) Either ProcessError ()
e)
IO (Either () ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO (Either () ())
forall a b. IO a -> IO b -> IO (Either a b)
race (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done) (Int -> IO ()
threadDelay (Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3))
Fd -> IO ()
closeFd Fd
stdoutRead
Either ProcessError () -> IO (Either ProcessError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ProcessError ()
e
tee :: Fd -> Fd -> IO ()
tee :: Fd -> Fd -> IO ()
tee Fd
fileFd = (ByteString -> IO ()) -> Fd -> IO ()
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
IO ByteCount -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteCount -> IO ()) -> IO ByteCount -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
fileFd (ByteString
bs' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
IO ByteCount -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteCount -> IO ()) -> IO ByteCount -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
stdOutput (ByteString
bs' ByteString -> ByteString -> ByteString
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
[Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
size] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ -> Handle -> ByteString -> IO ()
BS.hPut Handle
stderr ByteString
"\n"
IO ((), Seq ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), Seq ByteString) -> IO ())
-> IO ((), Seq ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ (StateT (Seq ByteString) IO ()
-> Seq ByteString -> IO ((), Seq ByteString))
-> Seq ByteString
-> StateT (Seq ByteString) IO ()
-> IO ((), Seq ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Seq ByteString) IO ()
-> Seq ByteString -> IO ((), Seq ByteString)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Seq ByteString
forall a. Monoid a => a
mempty
(StateT (Seq ByteString) IO () -> IO ((), Seq ByteString))
-> StateT (Seq ByteString) IO () -> IO ((), Seq ByteString)
forall a b. (a -> b) -> a -> b
$ do
(SomeException -> StateT (Seq ByteString) IO ())
-> StateT (Seq ByteString) IO () -> StateT (Seq ByteString) IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle
(\(SomeException
ex :: SomeException) -> do
Bool
ps <- IO Bool -> StateT (Seq ByteString) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> StateT (Seq ByteString) IO Bool)
-> IO Bool -> StateT (Seq ByteString) IO Bool
forall a b. (a -> b) -> a -> b
$ MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
pState
Bool
-> StateT (Seq ByteString) IO () -> StateT (Seq ByteString) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ps (IO () -> StateT (Seq ByteString) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Seq ByteString) IO ())
-> IO () -> StateT (Seq ByteString) IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
stderr (ByteString
pos1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineUp Int
size ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
clearScreen))
SomeException -> StateT (Seq ByteString) IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
ex
) (StateT (Seq ByteString) IO () -> StateT (Seq ByteString) IO ())
-> StateT (Seq ByteString) IO () -> StateT (Seq ByteString) IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> StateT (Seq ByteString) IO ())
-> Fd -> StateT (Seq ByteString) IO ()
forall (m :: * -> *) a.
MonadIO m =>
(ByteString -> m a) -> Fd -> m ()
readTilEOF ByteString -> StateT (Seq ByteString) IO ()
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[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"A"
moveLineDown :: Int -> ByteString
moveLineDown :: Int -> ByteString
moveLineDown Int
n = ByteString
"\x1b[" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)) ByteString -> ByteString -> ByteString
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineUp Int
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
clearLine ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
str ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString
moveLineDown Int
n ByteString -> ByteString -> ByteString
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" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\x1b[0m"
lineAction :: (MonadMask m, MonadIO m)
=> ByteString
-> StateT (Seq ByteString) m ()
lineAction :: ByteString -> StateT (Seq ByteString) m ()
lineAction = \ByteString
bs' -> do
StateT (Seq ByteString) m ByteCount -> StateT (Seq ByteString) m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (Seq ByteString) m ByteCount
-> StateT (Seq ByteString) m ())
-> StateT (Seq ByteString) m ByteCount
-> StateT (Seq ByteString) m ()
forall a b. (a -> b) -> a -> b
$ IO ByteCount -> StateT (Seq ByteString) m ByteCount
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteCount -> StateT (Seq ByteString) m ByteCount)
-> IO ByteCount -> StateT (Seq ByteString) m ByteCount
forall a b. (a -> b) -> a -> b
$ Fd -> ByteString -> IO ByteCount
SPIB.fdWrite Fd
fileFd (ByteString
bs' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
(Seq ByteString -> Seq ByteString) -> StateT (Seq ByteString) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (ByteString -> Seq ByteString -> Seq ByteString
forall a. a -> Seq a -> Seq a
swapRegs ByteString
bs')
IO (Maybe (Window Int))
-> StateT (Seq ByteString) m (Maybe (Window Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
TP.size StateT (Seq ByteString) m (Maybe (Window Int))
-> (Maybe (Window Int) -> StateT (Seq ByteString) m ())
-> StateT (Seq ByteString) m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Window Int)
Nothing -> () -> StateT (Seq ByteString) m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (TP.Window Int
_ Int
w) -> do
Seq ByteString
regs <- StateT (Seq ByteString) m (Seq ByteString)
forall (m :: * -> *) s. Monad m => StateT s m s
get
IO () -> StateT (Seq ByteString) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Seq ByteString) m ())
-> IO () -> StateT (Seq ByteString) m ()
forall a b. (a -> b) -> a -> b
$ Seq (ByteString, Int) -> ((ByteString, Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Seq ByteString -> Seq Int -> Seq (ByteString, Int)
forall a b. Seq a -> Seq b -> Seq (a, b)
Sq.zip Seq ByteString
regs ([Int] -> Seq Int
forall a. [a] -> Seq a
Sq.fromList [Int
0..(Seq ByteString -> Int
forall a. Seq a -> Int
Sq.length Seq ByteString
regs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)])) (((ByteString, Int) -> IO ()) -> IO ())
-> ((ByteString, Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ByteString
bs, Int
i) -> do
Handle -> ByteString -> IO ()
BS.hPut Handle
stderr
(ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
overwriteNthLine (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
trim Int
w
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
blue
(ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ByteString
b -> ByteString
"[ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
E.encodeUtf8 (FilePath -> Text
T.pack FilePath
lfile) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" ] " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b)
(ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
bs
swapRegs :: a -> Seq a -> Seq a
swapRegs :: a -> Seq a -> Seq a
swapRegs a
bs = \Seq a
regs -> if
| Seq a -> Int
forall a. Seq a -> Int
Sq.length Seq a
regs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size -> Seq a
regs Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
|> a
bs
| Bool
otherwise -> Int -> Seq a -> Seq a
forall a. Int -> Seq a -> Seq a
Sq.drop Int
1 Seq a
regs Seq a -> a -> Seq a
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
w Bool -> Bool -> Bool
&& Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5 -> Int -> ByteString -> ByteString
BS.take (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"..."
| Bool
otherwise -> ByteString
bs
readLine :: MonadIO m
=> Fd
-> ByteString
-> m (ByteString, ByteString, Bool)
readLine :: 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (IOException -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing else IOException -> IO (Maybe ByteString)
forall a. IOException -> IO a
ioError IOException
e)
(IO (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just
(IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Fd -> ByteCount -> IO ByteString
SPIB.fdRead Fd
fd ByteCount
512
else Maybe ByteString -> m (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
inBs
case Maybe ByteString
mbs of
Maybe ByteString
Nothing -> (ByteString, ByteString, Bool) -> m (ByteString, ByteString, Bool)
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 (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
_lf) ByteString
bs
if
| ByteString -> Int
BS.length ByteString
rest Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 -> (ByteString, ByteString, Bool) -> m (ByteString, ByteString, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
line, ByteString -> ByteString
BS.tail ByteString
rest, Bool
False)
| Bool
otherwise -> (\(ByteString
l, ByteString
r, Bool
b) -> (ByteString
line ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
l, ByteString
r, Bool
b)) ((ByteString, ByteString, Bool) -> (ByteString, ByteString, Bool))
-> m (ByteString, ByteString, Bool)
-> m (ByteString, ByteString, Bool)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ByteString -> m (ByteString, ByteString, Bool)
go ByteString
forall a. Monoid a => a
mempty
readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
readTilEOF :: (ByteString -> m a) -> Fd -> m ()
readTilEOF ~ByteString -> m a
action' Fd
fd' = ByteString -> m ()
go ByteString
forall a. Monoid a => a
mempty
where
go :: ByteString -> m ()
go ByteString
bs' = do
(ByteString
bs, ByteString
rest, Bool
eof) <- Fd -> ByteString -> m (ByteString, ByteString, Bool)
forall (m :: * -> *).
MonadIO m =>
Fd -> ByteString -> m (ByteString, ByteString, Bool)
readLine Fd
fd' ByteString
bs'
if Bool
eof
then IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall a. IOException -> IO a
ioError (IOErrorType
-> FilePath -> Maybe Handle -> Maybe FilePath -> IOException
mkIOError IOErrorType
eofErrorType FilePath
"" Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing)
else m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ByteString -> m a
action' ByteString
bs) m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> m ()
go ByteString
rest
captureOutStreams :: IO a
-> IO CapturedProcess
captureOutStreams :: IO a -> IO CapturedProcess
captureOutStreams IO a
action = do
((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes (((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess)
-> ((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess
forall a b. (a -> b) -> a -> b
$ \(Fd
parentStdoutRead, Fd
childStdoutWrite) ->
((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess
forall b. ((Fd, Fd) -> IO b) -> IO b
actionWithPipes (((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess)
-> ((Fd, Fd) -> IO CapturedProcess) -> IO CapturedProcess
forall a b. (a -> b) -> a -> b
$ \(Fd
parentStderrRead, Fd
childStderrWrite) -> do
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
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
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
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
IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate a
a
Fd -> IO ()
closeFd Fd
childStdoutWrite
Fd -> IO ()
closeFd Fd
childStderrWrite
IORef ByteString
refOut <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
BL.empty
IORef ByteString
refErr <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
BL.empty
MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
ThreadId
_ <-
IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
EX.handle (\(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
EX.finally (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
(IO () -> IO ()) -> IO () -> IO ()
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
IO (Either () ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () ()) -> IO ()) -> IO (Either () ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO (Either () ())
forall a b. IO a -> IO b -> IO (Either a b)
race (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done) (Int -> IO ()
threadDelay (Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3))
case Maybe ProcessStatus
status of
Just (SPP.Exited ExitCode
es) -> do
ByteString
stdout' <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
refOut
ByteString
stderr' <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
refErr
CapturedProcess -> IO CapturedProcess
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CapturedProcess -> IO CapturedProcess)
-> CapturedProcess -> IO CapturedProcess
forall a b. (a -> b) -> a -> b
$ CapturedProcess :: ExitCode -> ByteString -> ByteString -> CapturedProcess
CapturedProcess { $sel:_exitCode:CapturedProcess :: ExitCode
_exitCode = ExitCode
es
, $sel:_stdOut:CapturedProcess :: ByteString
_stdOut = ByteString
stdout'
, $sel:_stdErr:CapturedProcess :: ByteString
_stdErr = ByteString
stderr'
}
Maybe ProcessStatus
_ -> IOException -> IO CapturedProcess
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOException -> IO CapturedProcess)
-> IOException -> IO CapturedProcess
forall a b. (a -> b) -> a -> b
$ FilePath -> IOException
userError (FilePath
"No such PID " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ProcessID -> FilePath
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 <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
eofErrorType
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
EX.finally (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
doneOut ())
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ()) -> Fd -> IO ()
forall a b. (ByteString -> IO a) -> Fd -> IO b
readTilEOF (\ByteString
x -> IORef ByteString -> (ByteString -> ByteString) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ByteString
rout (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BL.fromStrict ByteString
x)) Fd
pout
MVar ()
doneErr <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
(IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IOErrorType -> IO () -> IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
IOErrorType -> m () -> m ()
hideError IOErrorType
eofErrorType
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
EX.finally (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
doneErr ())
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ()) -> Fd -> IO ()
forall a b. (ByteString -> IO a) -> Fd -> IO b
readTilEOF (\ByteString
x -> IORef ByteString -> (ByteString -> ByteString) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef ByteString
rerr (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BL.fromStrict ByteString
x)) Fd
perr
MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
doneOut
MVar () -> IO ()
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
IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
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 :: ((Fd, Fd) -> IO b) -> IO b
actionWithPipes (Fd, Fd) -> IO b
a =
IO (Fd, Fd)
createPipe IO (Fd, Fd) -> ((Fd, Fd) -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Fd
p1, Fd
p2) -> (IO b -> IO () -> IO b) -> IO () -> IO b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO b -> IO () -> IO b
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally ([Fd] -> IO ()
cleanup [Fd
p1, Fd
p2]) (IO b -> IO b) -> IO b -> IO b
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 = [Fd] -> (Fd -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Fd]
fds ((Fd -> IO ()) -> IO ()) -> (Fd -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Fd
fd -> (IOException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(IOException -> m a) -> m a -> m a
handleIO (\IOException
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
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 (FileMode -> Maybe FileMode
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 :: FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> m (Either ProcessError ())
exec FilePath
exe [FilePath]
args Maybe FilePath
chdir Maybe [(FilePath, FilePath)]
env = IO (Either ProcessError ()) -> m (Either ProcessError ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ProcessError ()) -> m (Either ProcessError ()))
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
forall a b. (a -> b) -> a -> b
$ do
ProcessID
pid <- IO () -> IO ProcessID
SPP.forkProcess (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ do
IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) FilePath -> IO ()
changeWorkingDirectory Maybe FilePath
chdir
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO ()
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
SPP.executeFile FilePath
exe (Bool -> Bool
not (FilePath
"./" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
exe)) [FilePath]
args Maybe [(FilePath, FilePath)]
env
(Maybe ProcessStatus -> Either ProcessError ())
-> IO (Maybe ProcessStatus) -> IO (Either ProcessError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
-> [FilePath] -> Maybe ProcessStatus -> Either ProcessError ()
toProcessError FilePath
exe [FilePath]
args) (IO (Maybe ProcessStatus) -> IO (Either ProcessError ()))
-> IO (Maybe ProcessStatus) -> IO (Either ProcessError ())
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)) -> ProcessError -> Either ProcessError ()
forall a b. a -> Either a b
Left (ProcessError -> Either ProcessError ())
-> ProcessError -> Either ProcessError ()
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> [FilePath] -> ProcessError
NonZeroExit Int
xi FilePath
exe [FilePath]
args
Just (SPP.Exited ExitCode
ExitSuccess ) -> () -> Either ProcessError ()
forall a b. b -> Either a b
Right ()
Just (Terminated Signal
_ Bool
_ ) -> ProcessError -> Either ProcessError ()
forall a b. a -> Either a b
Left (ProcessError -> Either ProcessError ())
-> ProcessError -> Either ProcessError ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
PTerminated FilePath
exe [FilePath]
args
Just (Stopped Signal
_ ) -> ProcessError -> Either ProcessError ()
forall a b. a -> Either a b
Left (ProcessError -> Either ProcessError ())
-> ProcessError -> Either ProcessError ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
PStopped FilePath
exe [FilePath]
args
Maybe ProcessStatus
Nothing -> ProcessError -> Either ProcessError ()
forall a b. a -> Either a b
Left (ProcessError -> Either ProcessError ())
-> ProcessError -> Either ProcessError ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessError
NoSuchPid FilePath
exe [FilePath]
args
chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
chmod_755 :: FilePath -> m ()
chmod_755 FilePath
fp = do
let exe_mode :: FileMode
exe_mode =
FileMode
nullFileMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerExecuteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerReadMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerWriteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
groupExecuteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
groupReadMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
otherExecuteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
otherReadMode
Text -> m ()
forall env (m :: * -> *).
(MonadReader env m,
LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) =>
Text -> m ()
logDebug (Text
"chmod 755 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
fp)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FileMode -> IO ()
setFileMode FilePath
fp FileMode
exe_mode
newFilePerms :: FileMode
newFilePerms :: FileMode
newFilePerms =
FileMode
ownerWriteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerReadMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
groupWriteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
groupReadMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
otherWriteMode
FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
otherReadMode
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink :: FilePath -> IO Bool
isBrokenSymlink FilePath
fp = do
IO Bool -> IO (Either IOException Bool)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (FilePath -> IO Bool
pathIsSymbolicLink FilePath
fp) IO (Either IOException Bool)
-> (Either IOException Bool -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right Bool
True -> do
let symDir :: FilePath
symDir = FilePath -> FilePath
takeDirectory FilePath
fp
FilePath
tfp <- FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
fp
Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesPathExist
(FilePath
symDir FilePath -> FilePath -> FilePath
</> FilePath
tfp)
Right Bool
b -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
Left IOException
e | IOException -> Bool
isDoesNotExistError IOException
e -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
otherwise -> IOException -> IO Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e