{-# 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,
    heartbeatCheck,
    setHeartbeatCheck,
    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 (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

-- | These only occur during startup.
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

-- | 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
  { 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 ()
  }

-- | Default settings. See the lenses in this module for details.
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 ()
    }

-- | How to log an info message.
--
-- Default: @hPutStrLn stderr@
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

-- | How to log an info message.
--
-- Default: @hPutStrLn stderr . ("WARNING: " ++)@
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

-- | If True, 'runSystemdWarp' throw a 'SocketActivationException' if
-- the server is started without socket activation.
--
-- Default: @False (continue)@
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

-- | If @Just n@, 'runSystemdWarp' emits a heartbeat notification to
-- systemd every @n@ seconds.
--
-- Default: @Nothing@
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

-- | Run an action before emitting a hearbeat and if it throws an exception, print a warning
--   and skip systemd notification.
--
-- Default: @return ()@
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

-- | 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' 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

-- | 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' 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

-- | See 'logInfo'
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}

-- | See 'logWarn'
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}

-- | See 'requireSocketActivation'
setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation :: Bool -> SystemdSettings -> SystemdSettings
setRequireSocketActivation Bool
x SystemdSettings
s = SystemdSettings
s {_requireSocketActivation :: Bool
_requireSocketActivation = Bool
x}

-- | See 'heartbeatInterval'
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}

-- | See 'heartbeatCheck'
setHeartbeatCheck :: IO () -> SystemdSettings -> SystemdSettings
setHeartbeatCheck :: IO () -> SystemdSettings -> SystemdSettings
setHeartbeatCheck IO ()
action SystemdSettings
s = SystemdSettings
s {_heartbeatCheck :: IO ()
_heartbeatCheck = IO ()
action}

-- | See 'dontOverrideInstallShutdownHandler'
setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler :: Bool -> SystemdSettings -> SystemdSettings
setDontOverrideInstallShutdownHandler Bool
x SystemdSettings
s = SystemdSettings
s {_dontOverrideInstallShutdownHandler :: Bool
_dontOverrideInstallShutdownHandler = Bool
x}

-- | See 'onBeginShutdown'
setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown :: IO () -> SystemdSettings -> SystemdSettings
setOnBeginShutdown IO ()
x SystemdSettings
s = SystemdSettings
s {_onBeginShutdown :: IO ()
_onBeginShutdown = IO ()
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 ->
  -- | Web server settings
  Warp.Settings ->
  -- | Web application
  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]
_ ->
      {- It is not entirely obvious how this should be implemented. When
         implementing, verify and document interaction with cleanup
         actions, notifications etc.
       -}
      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 -- inhibited: leave unaltered
      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 ->
                -- 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 :: 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

---------------- 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 :: 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)