Debugging for socket bind

package.yaml

@@ -122,6 +122,8 @@ dependencies:
   - mono-traversable
   - lens-aeson
   - systemd
+  - lifted-async
+  - streaming-commons
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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
+    flip runLoggingT logFunc $ do
-    app <- makeApplication foundation
+      -- Generate a WAI Application from the foundation
+      app <- makeApplication foundation
 
-    -- Run the application with Warp
+      -- Run the application with Warp
-    activatedSockets <- liftIO Systemd.getActivatedSockets
+      activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames
-    liftIO $ case activatedSockets of
+      sockets <- case activatedSockets of
-      Just [sock]
+        Just socks@(_ : _) -> do
-        -> runSettingsSocket (warpSettings foundation) sock app
+          $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|]
-      _other
+          return $ fmap fst socks
-        -> runSettings (warpSettings foundation) app
+        _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
 
 
 --------------------------------------------------------------