@@ -5,13 +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 System.Daemonize (DaemonOptions(..), daemonize)
12−import qualified System.Posix.Daemon as Daemon
13−import System.FilePath (FilePath)
15+import qualified System.Posix.Daemonize as Daemonize
16+import System.FilePath (FilePath, takeBaseName, takeDirectory)
1417import System.Posix.Process (getProcessID)
18+import System.Posix.Signals (Handler(CatchOnce), installHandler, sigTERM)
1519import qualified System.Directory as Dir
1620import qualified System.Exit as Exit
1721import System.Environment (getProgName)
@@ -101,6 +105,33 @@ runCli cliType = do
101105 Status ->
102106 Prelude.error "not implemented yet"
103107
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+
104135{-| Used by 'defaultMain' if the 'Start' command is issued via the CLI. If
105136@--daemonize@ switch is also passed, it checks for 'startPidFile':
106137
@@ -116,7 +147,12 @@ defaultStartCommand :: CommonStartArgs
116147 -> IO ()
117148defaultStartCommand CommonStartArgs{..} mUIArgs cliType = do
118149 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
155+ }
120156 else
121157 coreStartupFn
122158 where
@@ -155,7 +191,7 @@ defaultWebUI UIStartArgs{..} uicfg@UIConfig{..} = do
155191 Warp.run uistartPort $ Servant.serveWithContext api ctx app
156192
157193{-| 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
159195of 'shutTimeout' seconds (controller by @--timeout@) for the daemon to shutdown
160196gracefully, after which a @SIGKILL@ is issued
161197-}
@@ -163,27 +199,15 @@ defaultStopCommand :: StopArgs
163199 -> IO ()
164200defaultStopCommand StopArgs{..} = do
165201 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 <>
170203 " and waiting " <> show (unSeconds shutTimeout) <> " seconds for graceful stop"
171− readFile shutPidFile >>= Sig.signalProcess Sig.sigINT . read
172− Async.race (delaySeconds shutTimeout) checkProcessStatus >>= \case
173− Right _ -> do
174− putStrLn $ progName <> " seems to have exited gracefully."
175− Exit.exitSuccess
176− Left _ -> do
177− putStrLn $ progName <> " has still not exited. Sending sigKILL for forced exit."
178− Daemon.brutalKill shutPidFile
179− where
180− checkProcessStatus = do
181− Daemon.isRunning shutPidFile >>= \case
182− True -> do
183− delaySeconds (Seconds 1)
184− checkProcessStatus
185− False -> do
186− 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+
187211
188212-- * Default CLI parsers
189213--
@@ -298,7 +322,7 @@ webUiAuthParser = basicAuthParser <|> noAuthParser
298322-- 'shutTimeout' seconds. If the daemon doesn't shut down cleanly within that
299323-- time, it sends a @SIGKILL@ to kill immediately.
300324data 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
302326 -- @SIGKILL@
303327 shutTimeout :: !Seconds
304328 -- | PID file of the deamon. Ref: 'pidFileParser'
@@ -310,8 +334,6 @@ stopParser = fmap Stop $ StopArgs
310334 <$> option (Seconds <$> auto) ( long "timeout" <>
311335 metavar "TIMEOUT" <>
312336 help "Maximum seconds to wait before force-killing the background daemon."
313− -- value defaultTimeout <>
314− -- showDefaultWith (show . unSeconds)
315337 )
316338 <*> pidFileParser
317339
@@ -344,16 +366,6 @@ defaultCliInfo :: CliType -> ParserInfo Args
344366defaultCliInfo cliType =
345367 info (argParser cliType <**> helper) fullDesc
346368
347−-- defaultDaemonOptions :: DaemonOptions
348−-- defaultDaemonOptions = DaemonOptions
349−-- { daemonShouldChangeDirectory = False
350−-- , daemonShouldCloseStandardStreams = False
351−-- , daemonShouldIgnoreSignals = True
352−-- , daemonUserToChangeTo = Nothing
353−-- , daemonGroupToChangeTo = Nothing
354−-- }
355−
356−
357369-- ** Auth implementations for the default Web UI
358370
359371-- *** Basic Auth