{-# 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 (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.IO as SIO
import qualified System.Posix.Signals as Signals
import qualified System.Systemd.Daemon as Systemd
data SocketActivationException = SocketActivationException String
deriving (Int -> SocketActivationException -> ShowS
[SocketActivationException] -> ShowS
SocketActivationException -> String
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
{ _logInfo :: String -> IO ()
_logInfo = Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr,
_logWarn :: String -> IO ()
_logWarn = Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"WARNING: " forall a. [a] -> [a] -> [a]
++),
_requireSocketActivation :: Bool
_requireSocketActivation = Bool
False,
_heartbeatInterval :: Maybe Int
_heartbeatInterval = forall a. Maybe a
Nothing,
_heartbeatCheck :: IO ()
_heartbeatCheck = forall (m :: * -> *) a. Monad m => a -> m a
return (),
_dontOverrideInstallShutdownHandler :: Bool
_dontOverrideInstallShutdownHandler = Bool
False,
_onBeginShutdown :: IO ()
_onBeginShutdown = forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
logInfo :: Lens' SystemdSettings (String -> IO ())
logInfo :: Lens' SystemdSettings (String -> IO ())
logInfo = 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 :: Lens' SystemdSettings (String -> IO ())
logWarn = 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 :: Lens' SystemdSettings Bool
requireSocketActivation = 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 :: Lens' SystemdSettings (Maybe Int)
heartbeatInterval = 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 :: Lens' SystemdSettings (IO ())
heartbeatCheck = 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 :: Lens' SystemdSettings Bool
dontOverrideInstallShutdownHandler = 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 :: Lens' SystemdSettings (IO ())
onBeginShutdown = 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SystemdSettings -> Maybe Int
_heartbeatInterval SystemdSettings
saSettings) 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] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Socket
socket)
Maybe [Socket]
Nothing
| SystemdSettings -> Bool
_requireSocketActivation SystemdSettings
saSettings ->
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 ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just [] ->
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]
_ ->
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 :: forall a. Bool -> (a -> a) -> a -> a
inhibitIf Bool
False a -> a
x = a -> a
x
inhibitIf Bool
True a -> a
_ = forall a. a -> a
id
settings' :: Settings
settings' =
Settings
settings
forall a b. a -> (a -> b) -> b
& IO () -> Settings -> Settings
setBeforeMainLoop
( do
Settings -> IO ()
WarpInternal.settingsBeforeMainLoop Settings
settings
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Maybe ())
Systemd.notifyReady
)
forall a b. a -> (a -> b) -> b
& forall a. Bool -> (a -> a) -> a -> a
inhibitIf
(SystemdSettings -> Bool
_dontOverrideInstallShutdownHandler SystemdSettings
saSettings)
( (IO () -> IO ()) -> Settings -> Settings
setInstallShutdownHandler forall a b. (a -> b) -> a -> b
$ \IO ()
closeListenSocket ->
let handler :: Handler
handler = IO () -> Handler
Signals.Catch forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Maybe ())
Systemd.notifyStopping
IO ()
closeListenSocket
SystemdSettings -> IO ()
_onBeginShutdown SystemdSettings
saSettings
in forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CInt
Signals.sigINT, CInt
Signals.sigTERM] forall a b. (a -> b) -> a -> b
$ \CInt
signal ->
CInt -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler CInt
signal Handler
handler forall a. Maybe a
Nothing
)
case Maybe Socket
maybeSocket of
Just Socket
socket -> do
forall r. Socket -> (CInt -> IO r) -> IO r
withFdSocket Socket
socket forall a b. (a -> b) -> a -> b
$ \CInt
fd -> do
CInt -> IO ()
setNonBlockIfNeeded CInt
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 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
Either SomeException ()
eitherCheck <- 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 forall a b. (a -> b) -> a -> b
$ String
"Systemd heartbeat check failed: " forall a. Semigroup a => a -> a -> a
<> 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."
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 :: forall s a b t. (s -> a) -> (b -> s -> t) -> Lens s t a b
lens s -> a
sa b -> s -> t
sbt a -> f b
afb s
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> s -> t
sbt s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
afb (s -> a
sa s
s)