diff --git a/core-program.cabal b/core-program.cabal --- a/core-program.cabal +++ b/core-program.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: core-program -version: 0.6.7.1 +version: 0.6.8.0 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. @@ -68,6 +68,7 @@ , hourglass , mtl , prettyprinter >=1.6.2 + , process , safe-exceptions , stm , template-haskell >=2.14 && <3 diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs --- a/lib/Core/Program/Execute.hs +++ b/lib/Core/Program/Execute.hs @@ -93,6 +93,7 @@ -- * Running processes , readProcess + , callProcess , execProcess_ -- * Internals @@ -140,6 +141,7 @@ import Control.Exception qualified as Base (throwIO) import Control.Exception.Safe qualified as Safe ( catch + , onException , throw ) import Control.Monad @@ -178,8 +180,17 @@ ( findExecutable ) import System.Exit (ExitCode (..)) +import System.IO qualified as Base (IOMode (ReadMode), hClose, openFile) import System.Posix.Internals (hostIsThreaded) import System.Posix.Process qualified as Posix (executeFile, exitImmediately) +import System.Process qualified as Base + ( CreateProcess (std_err, std_in, std_out) + , StdStream (Inherit, UseHandle) + , createProcess + , proc + , terminateProcess + , waitForProcess + ) import System.Process.Typed qualified as Typed (nullStream, proc, readProcess, setStdin) import Prelude hiding (log) @@ -783,6 +794,79 @@ -- does not return _ <- Posix.executeFile cmd' True args' Nothing pure () + +{- | +Execute an external child process and wait for it to finish. The command is +specified first and and subsequent arguments as elements of the list. This +helper then logs the command being executed to the debug output, which can be +useful when you're trying to find out what exactly what program is being +invoked. + +The output of the child process (its @stdout@) will go to the terminal console +independently of your parent process's output. If your Haskell program does +anything concurrently then anything it 'Core.Program.Logging.write's will be +interleaved and probably make a mess of the child's output. So don't do that. + +See the similar 'readProcess' for an action which executes an external program +but which returns its output. + +If the thread invoking 'callProcess' receives an interrupting asynchronous +exception then it will terminate the child, waiting for it to exit. + +(this wraps __typed-process__'s 'System.Process.Typed.runProcess' but follows +the naming convention of the underlying 'System.Process.callProcess' code from +__process__.) + +@since 0.6.8 +-} +callProcess :: [Rope] -> Program τ ExitCode +callProcess [] = error "No command provided" +callProcess (cmd : args) = do + let cmd' = fromRope cmd + let args' = fmap fromRope args + let task1 = Base.proc cmd' args' + + let command = mconcat (List.intersperse (singletonRope ' ') (cmd : args)) + debug "command" command + + probe <- liftIO $ do + findExecutable cmd' + + case probe of + Nothing -> do + Safe.throw (CommandNotFound cmd) + Just _ -> do + liftIO $ do + i <- Base.openFile "/dev/null" Base.ReadMode + + let task2 = + task1 + { Base.std_in = Base.UseHandle i + , Base.std_out = Base.Inherit + , Base.std_err = Base.Inherit + } + + (_, _, _, p) <- Base.createProcess task2 + + Safe.onException + ( do + exit <- Base.waitForProcess p + Base.hClose i + pure exit + ) + ( do + -- + -- To avoid defunct zombie processes, you have to + -- wait() on the process and read its exit code. In + -- normal circumstances this happens because we are + -- _waiting_ but in abnormal circumstances where we + -- are forcing the child, we have to wait for the OS + -- to give us an exit code. + -- + Base.terminateProcess p + _ <- Base.waitForProcess p + Base.hClose i + ) {- | Reset the start time (used to calculate durations shown in event- and diff --git a/lib/Core/Program/Threads.hs b/lib/Core/Program/Threads.hs --- a/lib/Core/Program/Threads.hs +++ b/lib/Core/Program/Threads.hs @@ -44,10 +44,11 @@ -- * Internals , Thread , unThread + , Terminator (..) ) where import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar) +import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, tryPutMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVarIO) import Control.Exception.Safe qualified as Safe (catch, finally, onException, throw) @@ -354,6 +355,14 @@ {- | Cancel a thread. +Be careful when using this. If you are planning cancel a worker thread then +the main thread that is 'waitThread'ing on it will /throw an exception/, +specifically 'ThreadCancelled' (unless something else has already thrown an +exception in which case /that/ will be thrown instead). In this scenario you +will need to 'Core.Program.Exceptions.catch' around your waiting function +otherwise the uncaught exception will continue to unwind your execution stack +and probably end your program. + (this wraps __base__\'s 'Control.Concurrent.killThread'. The underlying mechanism used is to throw the 'GHC.Conc.ThreadKilled' exception to the other thread. That exception is asynchronous, so will not be trapped by a @@ -365,7 +374,40 @@ cancelThread :: Thread α -> Program τ () cancelThread thread = do liftIO $ do - killThread (threadPointerOf thread) + -- + -- There are some curiosities about what happens here. Someone + -- waitThread'ing on a Thread is blocked on reading the outcome MVar. + -- so to break that wait we put the Left value in. If the thread was + -- already dead this has no effect, but if not, then this will + -- initiate it rapidly being killing off. + -- + let outcome = threadOutcomeOf thread + result <- tryPutMVar outcome (Left (toException ThreadCancelled)) + case result of + False -> do + pure () + True -> do + killThread (threadPointerOf thread) + +{- | +When a thread is aborted with 'cancelThread' this value is used to mark a +failed computation inside the 'Thread'. Although it is not the mechanism used +internally to kill the computation, it /is/ the exception that is subsequently +rethrown from 'waitThread' if you are waiting on that thread to finish, +allowing you to 'Core.Program.Exceptions.catch' the case of a thread being +cancelled if necessary. + +This is mostly here to differentiate from 'Control.Exception.ThreadKilled', +giving you some knowledge as to whether it was your explicit 'cancelThread' +that ended the thread, or something else. You need to handle it either way, +but sometimes you want to know the difference. + +@since 0.6.8 +-} +data Terminator = ThreadCancelled + deriving (Show) + +instance Exception Terminator {- | Fork two threads and wait for both to finish. The return value is the pair of