{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE ScopedTypeVariables      #-}

module Keter.Conduit.Process.Unix
    ( -- * Process tracking
      -- $processTracker

      -- ** Types
      ProcessTracker
      -- ** Functions
    , initProcessTracker

      -- * Monitored process
    , MonitoredProcess
    , monitorProcess
    , terminateMonitoredProcess
    , printStatus
    ) where

import           Data.Text(Text, pack)
import           Control.Applicative             ((<$>), (<*>), pure)
import           Control.Arrow                   ((***))
import           Control.Concurrent              (forkIO)
import           Control.Concurrent              (threadDelay)
import           Control.Concurrent.MVar         (MVar, modifyMVar, modifyMVar_,
                                                  newEmptyMVar, newMVar,
                                                  putMVar, readMVar, swapMVar,
                                                  takeMVar, tryReadMVar)
import           Control.Exception               (Exception, SomeException,
                                                  bracketOnError, finally,
                                                  handle, mask_,
                                                  throwIO, try)
import           Control.Monad                   (void)
import           Data.ByteString                 (ByteString)
import qualified Data.ByteString.Char8           as S8
import           Data.Conduit                    (ConduitM, (.|), runConduit)
import           Data.Conduit.Binary             (sinkHandle, sourceHandle)
import qualified Data.Conduit.List               as CL
import           Data.IORef                      (IORef, newIORef, readIORef,
                                                  writeIORef)
import           Data.Time                       (getCurrentTime)
import           Data.Time                       (diffUTCTime)
import           Data.Typeable                   (Typeable)
import           Foreign.C.Types
import           Prelude                         (Bool (..), Either (..), IO,
                                                  Maybe (..), Monad (..), Show,
                                                  const, error,
                                                  map, maybe, show,
                                                  ($), ($!), (*), (<),
                                                  (==))
import           System.Exit                     (ExitCode)
import           System.IO                       (hClose)
import           System.Posix.IO.ByteString      ( closeFd, createPipe,
                                                  fdToHandle)
import           System.Posix.Signals            (sigKILL, signalProcess)
import           System.Posix.Types              (CPid (..))
import           System.Process                  (CmdSpec (..), CreateProcess (..),
                                                  StdStream (..), createProcess,
                                                  terminateProcess, waitForProcess,
                                                  getPid)
import           System.Process.Internals        (ProcessHandle (..),
                                                  ProcessHandle__ (..))
import Data.Monoid ((<>)) -- sauron

processHandleMVar :: ProcessHandle -> MVar ProcessHandle__
#if MIN_VERSION_process(1, 6, 0)
processHandleMVar :: ProcessHandle -> MVar ProcessHandle__
processHandleMVar (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) = MVar ProcessHandle__
m
#elif MIN_VERSION_process(1, 2, 0)
processHandleMVar (ProcessHandle m _) = m
#else
processHandleMVar (ProcessHandle m) = m
#endif

withProcessHandle_
        :: ProcessHandle
        -> (ProcessHandle__ -> IO ProcessHandle__)
        -> IO ()
withProcessHandle_ :: ProcessHandle -> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
withProcessHandle_ ProcessHandle
ph ProcessHandle__ -> IO ProcessHandle__
io = MVar ProcessHandle__
-> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (ProcessHandle -> MVar ProcessHandle__
processHandleMVar ProcessHandle
ph) ProcessHandle__ -> IO ProcessHandle__
io

-- | Kill a process by sending it the KILL (9) signal.
--
-- Since 0.1.0
killProcess :: ProcessHandle -> IO ()
killProcess :: ProcessHandle -> IO ()
killProcess ProcessHandle
ph = ProcessHandle -> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
withProcessHandle_ ProcessHandle
ph ((ProcessHandle__ -> IO ProcessHandle__) -> IO ())
-> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ ->
    case ProcessHandle__
p_ of
        ClosedHandle ExitCode
_ -> ProcessHandle__ -> IO ProcessHandle__
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_
        OpenHandle PHANDLE
h -> do
            Signal -> PHANDLE -> IO ()
signalProcess Signal
sigKILL PHANDLE
h
            ProcessHandle__ -> IO ProcessHandle__
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_

ignoreExceptions :: IO () -> IO ()
ignoreExceptions :: IO () -> IO ()
ignoreExceptions = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
_ :: SomeException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- $processTracker
--
-- Ensure that child processes are killed, regardless of how the parent process exits.
--
-- The technique used here is:
--
-- * Create a pipe.
--
-- * Fork a new child process that listens on the pipe.
--
-- * In the current process, send updates about processes that should be auto-killed.
--
-- * When the parent process dies, listening on the pipe in the child process will get an EOF.
--
-- * When the child process receives that EOF, it kills all processes it was told to auto-kill.
--
-- This code was originally written for Keter, but was moved to unix-process
-- conduit in the 0.2.1 release.

foreign import ccall unsafe "launch_process_tracker"
    c_launch_process_tracker :: IO CInt

foreign import ccall unsafe "track_process"
    c_track_process :: ProcessTracker -> CPid -> CInt -> IO ()

-- | Represents the child process which handles process cleanup.
--
-- Since 0.2.1
newtype ProcessTracker = ProcessTracker CInt

-- | Represents a child process which is currently being tracked by the cleanup
-- child process.
--
-- Since 0.2.1
data TrackedProcess = TrackedProcess !ProcessTracker !(IORef MaybePid) !(IO ExitCode)

data MaybePid = NoPid | Pid !CPid

-- | Fork off the child cleanup process.
--
-- This will ideally only be run once for your entire application.
--
-- Since 0.2.1
initProcessTracker :: IO ProcessTracker
initProcessTracker :: IO ProcessTracker
initProcessTracker = do
    Signal
i <- IO Signal
c_launch_process_tracker
    if Signal
i Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== -Signal
1
        then ProcessTrackerException -> IO ProcessTracker
forall e a. Exception e => e -> IO a
throwIO ProcessTrackerException
CannotLaunchProcessTracker
        else ProcessTracker -> IO ProcessTracker
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessTracker -> IO ProcessTracker)
-> ProcessTracker -> IO ProcessTracker
forall a b. (a -> b) -> a -> b
$! Signal -> ProcessTracker
ProcessTracker Signal
i

