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

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           Data.Text.Encoding              (decodeUtf8)
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           Control.Monad.IO.Class
import           Control.Monad.IO.Unlift
import           Control.Monad.Logger            
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 = 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 forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ ->
    case ProcessHandle__
p_ of
        ClosedHandle ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_
        OpenHandle Pid
h -> do
            CInt -> Pid -> IO ()
signalProcess CInt
sigKILL Pid
h
            forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_

ignoreExceptions :: IO () -> IO ()
ignoreExceptions :: IO () -> IO ()
ignoreExceptions = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
_ :: SomeException) -> 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
    CInt
i <- IO CInt
c_launch_process_tracker
    if CInt
i forall a. Eq a => a -> a -> Bool
== -CInt
1
        then forall e a. Exception e => e -> IO a
throwIO ProcessTrackerException
CannotLaunchProcessTracker
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! CInt -> ProcessTracker
ProcessTracker CInt
i

-- | Since 0.2.1
data ProcessTrackerException = CannotLaunchProcessTracker
    deriving (Int -> ProcessTrackerException -> ShowS
[ProcessTrackerException] -> ShowS
ProcessTrackerException -> String
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 = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    ProcessHandle__
mpid <- forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ ProcessHandle -> MVar ProcessHandle__
processHandleMVar ProcessHandle
ph
    MaybePid
mpid' <- case ProcessHandle__
mpid of
        ClosedHandle{} -> forall (m :: * -> *) a. Monad m => a -> m a
return MaybePid
NoPid
        OpenHandle Pid
pid -> do
            ProcessTracker -> Pid -> CInt -> IO ()
c_track_process ProcessTracker
pt Pid
pid CInt
1
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pid -> MaybePid
Pid Pid
pid
    IORef MaybePid
ipid <- forall a. a -> IO (IORef a)
newIORef MaybePid
mpid'
    MVar ExitCode
baton <- forall a. IO (MVar a)
newEmptyMVar
    let tp :: TrackedProcess
tp = ProcessTracker -> IORef MaybePid -> IO ExitCode -> TrackedProcess
TrackedProcess ProcessTracker
pt IORef MaybePid
ipid (forall a. MVar a -> IO a
takeMVar MVar ExitCode
baton)
    case MaybePid
mpid' of
        MaybePid
NoPid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Pid Pid
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
            ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
baton
            TrackedProcess -> IO ()
untrackProcess TrackedProcess
tp
    forall (m :: * -> *) a. Monad m => a -> m a
return 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
_) = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
    MaybePid
mpid <- forall a. IORef a -> IO a
readIORef IORef MaybePid
ipid
    case MaybePid
mpid of
        MaybePid
NoPid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Pid Pid
pid -> do
            ProcessTracker -> Pid -> CInt -> IO ()
c_track_process ProcessTracker
pt Pid
pid CInt
0
            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 ()
log = 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 = 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 forall a b. IO a -> IO b -> IO a
`finally` Fd -> IO ()
closeFd Fd
y)
        (\(Fd
x, Fd
y) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO Handle
fdToHandle Fd
x 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 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 :: CmdSpec
cmdspec = String -> [String] -> CmdSpec
RawCommand (ByteString -> String
S8.unpack ByteString
cmd) (forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
S8.unpack [ByteString]
args)
            , cwd :: Maybe String
cwd = ByteString -> String
S8.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mwdir
            , env :: Maybe [(String, String)]
env = forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
S8.unpack forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> String
S8.unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [(ByteString, ByteString)]
menv
            , std_in :: StdStream
std_in = forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
Inherit (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 = forall a. Maybe a
Nothing
            , child_user :: Maybe UserID
child_user = forall a. Maybe a
Nothing
#endif
            }
        IO () -> IO ()
ignoreExceptions forall a b. (a -> b) -> a -> b
$ (Handle, Handle) -> ProcessHandle -> IO ()
addAttachMessage (Handle, Handle)
pipes ProcessHandle
ph
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreExceptions forall a b. (a -> b) -> a -> b
$
            (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
readerH forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ ByteString -> IO ()
log) 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) -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
ignoreExceptions forall a b. (a -> b) -> a -> b
$
                (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
source forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h) forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
h
            (Maybe Handle
Nothing, Maybe (ConduitM () ByteString IO ())
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (Maybe Handle, Maybe (ConduitM () ByteString IO ()))
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"
        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 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 ()
log forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UTCTime
now
                    , ByteString
": Process immediately died with exit code "
                    , String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ExitCode
ec
                    , ByteString
"\n\n"
                    ]
                (Handle, Handle) -> IO ()
