{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}

{-|
Module      : GHCup.Utils.File.Posix
Description : File and unix APIs
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : POSIX

This module handles file and executable handling.
Some of these functions use sophisticated logging.
-}
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



-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: MonadIO m
           => FilePath          -- ^ command as filename, e.g. 'ls'
           -> [String]          -- ^ arguments to the command
           -> Maybe FilePath    -- ^ chdir to this path
           -> 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         -- ^ thing to execute
           -> [String]         -- ^ args for the thing
           -> Maybe FilePath   -- ^ optionally chdir into this
           -> FilePath         -- ^ log filename (opened in append mode)
           -> Maybe [(String, String)] -- ^ optional environment
           -> 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
      -- start the thread that logs to stdout
      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 ())

      -- fork the subprocess
      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

        -- execute the action
        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

      -- wait for the subprocess to finish
      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")

  -- Reads fdIn and logs the output in a continous scrolling area
  -- of 'size' terminal lines. Also writes to a log file.
  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
    -- init region
    [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"

    -- action to perform line by line
    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 output line to terminal width
    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

  -- Consecutively read from Fd in 512 chunks until we hit
  -- newline or EOF.
  readLine :: MonadIO m
           => Fd          -- ^ input file descriptor
           -> ByteString  -- ^ rest buffer (read across newline)
           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
  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
      -- if buffer is not empty, process it first
      Maybe ByteString
mbs <- if ByteString -> Int
BS.length ByteString
inBs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
               -- otherwise attempt read
               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
          -- split on newline
          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)
            -- if rest is empty, then there was no newline, process further
            | 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


-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
                     -- ^ the action to execute in a subprocess
                  -> 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
        -- dup stdout
        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

        -- dup stderr
        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

        -- execute the action
        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

      -- close everything we don't need
      Fd -> IO ()
closeFd Fd
childStdoutWrite
      Fd -> IO ()
closeFd Fd
childStderrWrite

      -- start thread that writes the output
      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
        -- readFd will take care of closing the fd
        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



-- | Create a new regular file in write-only mode. The file must not exist.
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 }


-- | Thin wrapper around `executeFile`.
exec :: MonadIO m
     => String           -- ^ thing to execute
     -> [String]         -- ^ args for the thing
     -> Maybe FilePath   -- ^ optionally chdir into this
     -> Maybe [(String, String)] -- ^ optional environment
     -> 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


-- |Default permissions for a new file.
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


-- | Checks whether the binary is a broken link.
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
        -- this drops 'symDir' if 'tfp' is absolute
        (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