warp-systemd 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+168/−128 lines, 5 filesdep +http-typesdep +warp-systemddep ~basedep ~networkdep ~waisetup-changednew-component:exe:warp-systemd-examplePVP ok
version bump matches the API change (PVP)
Dependencies added: http-types, warp-systemd
Dependency ranges changed: base, network, wai, warp
API changes (from Hackage documentation)
Files
- CHANGELOG.md +11/−0
- Setup.hs +1/−0
- example/Main.hs +19/−0
- src/Network/Wai/Handler/Warp/Systemd.hs +116/−120
- warp-systemd.cabal +21/−8
CHANGELOG.md view
@@ -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
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
+ example/Main.hs view
@@ -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)
src/Network/Wai/Handler/Warp/Systemd.hs view
@@ -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
warp-systemd.cabal view
@@ -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