cleanupPipes (Handle, Handle)
pipes
            OpenHandle Pid
h -> do
                ByteString -> IO ()
log forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UTCTime
now
                    , ByteString
": Attached new process "
                    , String -> ByteString
S8.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Pid
h
                    , ByteString
"\n\n"
                    ]
        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
    :: (MonadUnliftIO m, MonadLogger m)
    => 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?
    -> m MonitoredProcess
monitorProcess :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
ProcessTracker
-> Maybe ByteString
-> ByteString
-> ByteString
-> [ByteString]
-> [(ByteString, ByteString)]
-> (ByteString -> IO ())
-> (ExitCode -> IO Bool)
-> m MonitoredProcess
monitorProcess ProcessTracker
processTracker Maybe ByteString
msetuid ByteString
exec ByteString
dir [ByteString]
args [(ByteString, ByteString)]
env' ByteString -> IO ()
rlog ExitCode -> IO Bool
shouldRestart =
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
rio -> do
        MVar Status
mstatus <- forall a. a -> IO (MVar a)
newMVar Status
NeedsRestart
        let loop :: Maybe UTCTime -> IO ()
loop Maybe UTCTime
mlast = do
                IO ()
next <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Status
mstatus forall a b. (a -> b) -> a -> b
$ \Status
status ->
                    case Status
status of
                        Status
NoRestart -> forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NoRestart, 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 forall a. Ord a => a -> a -> Bool
< NominalDiffTime
5 -> do
                                    forall a. m a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logWarn forall a b. (a -> b) -> a -> b
$ Text
"Process restarting too quickly, waiting before trying again: " forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 ByteString
exec
                                    Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
5 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
                                Maybe UTCTime
_ -> 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" forall a. a -> [a] -> [a]
: ByteString
"-u" forall a. a -> [a] -> [a]
: ByteString
setuid forall a. a -> [a] -> [a]
: ByteString
"--" forall a. a -> [a] -> [a]
: ByteString
exec forall a. a -> [a] -> [a]
: [ByteString]
args)
                            Either SomeException ProcessHandle
res <- forall e a. Exception e => IO a -> IO (Either e a)
try 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'
                                (forall a. a -> Maybe a
Just [(ByteString, ByteString)]
env')
                                (forall a. a -> Maybe a
Just ByteString
dir)
                                (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                ByteString -> IO ()
rlog
                            case Either SomeException ProcessHandle
res of
                                Left SomeException
e -> do
                                    forall a. m a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logError forall a b. (a -> b) -> a -> b
$ Text
"Data.Conduit.Process.Unix.monitorProcess: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show (SomeException
e :: SomeException))
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NeedsRestart, forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                Right ProcessHandle
pid -> do
                                    forall a. m a -> IO a
rio forall a b. (a -> b) -> a -> b
$ $Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
pack :: String -> Text
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Process created: " forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 ByteString
exec
                                    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 (forall a. a -> Maybe a
Just UTCTime
now)
                                            else forall (m :: * -> *) a. Monad m => a -> m a
return ())
                IO ()
next
        ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> IO ()
loop forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar Status
mstatus
  case Maybe Status
mStatus of
    Maybe Status
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"no status set process"
    Just Status
NeedsRestart -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"needs-restart process"
    Just Status
NoRestart -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"no-restart process"
    Just (Running ProcessHandle
running) -> do
      Maybe Pid
x <- ProcessHandle -> IO (Maybe Pid)
getPid ProcessHandle
running
      case Maybe Pid
x of
        Just Pid
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"running process '" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Pid
y) forall a. Semigroup a => a -> a -> a
<> Text
"'")
        Maybe Pid
Nothing -> 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 <- 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()