diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for warp-systemd + +## 0.1.0.0 -- 2019-09-18 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Robert Hensing + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Robert Hensing nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/Wai/Handler/Warp/Systemd.hs b/src/Network/Wai/Handler/Warp/Systemd.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Handler/Warp/Systemd.hs @@ -0,0 +1,248 @@ +{-# 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 + + , onBeginShutdown + , setOnBeginShutdown + + -- * Low-level Settings + , dontOverrideInstallShutdownHandler, setDontOverrideInstallShutdownHandler + -- * Exceptions + , SocketActivationException(..) + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception +import Control.Monad +import Data.Function +import Data.Typeable +import Network.Socket (fdSocket, setNonBlockIfNeeded) +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 + +-- | These only occur during startup. +data SocketActivationException = SocketActivationException String + deriving (Show, Typeable) + +instance Exception SocketActivationException + +-- | 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 + , _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 + , _dontOverrideInstallShutdownHandler = False + , _onBeginShutdown = return () + } + +-- | How to log an info message. +-- +-- Default: @hPutStrLn stderr@ +logInfo :: Lens' SystemdSettings (String -> IO ()) +logInfo = lens _logInfo setLogInfo + +-- | How to log an info message. +-- +-- Default: @hPutStrLn stderr . ("WARNING: " ++)@ +logWarn :: Lens' SystemdSettings (String -> IO ()) +logWarn = lens _logWarn setLogWarn + +-- | If True, 'runSystemdWarp' throw a 'SocketActivationException' if +-- the server is started without socket activation. +-- +-- Default: @False (continue)@ +requireSocketActivation :: Lens' SystemdSettings Bool +requireSocketActivation = lens _requireSocketActivation setRequireSocketActivation + +-- | If @Just n@, 'runSystemdWarp' emits a heartbeat notification to +-- systemd every @n@ seconds. +-- +-- Default: @Nothing@ +heartbeatInterval :: Lens' SystemdSettings (Maybe Int) +heartbeatInterval = lens _heartbeatInterval setHeartbeatInterval + +-- | If @True@, do not override 'Warp.Settings'' with +-- 'setInstallShutdownHandler'. This lets you provide your own +-- shutdown handler functionality. Enabling this setting will +-- 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 + +-- | Action to run on shutdown. This will be called when a shutdown +-- signal has been received from systemd and the listening socket has +-- been closed. This means that no new incoming requests will be +-- received, but previous requests are still being processed. +-- +-- Control flow should return to the caller of 'runSystemdWarp' when +-- all requests have been handled. +-- +-- Default: 'return ()' +onBeginShutdown :: Lens' SystemdSettings (IO ()) +onBeginShutdown = lens _onBeginShutdown setOnBeginShutdown + +-- | See 'logInfo' +setLogInfo :: (String -> IO ()) -> SystemdSettings -> SystemdSettings +setLogInfo x s = s { _logInfo = x } + +-- | See 'logWarn' +setLogWarn :: (String -> IO ()) -> SystemdSettings -> SystemdSettings +setLogWarn x s = s { _logWarn = x } + +-- | See 'requireSocketActivation' +setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings +setRequireSocketActivation x s = s { _requireSocketActivation = x } + +-- | See 'heartbeatInterval' +setHeartbeatInterval :: Maybe Int -> SystemdSettings -> SystemdSettings +setHeartbeatInterval x s = s { _heartbeatInterval = x } + +-- | See 'dontOverrideInstallShutdownHandler' +setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings +setDontOverrideInstallShutdownHandler x s = s { _dontOverrideInstallShutdownHandler = x } + +-- | See 'onBeginShutdown' +setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings +setOnBeginShutdown x s = s { _onBeginShutdown = x } + + + + +-- | Run a web application, see 'SystemdSettings' for details. +-- +-- Note that Warp itself has some 'Warp.Settings' settings related to +-- the server process lifecycle, such as +-- '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 saSettings settings app = do + + forM_ (_heartbeatInterval saSettings) $ \interval -> do + forkIO (heartbeat (_logWarn saSettings) interval) + + 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 -> + 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 + actions, notifications etc. + -} + throwIO (SocketActivationException "Multiple sockets were passed to the process, but only one socket was expected.") + + 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 + + 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 + ) + + case maybeSocket of + Just socket -> do + setNonBlockIfNeeded (fdSocket socket) + runSettingsSocket settings' socket app + Nothing -> + runSettings settings' app + +heartbeat :: (String -> IO ()) -> Int -> IO () +heartbeat flogWarn delaySeconds = loop where + loop = do + let delayMicroSeconds = delaySeconds * 1000 * 1000 + 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 + +lens :: (s -> a) -> (b -> s -> t) -> Lens s t a b +lens sa sbt afb s = flip sbt s <$> afb (sa s) diff --git a/warp-systemd.cabal b/warp-systemd.cabal new file mode 100644 --- /dev/null +++ b/warp-systemd.cabal @@ -0,0 +1,25 @@ +name: warp-systemd +version: 0.1.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-file: LICENSE +author: Robert Hensing +maintainer: hackage@roberthensing.nl +copyright: Robert Hensing +category: Web +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: Network.Wai.Handler.Warp.Systemd + build-depends: base >=4.9 && < 4.13 + , network >= 2.6.3.0 && < 3.1 + , systemd == 1.* + , unix + , wai == 3.2.* + , warp == 3.2.* + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall