{-# LANGUAGE RankNTypes #-}
module Network.Wai.Handler.Warp.Systemd
( runSystemdWarp
, SystemdSettings
, defaultSystemdSettings
, logInfo
, setLogInfo
, logWarn
, setLogWarn
, requireSocketActivation
, setRequireSocketActivation
, heartbeatInterval
, setHeartbeatInterval
, onBeginShutdown
, setOnBeginShutdown
, dontOverrideInstallShutdownHandler, setDontOverrideInstallShutdownHandler
, 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 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
data SocketActivationException = SocketActivationException String
deriving (Show, Typeable)
instance Exception SocketActivationException
data SystemdSettings =
SystemdSettings
{ _logInfo :: String -> IO ()
, _logWarn :: String -> IO ()
, _requireSocketActivation :: Bool
, _heartbeatInterval :: Maybe Int
, _dontOverrideInstallShutdownHandler :: Bool
, _onBeginShutdown :: IO ()
}
defaultSystemdSettings :: SystemdSettings
defaultSystemdSettings = SystemdSettings
{ _logInfo = SIO.hPutStrLn SIO.stderr
, _logWarn = SIO.hPutStrLn SIO.stderr . ("WARNING: " ++)
, _requireSocketActivation = False
, _heartbeatInterval = Nothing
, _dontOverrideInstallShutdownHandler = False
, _onBeginShutdown = return ()
}
logInfo :: Lens' SystemdSettings (String -> IO ())
logInfo = lens _logInfo setLogInfo
logWarn :: Lens' SystemdSettings (String -> IO ())
logWarn = lens _logWarn setLogWarn
requireSocketActivation :: Lens' SystemdSettings Bool
requireSocketActivation = lens _requireSocketActivation setRequireSocketActivation
heartbeatInterval :: Lens' SystemdSettings (Maybe Int)
heartbeatInterval = lens _heartbeatInterval setHeartbeatInterval
dontOverrideInstallShutdownHandler :: Lens' SystemdSettings Bool
dontOverrideInstallShutdownHandler = lens _dontOverrideInstallShutdownHandler setDontOverrideInstallShutdownHandler
onBeginShutdown :: Lens' SystemdSettings (IO ())
onBeginShutdown = lens _onBeginShutdown setOnBeginShutdown
setLogInfo :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogInfo x s = s { _logInfo = x }
setLogWarn :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogWarn x s = s { _logWarn = x }
setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation x s = s { _requireSocketActivation = x }
setHeartbeatInterval :: Maybe Int -> SystemdSettings -> SystemdSettings
setHeartbeatInterval x s = s { _heartbeatInterval = x }
setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler x s = s { _dontOverrideInstallShutdownHandler = x }
setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown x s = s { _onBeginShutdown = x }
runSystemdWarp
:: SystemdSettings
-> Warp.Settings
-> Wai.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 _ ->
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
settings' = settings
& setBeforeMainLoop (do
WarpInternal.settingsBeforeMainLoop settings
void Systemd.notifyReady
)
& inhibitIf (_dontOverrideInstallShutdownHandler saSettings) (
setInstallShutdownHandler $ \closeListenSocket ->
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
withFdSocket socket $ \fd -> do
setNonBlockIfNeeded fd
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
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
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)