{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 Control.Applicative (pure, (<$>), (<*>))
import Control.Arrow ((***))
import Control.Concurrent (forkIO, 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, when)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as S8
import Data.Conduit (ConduitM, runConduit, (.|))
import Data.Conduit.Binary (sinkHandle, sourceHandle)
import Data.Conduit.List qualified as CL
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8)
import Data.Time (diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import Foreign.C.Types
import Prelude
       ( Bool(..)
       , Either(..)
       , IO
       , Maybe(..)
       , Monad(..)
       , Show
       , String
       , 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
       , getPid
       , terminateProcess
       , waitForProcess
       )
import System.Process.Internals (ProcessHandle(..), ProcessHandle__(..))

processHandleMVar :: ProcessHandle -> MVar ProcessHandle__
processHandleMVar :: ProcessHandle -> MVar ProcessHandle__
processHandleMVar (ProcessHandle MVar ProcessHandle__
m Bool
_ MVar ()
_) = MVar ProcessHandle__
m

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

-- | 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_
  OpenHandle Pid
h -> do
    CInt -> Pid -> IO ()
signalProcess CInt
sigKILL Pid
h
    ProcessHandle__ -> IO ProcessHandle__
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle__
p_
  ProcessHandle__
_ -> [Char] -> IO ProcessHandle__
forall a. HasCallStack => [Char] -> a
error [Char]
"Not implemented"

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 a. a -> IO a
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1
        then ProcessTrackerException -> IO ProcessTracker
forall e a. Exception e => e -> IO a
throwIO ProcessTrackerException
CannotLaunchProcessTracker
        else ProcessTracker -> IO ProcessTracker
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessTracker -> IO ProcessTracker)
-> ProcessTracker -> IO ProcessTracker
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 -> [Char]
(Int -> ProcessTrackerException -> ShowS)
-> (ProcessTrackerException -> [Char])
-> ([ProcessTrackerException] -> ShowS)
-> Show ProcessTrackerException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProcessTrackerException -> ShowS
showsPrec :: Int -> ProcessTrackerException -> ShowS
$cshow :: ProcessTrackerException -> [Char]
show :: ProcessTrackerException -> [Char]
$cshowList :: [ProcessTrackerException] -> ShowS
showList :: [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 a. a -> IO a
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
            MaybePid -> IO MaybePid
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybePid -> IO MaybePid) -> MaybePid -> IO MaybePid
forall a b. (a -> b) -> a -> b
$ Pid -> MaybePid
Pid Pid
pid
        ProcessHandle__
_ -> [Char] -> IO MaybePid
forall a. HasCallStack => [Char] -> a
error [Char]
"Not implemented"
    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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Pid Pid
_ -> 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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 a. a -> IO a
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
            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 ()
log = 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 a b. IO (a -> b) -> IO a -> IO b
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 :: CmdSpec
cmdspec = [Char] -> [[Char]] -> CmdSpec
RawCommand (ByteString -> [Char]
S8.unpack ByteString
cmd) ((ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
S8.unpack [ByteString]
args)
            , cwd :: Maybe [Char]
cwd = ByteString -> [Char]
S8.unpack (ByteString -> [Char]) -> Maybe ByteString -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mwdir
            , env :: Maybe [([Char], [Char])]
env = ((ByteString, ByteString) -> ([Char], [Char]))
-> [(ByteString, ByteString)] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> [Char]
S8.unpack (ByteString -> [Char])
-> (ByteString -> [Char])
-> (ByteString, ByteString)
-> ([Char], [Char])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> [Char]
S8.unpack) ([(ByteString, ByteString)] -> [([Char], [Char])])
-> Maybe [(ByteString, ByteString)] -> Maybe [([Char], [Char])]
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
            , use_process_jobs :: Bool
use_process_jobs = Bool
False
            , delegate_ctlc :: Bool
delegate_ctlc = Bool
False
            , detach_console :: Bool
detach_console = Bool
True
            , create_new_console :: Bool
create_new_console = Bool
False
            , new_session :: Bool
new_session = Bool
True
            , 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
            }
        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 (Handle -> ConduitM () ByteString IO ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
readerH ConduitM () ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> IO ()) -> ConduitT ByteString Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ ByteString -> IO ()
log) 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 (ConduitM () ByteString IO ()
source ConduitM () ByteString IO ()
-> ConduitT ByteString Void IO () -> ConduitT () Void IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Handle -> ConduitT 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (Maybe Handle, Maybe (ConduitM () ByteString IO ()))
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"
        ProcessHandle -> IO ProcessHandle
forall a. a -> IO a
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 ()
log (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , [Char] -> ByteString
S8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
now
                    , ByteString
": Process immediately died with exit code "
                    , [Char] -> ByteString
S8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ ExitCode -> [Char]
forall a. Show a => a -> [Char]
show ExitCode
ec
                    , ByteString
"\n\n"
                    ]
                (Handle, Handle) -> IO ()
cleanupPipes (Handle, Handle)
pipes
            OpenHandle Pid
h -> do
                ByteString -> IO ()
log (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat
                    [ ByteString
"\n\n"
                    , [Char] -> ByteString
S8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> [Char]
forall a. Show a => a -> [Char]
show UTCTime
now
                    , ByteString
": Attached new process "
                    , [Char] -> ByteString
S8.pack ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ Pid -> [Char]
forall a. Show a => a -> [Char]
show Pid
h
                    , ByteString
"\n\n"
                    ]
            ProcessHandle__
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Not implemented"
        ProcessHandle__ -> IO ProcessHandle__
forall a. a -> IO a
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 a. m a -> IO a) -> IO MonitoredProcess)
-> m MonitoredProcess
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO MonitoredProcess)
 -> m MonitoredProcess)
-> ((forall a. m a -> IO a) -> IO MonitoredProcess)
-> m MonitoredProcess
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
rio -> 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
$ \case
                Status
NoRestart -> (Status, IO ()) -> IO (Status, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NoRestart, () -> IO ()
forall a. a -> IO a
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
                            m () -> IO ()
forall a. m a -> IO a
rio (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logWarn (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Process restarting too quickly, waiting before trying again: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 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 a. a -> IO a
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 a. a -> ConduitT () ByteString IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                        ByteString -> IO ()
rlog
                    case Either SomeException ProcessHandle
res of
                        Left SomeException
e -> do
                            m () -> IO ()
forall a. m a -> IO a
rio (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Data.Conduit.Process.Unix.monitorProcess: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (SomeException -> [Char]
forall a. Show a => a -> [Char]
show (SomeException
e :: SomeException))
                            (Status, IO ()) -> IO (Status, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
NeedsRestart, () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                        Right ProcessHandle
pid -> do
                            m () -> IO ()
forall a. m a -> IO a
rio (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ $Int
[Char]
LogLevel
[Char] -> Text
[Char] -> [Char] -> [Char] -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall msg. ToLogStr msg => Loc -> Text -> LogLevel -> msg -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: [Char] -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Process created: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 ByteString
exec
                            (Status, IO ()) -> IO (Status, IO ())
forall a. a -> IO a
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
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRestart' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> IO ()
loop (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now))
              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 a. a -> IO a
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
{-# ANN monitorProcess ("HLint: ignore Use join" :: String) #-}

-- | 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"no status set process"
    Just Status
NeedsRestart -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"needs-restart process"
    Just Status
NoRestart -> Text -> IO Text
forall a. a -> IO a
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 -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"running process '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (Pid -> [Char]
forall a. Show a => a -> [Char]
show Pid
y) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")
        Maybe Pid
Nothing -> Text -> IO Text
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()