{-# LANGUAGE RankNTypes #-}
module Network.Wai.Handler.Warp.Systemd
( runSystemdWarp
, SystemdSettings
, defaultSystemdSettings
, logInfo
, setLogInfo
, logWarn
, setLogWarn
, requireSocketActivation
, setRequireSocketActivation
, heartbeatInterval
, setHeartbeatInterval
, heartbeatCheck
, setHeartbeatCheck
, 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 (Int -> SocketActivationException -> ShowS
[SocketActivationException] -> ShowS
SocketActivationException -> String
(Int -> SocketActivationException -> ShowS)
-> (SocketActivationException -> String)
-> ([SocketActivationException] -> ShowS)
-> Show SocketActivationException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SocketActivationException] -> ShowS
$cshowList :: [SocketActivationException] -> ShowS
show :: SocketActivationException -> String
$cshow :: SocketActivationException -> String
showsPrec :: Int -> SocketActivationException -> ShowS
$cshowsPrec :: Int -> SocketActivationException -> ShowS
Show, Typeable)
instance Exception SocketActivationException
data SystemdSettings =
SystemdSettings
{ SystemdSettings -> String -> IO ()
_logInfo :: String -> IO ()
, SystemdSettings -> String -> IO ()
_logWarn :: String -> IO ()
, SystemdSettings -> Bool
_requireSocketActivation :: Bool
, SystemdSettings -> Maybe Int
_heartbeatInterval :: Maybe Int
, SystemdSettings -> IO ()
_heartbeatCheck :: IO ()
, SystemdSettings -> Bool
_dontOverrideInstallShutdownHandler :: Bool
, SystemdSettings -> IO ()
_onBeginShutdown :: IO ()
}
defaultSystemdSettings :: SystemdSettings
defaultSystemdSettings :: SystemdSettings
defaultSystemdSettings = SystemdSettings :: (String -> IO ())
-> (String -> IO ())
-> Bool
-> Maybe Int
-> IO ()
-> Bool
-> IO ()
-> SystemdSettings
SystemdSettings
{ _logInfo :: String -> IO ()
_logInfo = Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr
, _logWarn :: String -> IO ()
_logWarn = Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"WARNING: " String -> ShowS
forall a. [a] -> [a] -> [a]
++)
, _requireSocketActivation :: Bool
_requireSocketActivation = Bool
False
, _heartbeatInterval :: Maybe Int
_heartbeatInterval = Maybe Int
forall a. Maybe a
Nothing
, _heartbeatCheck :: IO ()
_heartbeatCheck = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, _dontOverrideInstallShutdownHandler :: Bool
_dontOverrideInstallShutdownHandler = Bool
False
, _onBeginShutdown :: IO ()
_onBeginShutdown = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
logInfo :: Lens' SystemdSettings (String -> IO ())
logInfo :: ((String -> IO ()) -> f (String -> IO ()))
-> SystemdSettings -> f SystemdSettings
logInfo = (SystemdSettings -> String -> IO ())
-> ((String -> IO ()) -> SystemdSettings -> SystemdSettings)
-> Lens
SystemdSettings SystemdSettings (String -> IO ()) (String -> IO ())
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> String -> IO ()
_logInfo (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogInfo
logWarn :: Lens' SystemdSettings (String -> IO ())
logWarn :: ((String -> IO ()) -> f (String -> IO ()))
-> SystemdSettings -> f SystemdSettings
logWarn = (SystemdSettings -> String -> IO ())
-> ((String -> IO ()) -> SystemdSettings -> SystemdSettings)
-> Lens
SystemdSettings SystemdSettings (String -> IO ()) (String -> IO ())
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> String -> IO ()
_logWarn (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogWarn
requireSocketActivation :: Lens' SystemdSettings Bool
requireSocketActivation :: (Bool -> f Bool) -> SystemdSettings -> f SystemdSettings
requireSocketActivation = (SystemdSettings -> Bool)
-> (Bool -> SystemdSettings -> SystemdSettings)
-> Lens SystemdSettings SystemdSettings Bool Bool
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> Bool
_requireSocketActivation Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation
heartbeatInterval :: Lens' SystemdSettings (Maybe Int)
heartbeatInterval :: (Maybe Int -> f (Maybe Int))
-> SystemdSettings -> f SystemdSettings
heartbeatInterval = (SystemdSettings -> Maybe Int)
-> (Maybe Int -> SystemdSettings -> SystemdSettings)
-> Lens SystemdSettings SystemdSettings (Maybe Int) (Maybe Int)
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> Maybe Int
_heartbeatInterval Maybe Int -> SystemdSettings -> SystemdSettings
setHeartbeatInterval
heartbeatCheck :: Lens' SystemdSettings (IO ())
heartbeatCheck :: (IO () -> f (IO ())) -> SystemdSettings -> f SystemdSettings
heartbeatCheck = (SystemdSettings -> IO ())
-> (IO () -> SystemdSettings -> SystemdSettings)
-> Lens SystemdSettings SystemdSettings (IO ()) (IO ())
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> IO ()
_heartbeatCheck IO () -> SystemdSettings -> SystemdSettings
setHeartbeatCheck
dontOverrideInstallShutdownHandler :: Lens' SystemdSettings Bool
dontOverrideInstallShutdownHandler :: (Bool -> f Bool) -> SystemdSettings -> f SystemdSettings
dontOverrideInstallShutdownHandler = (SystemdSettings -> Bool)
-> (Bool -> SystemdSettings -> SystemdSettings)
-> Lens SystemdSettings SystemdSettings Bool Bool
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> Bool
_dontOverrideInstallShutdownHandler Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler
onBeginShutdown :: Lens' SystemdSettings (IO ())
onBeginShutdown :: (IO () -> f (IO ())) -> SystemdSettings -> f SystemdSettings
onBeginShutdown = (SystemdSettings -> IO ())
-> (IO () -> SystemdSettings -> SystemdSettings)
-> Lens SystemdSettings SystemdSettings (IO ()) (IO ())
forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens SystemdSettings -> IO ()
_onBeginShutdown IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown
setLogInfo :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogInfo :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogInfo String -> IO ()
x SystemdSettings
s = SystemdSettings
s { _logInfo :: String -> IO ()
_logInfo = String -> IO ()
x }
setLogWarn :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogWarn :: (String -> IO ()) -> SystemdSettings -> SystemdSettings
setLogWarn String -> IO ()
x SystemdSettings
s = SystemdSettings
s { _logWarn :: String -> IO ()
_logWarn = String -> IO ()
x }
setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation Bool
x SystemdSettings
s = SystemdSettings
s { _requireSocketActivation :: Bool
_requireSocketActivation = Bool
x }
setHeartbeatInterval :: Maybe Int -> SystemdSettings -> SystemdSettings
setHeartbeatInterval :: Maybe Int -> SystemdSettings -> SystemdSettings
setHeartbeatInterval Maybe Int
x SystemdSettings
s = SystemdSettings
s { _heartbeatInterval :: Maybe Int
_heartbeatInterval = Maybe Int
x }
setHeartbeatCheck :: IO () -> SystemdSettings -> SystemdSettings
setHeartbeatCheck :: IO () -> SystemdSettings -> SystemdSettings
setHeartbeatCheck IO ()
action SystemdSettings
s = SystemdSettings
s { _heartbeatCheck :: IO ()
_heartbeatCheck = IO ()
action }
setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler Bool
x SystemdSettings
s = SystemdSettings
s { _dontOverrideInstallShutdownHandler :: Bool
_dontOverrideInstallShutdownHandler = Bool
x }
setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown IO ()
x SystemdSettings
s = SystemdSettings
s { _onBeginShutdown :: IO ()
_onBeginShutdown = IO ()
x }
runSystemdWarp
:: SystemdSettings
-> Warp.Settings
-> Wai.Application
-> IO ()
runSystemdWarp :: SystemdSettings -> Settings -> Application -> IO ()
runSystemdWarp SystemdSettings
saSettings Settings
settings Application
app = do
Maybe Int -> (Int -> IO ThreadId) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SystemdSettings -> Maybe Int
_heartbeatInterval SystemdSettings
saSettings) ((Int -> IO ThreadId) -> IO ()) -> (Int -> IO ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
interval -> do
IO () -> IO ThreadId
forkIO ((String -> IO ()) -> IO () -> Int -> IO ()
heartbeat (SystemdSettings -> String -> IO ()
_logWarn SystemdSettings
saSettings) (SystemdSettings -> IO ()
_heartbeatCheck SystemdSettings
saSettings) Int
interval)
Maybe [Socket]
socketActivationSockets <- IO (Maybe [Socket])
Systemd.getActivatedSockets
Maybe Socket
maybeSocket <- case Maybe [Socket]
socketActivationSockets of
Just [Socket
socket] -> Maybe Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
socket)
Maybe [Socket]
Nothing | SystemdSettings -> Bool
_requireSocketActivation SystemdSettings
saSettings ->
SocketActivationException -> IO (Maybe Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> SocketActivationException
SocketActivationException String
"Socket activation is required to run this web application.")
Maybe [Socket]
Nothing ->
Maybe Socket -> IO (Maybe Socket)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Socket
forall a. Maybe a
Nothing
Just [] ->
SocketActivationException -> IO (Maybe Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> SocketActivationException
SocketActivationException String
"Socket activation seems active, but no sockets were passed to the process.")
Just [Socket]
_ ->
SocketActivationException -> IO (Maybe Socket)
forall e a. Exception e => e -> IO a
throwIO (String -> SocketActivationException
SocketActivationException String
"Multiple sockets were passed to the process, but only one socket was expected.")
case Maybe Socket
maybeSocket of
Just Socket
_ -> SystemdSettings -> String -> IO ()
_logInfo SystemdSettings
saSettings String
"Warp is socket-activated"
Maybe Socket
Nothing -> SystemdSettings -> String -> IO ()
_logInfo SystemdSettings
saSettings String
"Warp is not socket-activated"
let
inhibitIf :: Bool -> (a -> a) -> (a -> a)
inhibitIf :: Bool -> (a -> a) -> a -> a
inhibitIf Bool
False a -> a
x = a -> a
x
inhibitIf Bool
True a -> a
_ = a -> a
forall a. a -> a
id
settings' :: Settings
settings' = Settings
settings
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
setBeforeMainLoop (do
Settings -> IO ()
WarpInternal.settingsBeforeMainLoop Settings
settings
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Maybe ())
Systemd.notifyReady
)
Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Bool -> (Settings -> Settings) -> Settings -> Settings
forall a. Bool -> (a -> a) -> a -> a
inhibitIf (SystemdSettings -> Bool
_dontOverrideInstallShutdownHandler SystemdSettings
saSettings) (
(IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler ((IO () -> IO ()) -> Settings -> Settings)
-> (IO () -> IO ()) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$ \IO ()
closeListenSocket ->
let handler :: Handler
handler = IO () -> Handler
Signals.Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ do
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Maybe ())
Systemd.notifyStopping
IO ()
closeListenSocket
SystemdSettings -> IO ()
_onBeginShutdown SystemdSettings
saSettings
in IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigTERM Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
)
case Maybe Socket
maybeSocket of
Just Socket
socket -> do
Socket -> (Signal -> IO ()) -> IO ()
forall r. Socket -> (Signal -> IO r) -> IO r
withFdSocket Socket
socket ((Signal -> IO ()) -> IO ()) -> (Signal -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Signal
fd -> do
Signal -> IO ()
setNonBlockIfNeeded Signal
fd
Settings -> Socket -> Application -> IO ()
runSettingsSocket Settings
settings' Socket
socket Application
app
Maybe Socket
Nothing ->
Settings -> Application -> IO ()
runSettings Settings
settings' Application
app
heartbeat :: (String -> IO ()) -> IO () -> Int -> IO ()
heartbeat :: (String -> IO ()) -> IO () -> Int -> IO ()
heartbeat String -> IO ()
flogWarn IO ()
action Int
delaySeconds = IO ()
loop where
loop :: IO ()
loop = do
let delayMicroSeconds :: Int
delayMicroSeconds = Int
delaySeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
Either SomeException ()
eitherCheck <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try IO ()
action
case Either SomeException ()
eitherCheck of
Left SomeException
exc -> do
String -> IO ()
flogWarn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Systemd heartbeat check failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException
exc :: SomeException)
Int -> IO ()
threadDelay Int
delayMicroSeconds
IO ()
loop
Right () -> do
Maybe ()
r <- IO (Maybe ())
Systemd.notifyWatchdog
case Maybe ()
r of
Maybe ()
Nothing -> do
String -> IO ()
flogWarn String
"Systemd heartbeat notification does not seem to arrive. Stopping heartbeat notifications."
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ()
_ -> do
Int -> IO ()
threadDelay Int
delayMicroSeconds
IO ()
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 :: (s -> a) -> (b -> s -> t) -> Lens s t a b
lens s -> a
sa b -> s -> t
sbt a -> f b
afb s
s = (b -> s -> t) -> s -> b -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> s -> t
sbt s
s (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
afb (s -> a
sa s
s)