-- | Since 0.2.1
data ProcessTrackerException = CannotLaunchProcessTracker
    deriving (Int -> ProcessTrackerException -> ShowS
[ProcessTrackerException] -> ShowS
ProcessTrackerException -> String
(Int -> ProcessTrackerException -> ShowS)
-> (ProcessTrackerException -> String)
-> ([ProcessTrackerException] -> ShowS)
-> Show ProcessTrackerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProcessTrackerException] -> ShowS
$cshowList :: [ProcessTrackerException] -> ShowS
show :: ProcessTrackerException -> String
$cshow :: ProcessTrackerException -> String
showsPrec :: Int -> ProcessTrackerException -> ShowS
$cshowsPrec :: Int -> ProcessTrackerException -> ShowS
Show, Typeable)
instance Exception ProcessTrackerException

-- | Begin tracking the given process. If the 'ProcessHandle' refers to a
-- closed process, no tracking will occur. If the process is closed, then it
-- will be untracked automatically.
--
-- Note that you /must/ compile your program with @-threaded@; see
-- 'waitForProcess'.
--
-- Since 0.2.1
trackProcess :: ProcessTracker -> ProcessHandle -> IO TrackedProcess
trackProcess :: ProcessTracker -> ProcessHandle -> IO TrackedProcess
trackProcess ProcessTracker
pt ProcessHandle
ph = IO TrackedProcess -> IO TrackedProcess
forall a. IO a -> IO a
mask_ (IO TrackedProcess -> IO TrackedProcess)
-> IO TrackedProcess -> IO TrackedProcess
forall a b. (a -> b) -> a -> b
$ do
    ProcessHandle__
mpid <- MVar ProcessHandle__ -> IO ProcessHandle__
forall a. MVar a -> IO a
readMVar (MVar ProcessHandle__ -> IO ProcessHandle__)
-> MVar ProcessHandle__ -> IO ProcessHandle__
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> MVar ProcessHandle__
processHandleMVar ProcessHandle
ph
    MaybePid
