packages feed

warp-systemd (empty) → 0.1.0.0

raw patch · 5 files changed

+310/−0 lines, 5 filesdep +basedep +networkdep +systemdsetup-changed

Dependencies added: base, network, systemd, unix, wai, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for warp-systemd++## 0.1.0.0  -- 2019-09-18++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/Wai/Handler/Warp/Systemd.hs view
@@ -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)
+ warp-systemd.cabal view
@@ -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