diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for warp-systemd +## 0.3.0.0 -- 2023-06-22 + + * By default, `runSystemdWarp` now installs a shutdown signal handler for `SIGINT` in addition to `SIGTERM`. + + * If you don't want to install a shutdown signal handler, use the new `setDontOverrideInstallShutdownHandler`. + + * The repository now comes with + - example systemd configuration in the README + - example NixOS service + - a NixOS test for the watchdog feature, which is also a good example + ## 0.2.0.0 -- 2021-07-06 * Allow using healthchecks as conditional to trigger heartbeat diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Data.Function ((&)) +import Network.HTTP.Types.Status (status200) +import Network.Wai (Application, responseLBS) +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.Warp.Systemd as Systemd + +app :: Application +app _ respond = + respond $ responseLBS status200 [] "Hello World" + +main :: IO () +main = + Systemd.runSystemdWarp systemdSettings Warp.defaultSettings app + where + systemdSettings = + Systemd.defaultSystemdSettings + & Systemd.setHeartbeatInterval (Just 5) diff --git a/src/Network/Wai/Handler/Warp/Systemd.hs b/src/Network/Wai/Handler/Warp/Systemd.hs --- a/src/Network/Wai/Handler/Warp/Systemd.hs +++ b/src/Network/Wai/Handler/Warp/Systemd.hs @@ -1,48 +1,47 @@ {-# LANGUAGE RankNTypes #-} + -- | This modules provides function that help start the Warp web -- server using systemd's socket activation feature. module Network.Wai.Handler.Warp.Systemd - ( runSystemdWarp - -- * Settings - , SystemdSettings - , defaultSystemdSettings - - , logInfo - , setLogInfo - - , logWarn - , setLogWarn - - , requireSocketActivation - , setRequireSocketActivation - - , heartbeatInterval - , setHeartbeatInterval - - , heartbeatCheck - , setHeartbeatCheck + ( runSystemdWarp, - , onBeginShutdown - , setOnBeginShutdown + -- * Settings + SystemdSettings, + defaultSystemdSettings, + logInfo, + setLogInfo, + logWarn, + setLogWarn, + requireSocketActivation, + setRequireSocketActivation, + heartbeatInterval, + setHeartbeatInterval, + heartbeatCheck, + setHeartbeatCheck, + onBeginShutdown, + setOnBeginShutdown, -- * Low-level Settings - , dontOverrideInstallShutdownHandler, setDontOverrideInstallShutdownHandler + dontOverrideInstallShutdownHandler, + setDontOverrideInstallShutdownHandler, + -- * Exceptions - , SocketActivationException(..) - ) where + SocketActivationException (..), + ) +where -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception -import Control.Monad -import Data.Function -import Data.Typeable -import Network.Socket (withFdSocket, setNonBlockIfNeeded) -import Network.Wai as Wai -import Network.Wai.Handler.Warp as Warp +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception +import Control.Monad +import Data.Function +import Data.Typeable +import Network.Socket (setNonBlockIfNeeded, withFdSocket) +import Network.Wai as Wai +import Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as WarpInternal -import qualified System.Systemd.Daemon as Systemd import qualified System.IO as SIO import qualified System.Posix.Signals as Signals +import qualified System.Systemd.Daemon as Systemd -- | These only occur during startup. data SocketActivationException = SocketActivationException String @@ -53,29 +52,28 @@ -- | Warp-systemd integration settings. See the lenses in this module for details. -- -- Note that Warp itself has some settings related to the server process lifecycle, for example 'Warp.setInstallShutdownHandler'. - -data SystemdSettings = - SystemdSettings - { _logInfo :: String -> IO () - , _logWarn :: String -> IO () - , _requireSocketActivation :: Bool - , _heartbeatInterval :: Maybe Int - , _heartbeatCheck :: IO () - , _dontOverrideInstallShutdownHandler :: Bool - , _onBeginShutdown :: IO () +data SystemdSettings = SystemdSettings + { _logInfo :: String -> IO (), + _logWarn :: String -> IO (), + _requireSocketActivation :: Bool, + _heartbeatInterval :: Maybe Int, + _heartbeatCheck :: IO (), + _dontOverrideInstallShutdownHandler :: Bool, + _onBeginShutdown :: IO () } -- | Default settings. See the lenses in this module for details. defaultSystemdSettings :: SystemdSettings -defaultSystemdSettings = SystemdSettings - { _logInfo = SIO.hPutStrLn SIO.stderr - , _logWarn = SIO.hPutStrLn SIO.stderr . ("WARNING: " ++) - , _requireSocketActivation = False - , _heartbeatInterval = Nothing - , _heartbeatCheck = return () - , _dontOverrideInstallShutdownHandler = False - , _onBeginShutdown = return () - } +defaultSystemdSettings = + SystemdSettings + { _logInfo = SIO.hPutStrLn SIO.stderr, + _logWarn = SIO.hPutStrLn SIO.stderr . ("WARNING: " ++), + _requireSocketActivation = False, + _heartbeatInterval = Nothing, + _heartbeatCheck = return (), + _dontOverrideInstallShutdownHandler = False, + _onBeginShutdown = return () + } -- | How to log an info message. -- @@ -116,8 +114,8 @@ -- cause the default 'installShutdownHandler' to not be set, -- with the effect of preventing the 'onBeginShutdown' action and -- preventing the systemd ‘stopping’ notification. --- -- +-- -- Default: @Nothing@ dontOverrideInstallShutdownHandler :: Lens' SystemdSettings Bool dontOverrideInstallShutdownHandler = lens _dontOverrideInstallShutdownHandler setDontOverrideInstallShutdownHandler @@ -136,34 +134,31 @@ -- | See 'logInfo' setLogInfo :: (String -> IO ()) -> SystemdSettings -> SystemdSettings -setLogInfo x s = s { _logInfo = x } +setLogInfo x s = s {_logInfo = x} -- | See 'logWarn' setLogWarn :: (String -> IO ()) -> SystemdSettings -> SystemdSettings -setLogWarn x s = s { _logWarn = x } +setLogWarn x s = s {_logWarn = x} -- | See 'requireSocketActivation' setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings -setRequireSocketActivation x s = s { _requireSocketActivation = x } +setRequireSocketActivation x s = s {_requireSocketActivation = x} -- | See 'heartbeatInterval' setHeartbeatInterval :: Maybe Int -> SystemdSettings -> SystemdSettings -setHeartbeatInterval x s = s { _heartbeatInterval = x } +setHeartbeatInterval x s = s {_heartbeatInterval = x} -- | See 'heartbeatCheck' setHeartbeatCheck :: IO () -> SystemdSettings -> SystemdSettings -setHeartbeatCheck action s = s { _heartbeatCheck = action } +setHeartbeatCheck action s = s {_heartbeatCheck = action} -- | See 'dontOverrideInstallShutdownHandler' setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings -setDontOverrideInstallShutdownHandler x s = s { _dontOverrideInstallShutdownHandler = x } +setDontOverrideInstallShutdownHandler x s = s {_dontOverrideInstallShutdownHandler = x} -- | See 'onBeginShutdown' setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings -setOnBeginShutdown x s = s { _onBeginShutdown = x } - - - +setOnBeginShutdown x s = s {_onBeginShutdown = x} -- | Run a web application, see 'SystemdSettings' for details. -- @@ -172,31 +167,28 @@ -- 'Warp.setInstallShutdownHandler'. However, you do not have to -- include a ready notification using 'Warp.setBeforeMainloop', because -- 'runSystemdWarp' does this for you. -runSystemdWarp - :: SystemdSettings - -> Warp.Settings -- ^ Web server settings - -> Wai.Application -- ^ Web application - -> IO () +runSystemdWarp :: + SystemdSettings -> + -- | Web server settings + Warp.Settings -> + -- | Web application + Wai.Application -> + IO () runSystemdWarp saSettings settings app = do - forM_ (_heartbeatInterval saSettings) $ \interval -> do forkIO (heartbeat (_logWarn saSettings) (_heartbeatCheck saSettings) interval) - - socketActivationSockets <- Systemd.getActivatedSockets + socketActivationSockets <- Systemd.getActivatedSockets maybeSocket <- case socketActivationSockets of Just [socket] -> return (Just socket) - - Nothing | _requireSocketActivation saSettings -> - throwIO (SocketActivationException "Socket activation is required to run this web application.") - + Nothing + | _requireSocketActivation saSettings -> + throwIO (SocketActivationException "Socket activation is required to run this web application.") Nothing -> return Nothing - Just [] -> throwIO (SocketActivationException "Socket activation seems active, but no sockets were passed to the process.") - Just _ -> {- It is not entirely obvious how this should be implemented. When implementing, verify and document interaction with cleanup @@ -206,32 +198,34 @@ case maybeSocket of Just _ -> _logInfo saSettings "Warp is socket-activated" - Nothing -> _logInfo saSettings "Warp is not socket-activated" - - let - inhibitIf :: Bool -> (a -> a) -> (a -> a) - inhibitIf False x = x - inhibitIf True _ = id -- inhibited: leave unaltered + Nothing -> _logInfo saSettings "Warp is not socket-activated" - settings' = settings - & setBeforeMainLoop (do - WarpInternal.settingsBeforeMainLoop settings - void Systemd.notifyReady - ) - & inhibitIf (_dontOverrideInstallShutdownHandler saSettings) ( - setInstallShutdownHandler $ \closeListenSocket -> - -- Maybe append/prepend this to the old setting? - -- But what about multiple sockets? - -- No obvious semantics to implement, sadly. - -- If multi-socket is needed, do the research and - -- probably create a bunch of new settings with - -- compatible defaults... - let handler = Signals.Catch $ do - void Systemd.notifyStopping - closeListenSocket - _onBeginShutdown saSettings - in void $ Signals.installHandler Signals.sigTERM handler Nothing - ) + let inhibitIf :: Bool -> (a -> a) -> (a -> a) + inhibitIf False x = x + inhibitIf True _ = id -- inhibited: leave unaltered + settings' = + settings + & setBeforeMainLoop + ( do + WarpInternal.settingsBeforeMainLoop settings + void Systemd.notifyReady + ) + & inhibitIf + (_dontOverrideInstallShutdownHandler saSettings) + ( setInstallShutdownHandler $ \closeListenSocket -> + -- Maybe append/prepend this to the old setting? + -- But what about multiple sockets? + -- No obvious semantics to implement, sadly. + -- If multi-socket is needed, do the research and + -- probably create a bunch of new settings with + -- compatible defaults... + let handler = Signals.Catch $ do + void Systemd.notifyStopping + closeListenSocket + _onBeginShutdown saSettings + in forM_ [Signals.sigINT, Signals.sigTERM] $ \signal -> + Signals.installHandler signal handler Nothing + ) case maybeSocket of Just socket -> do @@ -242,29 +236,31 @@ runSettings settings' app heartbeat :: (String -> IO ()) -> IO () -> Int -> IO () -heartbeat flogWarn action delaySeconds = loop where - loop = do - let delayMicroSeconds = delaySeconds * 1000 * 1000 - eitherCheck <- try action - case eitherCheck of - Left exc -> do - flogWarn $ "Systemd heartbeat check failed: " <> displayException (exc :: SomeException) - threadDelay delayMicroSeconds - loop - Right () -> do - r <- Systemd.notifyWatchdog - case r of - Nothing -> do - flogWarn "Systemd heartbeat notification does not seem to arrive. Stopping heartbeat notifications." - return () - Just _ -> do - threadDelay delayMicroSeconds - loop +heartbeat flogWarn action delaySeconds = loop + where + loop = do + let delayMicroSeconds = delaySeconds * 1000 * 1000 + eitherCheck <- try action + case eitherCheck of + Left exc -> do + flogWarn $ "Systemd heartbeat check failed: " <> displayException (exc :: SomeException) + threadDelay delayMicroSeconds + loop + Right () -> do + r <- Systemd.notifyWatchdog + case r of + Nothing -> do + flogWarn "Systemd heartbeat notification does not seem to arrive. Stopping heartbeat notifications." + return () + Just _ -> do + threadDelay delayMicroSeconds + loop ---------------- Minimal dependency-free lens ---------------- -- | Traverse a single element. The essence of getting and setting. type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + -- | Monomorphic 'Lens' type Lens' s a = Lens s s a a diff --git a/warp-systemd.cabal b/warp-systemd.cabal --- a/warp-systemd.cabal +++ b/warp-systemd.cabal @@ -1,8 +1,9 @@ +cabal-version: 2.4 name: warp-systemd -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Socket activation and other systemd integration for the Warp web server (WAI) homepage: https://github.com/hercules-ci/warp-systemd -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Robert Hensing maintainer: hackage@roberthensing.nl @@ -10,16 +11,28 @@ category: Web build-type: Simple extra-source-files: CHANGELOG.md -cabal-version: >=1.10 +common common-options + build-depends: base >=4.9 && < 4.17 + + default-language: Haskell2010 + ghc-options: -Wall + library + import: common-options exposed-modules: Network.Wai.Handler.Warp.Systemd - build-depends: base >=4.9 && < 4.15 - , network >= 3.1 && < 3.2 + hs-source-dirs: src + build-depends: network >= 3.1 && < 3.2 , systemd == 2.* , unix , wai == 3.2.* , warp >= 3.2.0 && < 3.4 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + +executable warp-systemd-example + import: common-options + build-depends: http-types + , wai + , warp + , warp-systemd + hs-source-dirs: example + main-is: Main.hs