mpid' <- case ProcessHandle__
mpid of
        ClosedHandle{} -> MaybePid -> IO MaybePid
forall (m :: * -> *) a. Monad m => a -> m a
return MaybePid
NoPid
        OpenHandle PHANDLE
pid -> do
            ProcessTracker -> PHANDLE -> Signal -> IO ()
c_track_process ProcessTracker
pt PHANDLE
pid Signal
1
            MaybePid -> IO MaybePid
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybePid -> IO MaybePid) -> MaybePid -> IO MaybePid
forall a b. (a -> b) -> a -> b
$ PHANDLE -> MaybePid
Pid PHANDLE
pid
    IORef MaybePid
ipid <- MaybePid -> IO (IORef MaybePid)
forall a. a -> IO (IORef a)
newIORef MaybePid
mpid'
    MVar ExitCode
baton <- IO (MVar ExitCode)
forall a. IO (MVar a)
newEmptyMVar
    let tp :: TrackedProcess
tp = ProcessTracker -> IORef MaybePid -> IO ExitCode -> TrackedProcess
TrackedProcess ProcessTracker
pt IORef MaybePid
ipid (MVar ExitCode -> IO ExitCode
forall a. MVar a -> IO a
takeMVar MVar ExitCode
baton)
    case MaybePid
mpid' of
        MaybePid
NoPid -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Pid PHANDLE
_ -> 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
$ do
            ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
baton
            TrackedProcess -> IO ()
untrackProcess TrackedProcess
tp
    TrackedProcess -> IO TrackedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (TrackedProcess -> IO TrackedProcess)
-> TrackedProcess -> IO TrackedProcess
forall a b. (a -> b) -> a -> b
$! TrackedProcess
tp

-- | Explicitly remove the given process from the tracked process list in the
-- cleanup process.
--
-- Since 0.2.1
untrackProcess :: TrackedProcess -> IO ()
untrackProcess :: TrackedProcess -> IO ()
untrackProcess (TrackedProcess ProcessTracker
pt IORef MaybePid
ipid IO ExitCode
_) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MaybePid
mpid <- IORef MaybePid -> IO MaybePid
forall a. IORef a -> IO a
readIORef IORef MaybePid
ipid
    case MaybePid
mpid of
        MaybePid
NoPid -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Pid PHANDLE
pid -> do
            ProcessTracker -> PHANDLE -> Signal -> IO ()
c_track_process ProcessTracker
pt PHANDLE
pid Signal
0
            IORef MaybePid -> MaybePid -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef MaybePid
ipid MaybePid
NoPid

-- | Fork and execute a subprocess, sending stdout and stderr to the specified
-- rotating log.
--
-- Since 0.2.1
forkExecuteLog :: ByteString -- ^ command
               -> [ByteString] -- ^ args
               -> Maybe [(ByteString, ByteString)] -- ^ environment
               -> Maybe ByteString -- ^ working directory
               -> Maybe (ConduitM () ByteString IO ()) -- ^ stdin
               -> (ByteString -> IO ()) -- ^ both stdout and stderr will be sent to this location
               -> IO ProcessHandle
forkExecuteLog :: ByteString
-> [ByteString]
-> Maybe [(ByteString, ByteString)]
-> Maybe ByteString
-> Maybe (ConduitM () ByteString IO ())
-> (ByteString -> IO ())
-> IO ProcessHandle
forkExecuteLog ByteString
cmd [ByteString]
args Maybe [(ByteString, ByteString)]
menv Maybe ByteString
mwdir Maybe (ConduitM () ByteString IO ())
mstdin ByteString -> IO ()
rlog = IO (Handle, Handle)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO ProcessHandle)
-> IO ProcessHandle
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
    IO (Handle, Handle)
setupPipe
    (Handle, Handle) -> IO ()
cleanupPipes
    (Handle, Handle) -> IO ProcessHandle
usePipes
  where
    setupPipe :: IO (Handle, Handle)
setupPipe = IO (Fd, Fd)
-> ((Fd, Fd) -> IO ())
-> ((Fd, Fd) -> IO (Handle, Handle))
-> IO (Handle, Handle)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        IO (Fd, Fd)
createPipe
        (\(Fd
x, Fd
y) -> Fd -> IO ()
closeFd Fd
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Fd -> IO ()
closeFd Fd
y)
        (\(Fd
x, Fd
y) -> (,) (Handle -> Handle -> (Handle, Handle))
-> IO Handle -> IO (Handle -> (Handle, Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO Handle
fdToHandle Fd
x IO (Handle -> (Handle, Handle)) -> IO Handle -> IO (Handle, Handle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fd -> IO Handle
fdToHandle Fd
y)
    cleanupPipes :: (Handle, Handle) -> IO ()
cleanupPipes (Handle
x, Handle
y) = Handle -> IO ()
hClose Handle
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
y

    usePipes :: (Handle, Handle) -> IO ProcessHandle
usePipes pipes :: (Handle, Handle)
pipes@(Handle
readerH, Handle
writerH) = do
        (Maybe Handle
min, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess :: CmdSpec
-> Maybe String
-> Maybe [(String, String)]
-> StdStream
-> StdStream
-> StdStream
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe GroupID
-> Maybe UserID
-> Bool
-> CreateProcess
CreateProcess
            { cmdspec :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand (ByteString -> String
S8.unpack ByteString
cmd) ((ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
S8.unpack [ByteString]
args)
            , cwd :: Maybe String
cwd = ByteString -> String
S8.unpack (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mwdir
            , env :: Maybe [(String, String)]
env = ((ByteString, ByteString) -> (String, String))
-> [(ByteString, ByteString)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
S8.unpack (ByteString -> String)
-> (ByteString -> String)
-> (ByteString, ByteString)
-> (String, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> String
S8.unpack) ([(ByteString, ByteString)] -> [(String, String)])
-> Maybe [(ByteString, ByteString)] -> Maybe [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(ByteString, ByteString)]
menv
            , std_in :: StdStream
std_in = StdStream
-> (ConduitM () ByteString IO () -> StdStream)
-> Maybe (ConduitM () ByteString IO ())
-> StdStream
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
Inherit (StdStream -> ConduitM () ByteString IO () -> StdStream
forall a b. a -> b -> a
const StdStream
CreatePipe) Maybe (ConduitM () ByteString IO ())
mstdin
            , std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
writerH
            , std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
writerH
            , close_fds :: Bool
close_fds = Bool
True
            , create_group :: Bool
create_group = Bool
True
#if MIN_VERSION_process(1, 5, 0)
            , use_process_jobs :: Bool
use_process_jobs = Bool
False
#endif
#if MIN_VERSION_process(1, 2, 0)
            , delegate_ctlc :: Bool
delegate_ctlc = Bool
False
#endif
#if MIN_VERSION_process(1, 3, 0)
            , detach_console :: Bool
detach_console = Bool
True
            , create_new_console :: Bool
create_new_console = Bool
False
            , new_session :: Bool
new_session = Bool
True
#endif
#if MIN_VERSION_process(1, 4, 0)
            , child_group :: Maybe GroupID
child_group = Maybe GroupID
forall a. Maybe a
Nothing
            , child_user :: Maybe UserID
child_user = Maybe UserID
forall a. Maybe a
Nothing
#endif
            }
        IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Handle, Handle) -> ProcessHandle -> IO ()
addAttachMessage (Handle, Handle)
pipes ProcessHandle
ph
        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
$ IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitM () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
readerH ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ByteString -> IO ()) -> ConduitM ByteString Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ ByteString -> IO ()
rlog) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
readerH
        case (Maybe Handle
min, Maybe (ConduitM () ByteString IO ())
mstdin) of
            (Just Handle
h, Just ConduitM () ByteString IO ()
source) -> 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
$ IO () -> IO ()
ignoreExceptions (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                (ConduitT () Void IO () -> IO ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO () -> IO ())
-> ConduitT () Void IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
source ConduitM () ByteString IO ()
-> ConduitM ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Handle -> ConduitM ByteString Void IO ()
forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
h
            (Maybe Handle
Nothing, Maybe (ConduitM () ByteString IO ())
Nothing) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (Maybe Handle, Maybe (ConduitM () ByteString IO ()))
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"
        ProcessHandle -> IO ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
ph

    addAttachMessage :: (Handle, Handle) -> ProcessHandle -> IO ()
addAttachMessage (Handle, Handle)
pipes ProcessHandle
ph = ProcessHandle -> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
withProcessHandle_ ProcessHandle
ph ((ProcessHandle__ -> IO ProcessHandle__) -> IO ())
-> (ProcessHandle__ -> IO ProcessHandle__) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ -> do
        UTCTime
now <- IO UTCTime
getCurrentTime
        case ProcessHandle__
p_ of
            ClosedHandle ExitCode
ec -> do
                ByteString -> IO ()
rlog (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
now
                    , ByteString
": Process immediately died with exit code "
                    , String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
ec
                    , ByteString
"\n\n"
                    ]
                (Handle, Handle) -> IO ()
cleanupPipes (Handle, Handle)
pipes
            OpenHandle PHANDLE
h -> do
                ByteString -> IO ()
rlog (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
now
                    , ByteString
": Attached new process "
                    , String -> ByteString
S8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ PHANDLE -> String
forall a. Show a => a -> String
show PHANDLE
h
                    , ByteString
"\n\n"
                    ]
        ProcessHandle__ -> IO ProcessHandle__
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_

data Status = NeedsRestart | NoRestart | Running ProcessHandle

-- | Run the given command, restarting if the process dies.
monitorProcess
    :: (ByteString -> IO ()) -- ^ log
    -> ProcessTracker
    -> Maybe S8.ByteString -- ^ setuid
    -> S8.ByteString -- ^ executable
    -> S8.ByteString -- ^ working directory
    -> [S8.ByteString] -- ^ command line parameter
    -> [(S8.ByteString, S8.ByteString)] -- ^ environment
    -> (ByteString -> IO ())
    -> (ExitCode -> IO Bool) -- ^ should we restart?
    -> IO MonitoredProcess
monitorProcess :: (ByteString -> IO ())
-> ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> IO MonitoredProcess
monitorProcess ByteString -> IO ()
log ProcessTracker
processTracker Maybe ByteString
msetuid ByteString
exec ByteString
dir [ByteString]
args [(ByteString, ByteString)]
env' ByteString -> IO ()
rlog ExitCode -> IO Bool
shouldRestart = do
    MVar Status
mstatus <- Status -> IO (MVar Status)
forall a. a -> IO (MVar a)
newMVar Status
NeedsRestart
    let loop :: Maybe UTCTime -> IO ()
loop Maybe UTCTime
mlast = do
            IO ()
next <- MVar Status -> (Status -> IO (Status, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Status
mstatus ((Status -> IO (Status, IO ())) -> IO (IO ()))
-> (Status -> IO (Status, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Status
status ->
                case Status
status of
                    Status
NoRestart -> (Status, IO ()) -> IO (Status, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NoRestart, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                    Status
_ -> do
                        UTCTime
now <- IO UTCTime
getCurrentTime
                        case Maybe UTCTime
mlast of
                            Just UTCTime
last | UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
last NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
5 -> do
                                ByteString -> IO ()
log (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Process restarting too quickly, waiting before trying again: " ByteString -> ByteString -> ByteString
`S8.append` ByteString
exec
                                Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
                            Maybe UTCTime
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        let (ByteString
cmd, [ByteString]
args') =
                                case Maybe ByteString
msetuid of
                                    Maybe ByteString
Nothing -> (ByteString
exec, [ByteString]
args)
                                    Just ByteString
setuid -> (ByteString
"sudo", ByteString
"-E" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
"-u" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
setuid ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
"--" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
exec ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
args)
                        Either SomeException ProcessHandle
res <- IO ProcessHandle -> IO (Either SomeException ProcessHandle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ProcessHandle -> IO (Either SomeException ProcessHandle))
-> IO ProcessHandle -> IO (Either SomeException ProcessHandle)
forall a b. (a -> b) -> a -> b
$ ByteString
-> [ByteString]
-> Maybe [(ByteString, ByteString)]
-> Maybe ByteString
-> Maybe (ConduitM () ByteString IO ())
-> (ByteString -> IO ())
-> IO ProcessHandle
forkExecuteLog
                            ByteString
cmd
                            [ByteString]
args'
                            ([(ByteString, ByteString)] -> Maybe [(ByteString, ByteString)]
forall a. a -> Maybe a
Just [(ByteString, ByteString)]
env')
                            (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
dir)
                            (ConduitM () ByteString IO ()
-> Maybe (ConduitM () ByteString IO ())
forall a. a -> Maybe a
Just (ConduitM () ByteString IO ()
 -> Maybe (ConduitM () ByteString IO ()))
-> ConduitM () ByteString IO ()
-> Maybe (ConduitM () ByteString IO ())
forall a b. (a -> b) -> a -> b
$ () -> ConduitM () ByteString IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                            ByteString -> IO ()
rlog
                        case Either SomeException ProcessHandle
res of
                            Left SomeException
e -> do
                                ByteString -> IO ()
log (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Data.Conduit.Process.Unix.monitorProcess: " ByteString -> ByteString -> ByteString
`S8.append` String -> ByteString
S8.pack (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))
                                (Status, IO ()) -> IO (Status, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NeedsRestart, () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                            Right ProcessHandle
pid -> do
                                ByteString -> IO ()
log (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Process created: " ByteString -> ByteString -> ByteString
`S8.append` ByteString
exec
                                (Status, IO ()) -> IO (Status, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle -> Status
Running ProcessHandle
pid, do
                                    TrackedProcess ProcessTracker
_ IORef MaybePid
_ IO ExitCode
wait <- ProcessTracker -> ProcessHandle -> IO TrackedProcess
trackProcess ProcessTracker
processTracker ProcessHandle
pid
                                    ExitCode
ec <- IO ExitCode
wait
                                    Bool
shouldRestart' <- ExitCode -> IO Bool
shouldRestart ExitCode
ec
                                    if Bool
shouldRestart'
                                        then Maybe UTCTime -> IO ()
loop (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now)
                                        else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            IO ()
next
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> IO ()
loop Maybe UTCTime
forall a. Maybe a
Nothing
    MonitoredProcess -> IO MonitoredProcess
forall (m :: * -> *) a. Monad m => a -> m a
return (MonitoredProcess -> IO MonitoredProcess)
-> MonitoredProcess -> IO MonitoredProcess
forall a b. (a -> b) -> a -> b
$ MVar Status -> MonitoredProcess
MonitoredProcess MVar Status
mstatus

-- | Abstract type containing information on a process which will be restarted.
newtype MonitoredProcess = MonitoredProcess (MVar Status)

printStatus :: MonitoredProcess -> IO Text
printStatus :: MonitoredProcess -> IO Text
printStatus (MonitoredProcess MVar Status
mstatus) = do
  Maybe Status
mStatus <- MVar Status -> IO (Maybe Status)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar Status
mstatus
  case Maybe Status
mStatus of
    Maybe Status
Nothing -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"no status set process"
    Just Status
NeedsRestart -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"needs-restart process"
    Just Status
NoRestart -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"no-restart process"
    Just (Running ProcessHandle
running) -> do
      Maybe PHANDLE
x <- ProcessHandle -> IO (Maybe PHANDLE)
getPid ProcessHandle
running
      case Maybe PHANDLE
x of
        Just PHANDLE
y -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"running process '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (PHANDLE -> String
forall a. Show a => a -> String
show PHANDLE
y) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")
        Maybe PHANDLE
Nothing -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"just closed process"

-- | Terminate the process and prevent it from being restarted.
terminateMonitoredProcess :: MonitoredProcess -> IO ()
terminateMonitoredProcess :: MonitoredProcess -> IO ()
terminateMonitoredProcess (MonitoredProcess MVar Status
mstatus) = do
    Status
status <- MVar Status -> Status -> IO Status
forall a. MVar a -> a -> IO a
swapMVar MVar Status
mstatus Status
NoRestart
    case Status
status of
        Running ProcessHandle
pid -> do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid
            Int -> IO ()
threadDelay Int
1000000
            ProcessHandle -> IO ()
killProcess ProcessHandle
pid
        Status
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()