@@ -5,12 +5,17 @@
55module OddJobs.Cli where
66
77import Options.Applicative as Opts
8+import Control.Concurrent.Async (race)
9+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar)
10+import Data.Coerce (coerce)
11+import Data.Functor (void)
812import Data.Text
913import OddJobs.Job (startJobRunner, Config(..), LogLevel(..), LogEvent(..))
1014import OddJobs.Types (UIConfig(..), Seconds(..), delaySeconds)
11−import qualified System.Posix.Daemon as Daemon
12−import System.FilePath (FilePath)
15+import qualified System.Posix.Daemonize as Daemonize
16+import System.FilePath (FilePath, takeBaseName, takeDirectory)
1317import System.Posix.Process (getProcessID)
18+import System.Posix.Signals (Handler(CatchOnce), installHandler, sigTERM)
1419import qualified System.Directory as Dir
1520import qualified System.Exit as Exit
1621import System.Environment (getProgName)
@@ -100,6 +105,33 @@ runCli cliType = do
100105 Status ->
101106 Prelude.error "not implemented yet"
102107
108+-- | Ensure that @SIGTERM@ is handled gracefully, because it's how containers are stopped.
109+--
110+-- @action@ will receive an 'AsyncCancelled' exception if @SIGTERM@ is received by the process.
111+--
112+-- Typical use:
113+--
114+-- > main :: IO ()
115+-- > main = withGracefulTermination_ $ do
116+--
117+-- Note that although the Haskell runtime handles @SIGINT@ it doesn't do anything with @SIGTERM@.
118+-- Therefore, the program will be killed immediately and no cleanup will be performed. In particular,
119+-- exception handlers in `bracket`, `finally`, `onException`, etc. won't be run. However, if the
120+-- program is running as PID 1 in a container, @SIGTERM@ will be ignored and the program will keep
121+-- running. This will likely result in a @SIGKILL@ being sent a short while later and cleanup still
122+-- won't be performed.
123+withGracefulTermination :: IO a -> IO (Maybe a)
124+withGracefulTermination ioAction = do
125+ var <- newEmptyMVar
126+ let terminate = void $ tryPutMVar var ()
127+ waitForTermination = takeMVar var
128+ void $ installHandler sigTERM (CatchOnce terminate) Nothing
129+ either (const Nothing) Just <$> race waitForTermination ioAction
130+
131+-- | Like 'withGracefulTermination' but ignoring the return value
132+withGracefulTermination_ :: IO a -> IO ()
133+withGracefulTermination_ = void . withGracefulTermination
134+
103135{-| Used by 'defaultMain' if the 'Start' command is issued via the CLI. If
104136@--daemonize@ switch is also passed, it checks for 'startPidFile':
105137
@@ -115,7 +147,12 @@ defaultStartCommand :: CommonStartArgs
115147 -> IO ()
116148defaultStartCommand CommonStartArgs{..} mUIArgs cliType = do
117149 if startDaemonize then do
118− Daemon.runDetached (Just startPidFile) (Daemon.ToFile "/tmp/oddjobs.out") coreStartupFn
150+ Daemonize.serviced
151+ $ Daemonize.simpleDaemon
152+ { Daemonize.program = \() -> withGracefulTermination_ coreStartupFn
153+ , Daemonize.name = Just $ takeBaseName startPidFile
154+ , Daemonize.pidfileDirectory = Just $ takeDirectory startPidFile
155+ }
119156 else
120157 coreStartupFn
121158 where
@@ -154,7 +191,7 @@ defaultWebUI UIStartArgs{..} uicfg@UIConfig{..} = do
154191 Warp.run uistartPort $ Servant.serveWithContext api ctx app
155192
156193{-| Used by 'defaultMain' if 'Stop' command is issued via the CLI. Sends a
157−@SIGINT@ signal to the process indicated by 'shutPidFile'. Waits for a maximum
194+@SIGTERM@ signal to the process indicated by 'shutPidFile'. Waits for a maximum
158195of 'shutTimeout' seconds (controller by @--timeout@) for the daemon to shutdown
159196gracefully, after which a @SIGKILL@ is issued
160197-}
@@ -162,26 +199,15 @@ defaultStopCommand :: StopArgs
162199 -> IO ()
163200defaultStopCommand StopArgs{..} = do
164201 progName <- getProgName
165− if shutTimeout == Seconds 0
166− then Daemon.brutalKill shutPidFile
167− else do putStrLn $ "Sending sigINT to " <> show progName <>
202+ putStrLn $ "Sending SIGTERM to " <> show progName <>
168203 " and waiting " <> show (unSeconds shutTimeout) <> " seconds for graceful stop"
169− readFile shutPidFile >>= Sig.signalProcess Sig.sigINT . read
170− Async.race (delaySeconds shutTimeout) checkProcessStatus >>= \case
171− Right _ -> do
172− putStrLn $ progName <> " seems to have exited gracefully."
173− Exit.exitSuccess
174− Left _ -> do
175− putStrLn $ progName <> " has still not exited. Sending sigKILL for forced exit."
176− Daemon.brutalKill shutPidFile
177− where
178− checkProcessStatus = do
179− Daemon.isRunning shutPidFile >>= \case
180− True -> do
181− delaySeconds (Seconds 1)
182− checkProcessStatus
183− False -> do
184− pure ()
204+ flip Daemonize.serviced' Daemonize.Stop
205+ $ Daemonize.simpleDaemon
206+ { Daemonize.name = Just $ takeBaseName shutPidFile
207+ , Daemonize.pidfileDirectory = Just $ takeDirectory shutPidFile
208+ , Daemonize.killWait = Just $ coerce shutTimeout
209+ }
210+
185211
186212-- * Default CLI parsers
187213--
@@ -296,7 +322,7 @@ webUiAuthParser = basicAuthParser <|> noAuthParser
296322-- 'shutTimeout' seconds. If the daemon doesn't shut down cleanly within that
297323-- time, it sends a @SIGKILL@ to kill immediately.
298324data StopArgs = StopArgs
299− { -- | After sending a @SIGINT@, how many seconds to wait before sending a
325+ { -- | After sending a @SIGTERM@, how many seconds to wait before sending a
300326 -- @SIGKILL@
301327 shutTimeout :: !Seconds
302328 -- | PID file of the deamon. Ref: 'pidFileParser'