{-# 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           (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

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

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

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

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

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

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

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

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

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

-- | 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
  -> Warp.Settings     -- ^ Web server settings
  -> Wai.Application   -- ^ Web 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]
_ ->
      {- It is not entirely obvious how this should be implemented. When
         implementing, verify and document interaction with cleanup
         actions, notifications etc.
       -}
      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 -- inhibited: leave unaltered

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

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