diff --git a/package.yaml b/package.yaml index 217f65626..470e510db 100644 --- a/package.yaml +++ b/package.yaml @@ -122,6 +122,8 @@ dependencies: - mono-traversable - lens-aeson - systemd + - lifted-async + - streaming-commons other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index ae1ca9dbd..b214df5ad 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,9 +24,10 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettings, runSettingsSocket, setHost, + runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) +import Data.Streaming.Network (bindPortTCP) import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, @@ -74,6 +75,7 @@ import System.Exit (exitFailure) import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd +import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel) -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) @@ -292,9 +294,9 @@ makeLogWare app = do -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings - & setPort (foundation ^. _appPort) - & setHost (foundation ^. _appHost) & setBeforeMainLoop (void Systemd.notifyReady) + & setHost (foundation ^. _appHost) + & setPort (foundation ^. _appPort) & setOnException (\_req e -> when (defaultShouldDisplayException e) $ do logger <- readTVarIO . snd $ appLogger foundation @@ -337,17 +339,30 @@ appMain = runResourceT $ do -- Generate the foundation from the settings foundation <- makeFoundation settings + + let logFunc loc src lvl str = do + f <- messageLoggerSource foundation <$> readTVarIO (snd $ foundation ^. _appLogger) + f loc src lvl str - -- Generate a WAI Application from the foundation - app <- makeApplication foundation + flip runLoggingT logFunc $ do + -- Generate a WAI Application from the foundation + app <- makeApplication foundation - -- Run the application with Warp - activatedSockets <- liftIO Systemd.getActivatedSockets - liftIO $ case activatedSockets of - Just [sock] - -> runSettingsSocket (warpSettings foundation) sock app - _other - -> runSettings (warpSettings foundation) app + -- Run the application with Warp + activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames + sockets <- case activatedSockets of + Just socks@(_ : _) -> do + $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|] + return $ fmap fst socks + _other -> do + let + host = foundation ^. _appHost + port = foundation ^. _appPort + $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] + liftIO $ pure <$> bindPortTCP port host + + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app + liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) sockets --------------------------------------------------------------