@@ -5,13 +5,17 @@
5module OddJobs.Cli where
5module OddJobs.Cli where
7import Options.Applicative as Opts
7import 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)
8import Data.Text
12import Data.Text
9import OddJobs.Job (startJobRunner, Config(..), LogLevel(..), LogEvent(..))
13import OddJobs.Job (startJobRunner, Config(..), LogLevel(..), LogEvent(..))
10import OddJobs.Types (UIConfig(..), Seconds(..), delaySeconds)
14import OddJobs.Types (UIConfig(..), Seconds(..), delaySeconds)
11−-- import System.Daemonize (DaemonOptions(..), daemonize)
12−import qualified System.Posix.Daemon as Daemon
15+import qualified System.Posix.Daemonize as Daemonize
13−import System.FilePath (FilePath)
16+import System.FilePath (FilePath, takeBaseName, takeDirectory)
14import System.Posix.Process (getProcessID)
17import System.Posix.Process (getProcessID)
18+import System.Posix.Signals (Handler(CatchOnce), installHandler, sigTERM)
15import qualified System.Directory as Dir
19import qualified System.Directory as Dir
16import qualified System.Exit as Exit
20import qualified System.Exit as Exit
17import System.Environment (getProgName)
21import System.Environment (getProgName)
@@ -101,6 +105,33 @@ runCli cliType = do
101 Status ->
105 Status ->
102 Prelude.error "not implemented yet"
106 Prelude.error "not implemented yet"
108+-- | Ensure that @SIGTERM@ is handled gracefully, because it's how containers are stopped.
110+-- @action@ will receive an 'AsyncCancelled' exception if @SIGTERM@ is received by the process.
115+-- > main = withGracefulTermination_ $ do
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
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
131+-- | Like 'withGracefulTermination' but ignoring the return value
132+withGracefulTermination_ :: IO a -> IO ()
133+withGracefulTermination_ = void . withGracefulTermination
104{-| Used by 'defaultMain' if the 'Start' command is issued via the CLI. If
135{-| Used by 'defaultMain' if the 'Start' command is issued via the CLI. If
105@--daemonize@ switch is also passed, it checks for 'startPidFile':
136@--daemonize@ switch is also passed, it checks for 'startPidFile':
@@ -116,7 +147,12 @@ defaultStartCommand :: CommonStartArgs
117defaultStartCommand CommonStartArgs{..} mUIArgs cliType = do
148defaultStartCommand CommonStartArgs{..} mUIArgs cliType = do
118 if startDaemonize then do
149 if startDaemonize then do
119− 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
121 coreStartupFn
157 coreStartupFn
@@ -155,7 +191,7 @@ defaultWebUI UIStartArgs{..} uicfg@UIConfig{..} = do
155 Warp.run uistartPort $ Servant.serveWithContext api ctx app
191 Warp.run uistartPort $ Servant.serveWithContext api ctx app
157{-| Used by 'defaultMain' if 'Stop' command is issued via the CLI. Sends a
193{-| Used by 'defaultMain' if 'Stop' command is issued via the CLI. Sends a
158−@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
159of 'shutTimeout' seconds (controller by @--timeout@) for the daemon to shutdown
195of 'shutTimeout' seconds (controller by @--timeout@) for the daemon to shutdown
160gracefully, after which a @SIGKILL@ is issued
196gracefully, after which a @SIGKILL@ is issued
@@ -163,27 +199,15 @@ defaultStopCommand :: StopArgs
164defaultStopCommand StopArgs{..} = do
200defaultStopCommand StopArgs{..} = do
165 progName <- getProgName
201 progName <- getProgName
166− -- pid <- read <$> (readFile shutPidFile)
167− if shutTimeout == Seconds 0
168− then Daemon.brutalKill shutPidFile
169− else do putStrLn $ "Sending sigINT to " <> show progName <>
202+ putStrLn $ "Sending SIGTERM to " <> show progName <>
170 " and waiting " <> show (unSeconds shutTimeout) <> " seconds for graceful stop"
203 " and waiting " <> show (unSeconds shutTimeout) <> " seconds for graceful stop"
171− readFile shutPidFile >>= Sig.signalProcess Sig.sigINT . read
204+ flip Daemonize.serviced' Daemonize.Stop
172− Async.race (delaySeconds shutTimeout) checkProcessStatus >>= \case
205+ $ Daemonize.simpleDaemon
173− Right _ -> do
206+ { Daemonize.name = Just $ takeBaseName shutPidFile
174− putStrLn $ progName <> " seems to have exited gracefully."
207+ , Daemonize.pidfileDirectory = Just $ takeDirectory shutPidFile
175− Exit.exitSuccess
208+ , Daemonize.killWait = Just $ coerce shutTimeout
177− putStrLn $ progName <> " has still not exited. Sending sigKILL for forced exit."
210+
178− Daemon.brutalKill shutPidFile
180− checkProcessStatus = do
181− Daemon.isRunning shutPidFile >>= \case
183− delaySeconds (Seconds 1)
188-- * Default CLI parsers
212-- * Default CLI parsers
@@ -298,7 +322,7 @@ webUiAuthParser = basicAuthParser <|> noAuthParser
298-- 'shutTimeout' seconds. If the daemon doesn't shut down cleanly within that
322-- 'shutTimeout' seconds. If the daemon doesn't shut down cleanly within that
299-- time, it sends a @SIGKILL@ to kill immediately.
323-- time, it sends a @SIGKILL@ to kill immediately.
300data StopArgs = StopArgs
324data StopArgs = StopArgs
301− { -- | 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
302 -- @SIGKILL@
326 -- @SIGKILL@
303 shutTimeout :: !Seconds
327 shutTimeout :: !Seconds
304 -- | PID file of the deamon. Ref: 'pidFileParser'
328 -- | PID file of the deamon. Ref: 'pidFileParser'
@@ -310,8 +334,6 @@ stopParser = fmap Stop $ StopArgs
310 <$> option (Seconds <$> auto) ( long "timeout" <>
334 <$> option (Seconds <$> auto) ( long "timeout" <>
311 metavar "TIMEOUT" <>
335 metavar "TIMEOUT" <>
312 help "Maximum seconds to wait before force-killing the background daemon."
336 help "Maximum seconds to wait before force-killing the background daemon."
313− -- value defaultTimeout <>
314− -- showDefaultWith (show . unSeconds)
316 <*> pidFileParser
338 <*> pidFileParser
@@ -344,16 +366,6 @@ defaultCliInfo :: CliType -> ParserInfo Args
344defaultCliInfo cliType =
366defaultCliInfo cliType =
345 info (argParser cliType <**> helper) fullDesc
367 info (argParser cliType <**> helper) fullDesc
347−-- defaultDaemonOptions :: DaemonOptions
348−-- defaultDaemonOptions = DaemonOptions
349−-- { daemonShouldChangeDirectory = False
350−-- , daemonShouldCloseStandardStreams = False
351−-- , daemonShouldIgnoreSignals = True
352−-- , daemonUserToChangeTo = Nothing
353−-- , daemonGroupToChangeTo = Nothing
357-- ** Auth implementations for the default Web UI
369-- ** Auth implementations for the default Web UI
359-- *** Basic Auth
371-- *** Basic Auth