Add socket activation support

exes/Main.hs

@@ -6,7 +6,7 @@
 module Main where
 
 import qualified Distribution.Server as Server
-import Distribution.Server (ListenOn(..), ServerConfig(..), Server)
+import Distribution.Server (InfallibleListenOn(..), ListenOn(..), ServerConfig(..), Server)
 import Distribution.Server.Framework.Feature
 import Distribution.Server.Framework.Logging
 import Distribution.Server.Framework.BackupRestore (equalTarBall, restoreServerBackup)
@@ -44,7 +44,7 @@ import Distribution.Simple.Command
 import Distribution.Simple.Setup
          ( Flag, pattern Flag, pattern NoFlag, fromFlag, fromFlagOrDefault, flagToList, flagToMaybe )
 import Data.Maybe
-         ( isNothing )
+         ( isNothing, isJust )
 import Data.List
          ( intercalate, isInfixOf )
 import Data.Foldable
@@ -209,7 +209,9 @@ data RunFlags = RunFlags {
     -- Online backup flags
     flagRunBackupOutputDir :: Flag FilePath,
     flagRunBackupLinkBlobs :: Flag Bool,
-    flagRunBackupScrubbed  :: Flag Bool
+    flagRunBackupScrubbed  :: Flag Bool,
+    flagRunSocketActivationOnly :: Flag Bool,
+    flagRunNoSocketActivation   :: Flag Bool
   }
 
 defaultRunFlags :: RunFlags
@@ -228,7 +230,9 @@ defaultRunFlags = RunFlags {
     flagRunLiveTemplates   = Flag False,
     flagRunBackupOutputDir = Flag "backups",
     flagRunBackupLinkBlobs = Flag False,
-    flagRunBackupScrubbed  = Flag False
+    flagRunBackupScrubbed  = Flag False,
+    flagRunSocketActivationOnly = Flag False,
+    flagRunNoSocketActivation   = Flag False
   }
 
 runCommand :: CommandUI RunFlags
@@ -311,6 +315,14 @@ runCommand =
           "Do not cache templates, for quicker feedback during development."
           flagRunLiveTemplates (\v flags -> flags { flagRunLiveTemplates = v })
           (noArg (Flag True))
+      , option [] ["socket-activation-only"]
+          "Require systemd socket activation (LISTEN_FDS); do not fall back to binding a port."
+          flagRunSocketActivationOnly (\v flags -> flags { flagRunSocketActivationOnly = v })
+          (noArg (Flag True))
+      , option [] ["no-socket-activation"]
+          "Always bind a port ourselves; ignore socket activation (LISTEN_FDS). Implied by --ip or --port."
+          flagRunNoSocketActivation (\v flags -> flags { flagRunNoSocketActivation = v })
+          (noArg (Flag True))
       ]
 
 runAction :: RunFlags -> IO ()
@@ -326,10 +338,21 @@ runAction opts = do
     let stateDir  = fromFlagOrDefault (confStateDir  defaults) (flagRunStateDir  opts)
         staticDir = fromFlagOrDefault (confStaticDir defaults) (flagRunStaticDir opts)
         tmpDir    = fromFlagOrDefault (confTmpDir    defaults) (flagRunTmpDir    opts)
-        listenOn  = (confListenOn defaults) {
-                       loPortNum = port,
-                       loIP      = ip
-                    }
+        socketActivationOnly = fromFlag (flagRunSocketActivationOnly opts)
+        -- Explicitly asking for an address to listen on is itself a request
+        -- to bind it ourselves, so it implies --no-socket-activation. (Pass
+        -- --host-uri if you only meant to change the advertised URI.)
+        noSocketActivation = fromFlag (flagRunNoSocketActivation opts)
+                          || explicitFlag (flagRunIP   opts)
+                          || explicitFlag (flagRunPort opts)
+        boundSocket = Server.FreshlyBoundSocket {
+                          Server.loIP      = ip,
+                          Server.loPortNum = port
+                      }
+        listenOn
+          | noSocketActivation = Server.ListenOnInfallible boundSocket
+          | socketActivationOnly = Server.ListenOnSocketActivation Nothing
+          | otherwise = Server.ListenOnSocketActivation (Just boundSocket)
         config    = defaults {
                         confHostUri    = hosturi,
                         confUserContentUri = usercontenturi,
@@ -347,6 +370,9 @@ runAction opts = do
         scrubbed  = fromFlag (flagRunBackupScrubbed  opts)
         liveTemplates = fromFlag (flagRunLiveTemplates opts)
 
+    when (socketActivationOnly && noSocketActivation) $
+      fail "--socket-activation-only conflicts with --no-socket-activation (or with --ip/--port, which imply it)"
+
     checkBlankServerState =<< Server.hasSavedState config
     checkStaticDir staticDir (flagRunStaticDir opts)
     checkTmpDir    tmpDir
@@ -379,9 +405,19 @@ runAction opts = do
   where
     verbosity = fromFlag (flagRunVerbosity opts)
 
+    explicitFlag = isJust . flagToMaybe
+
+    -- Extract default IP/port from the config's fallback
+    defaultInfallible defaults = case confListenOn defaults of
+      ListenOnInfallible bs             -> Just bs
+      ListenOnSocketActivation (Just bs) -> Just bs
+      ListenOnSocketActivation Nothing   -> Nothing
+    defaultPortNum defaults = maybe 8080 loPortNum (defaultInfallible defaults)
+    defaultIP      defaults = maybe "127.0.0.1" loIP (defaultInfallible defaults)
+
     -- Option handling:
     --
-    checkPortOpt defaults Nothing    = return (loPortNum (confListenOn defaults))
+    checkPortOpt defaults Nothing    = return (defaultPortNum defaults)
     checkPortOpt _        (Just str) = case reads str of
       [(n,"")]  | n >= 1 && n <= 65535
                -> return n
@@ -419,7 +455,7 @@ runAction opts = do
     checkRequiredBaseHostHeader _ Nothing    = fail "You must provide the --required-base-host-header= flag. It's typically the host part of the base-uri."
     checkRequiredBaseHostHeader _ (Just str) = pure str
 
-    checkIPOpt defaults Nothing    = return (loIP (confListenOn defaults))
+    checkIPOpt defaults Nothing    = return (defaultIP defaults)
     checkIPOpt _        (Just str) =
       let pQuad = do ds <- Parse.many1 Parse.digit
                      let quad = read ds :: Integer

hackage-server.cabal

@@ -170,6 +170,7 @@ common defaults
     , Cabal-syntax           >= 3.16.0.0 && < 3.18
         -- Cabal-syntax needs to be bound to constrain hackage-security
         -- see https://github.com/haskell/hackage-server/issues/1130
+    , network               ^>= 3.1   || ^>= 3.2
     , network-bsd           ^>= 2.8
     , network-uri           ^>= 2.6
     , parsec                ^>= 3.1.13

nix/nixos-module.nix

@@ -57,18 +57,20 @@ in
       defaultText = lib.literalMD "the data files of {option}`package`";
       description = ''
         Directory containing HTML templates, static files, and TUF keys.
+        Defaults to the data-files directory shipped with the package.
+        In prod, this is the `datafiles/` directory.
       '';
     };
 
     port = lib.mkOption {
       type = lib.types.port;
       default = 8080;
-      description = "TCP port to listen on.";
+      description = "TCP port for the listening socket.";
     };
 
     ip = lib.mkOption {
       type = lib.types.str;
-      default = "127.0.0.1";
+      default = "0.0.0.0";
       description = "IPv4 address to bind.";
     };
 
@@ -102,11 +104,19 @@ in
       "d ${cfg.stateDir}/state/tmp 0750 ${cfg.user} ${cfg.group} -"
     ];
 
+    systemd.sockets.hackage-server = {
+      description = "Hackage Server listening socket";
+      wantedBy = [ "sockets.target" ];
+      socketConfig = {
+        ListenStream = "${cfg.ip}:${toString cfg.port}";
+        Accept = false;
+      };
+    };
+
     systemd.services.hackage-server = {
       description = "Hackage Server";
-      after = [ "network-online.target" ];
-      wants = [ "network-online.target" ];
-      wantedBy = [ "multi-user.target" ];
+      requires = [ "hackage-server.socket" ];
+      # No wantedBy — service is started on-demand by socket activation
 
       preStart = ''
         if [ ! -d "${cfg.stateDir}/state/db" ]; then
@@ -129,8 +139,7 @@ in
         ExecStart = lib.concatStringsSep " " [
           (lib.getExe pkg)
           "run"
-          "--ip=${cfg.ip}"
-          "--port=${toString cfg.port}"
+          "--socket-activation-only"
           "--base-uri=${cfg.baseUri}"
           "--user-content-uri=${cfg.userContentUri}"
           "--required-base-host-header=${cfg.requiredBaseHostHeader}"

nix/test.nix

@@ -20,11 +20,13 @@ pkgs.testers.runNixOSTest {
 
   testScript = ''
     machine.start()
-    machine.wait_for_unit("hackage-server.service")
+    machine.wait_for_unit("hackage-server.socket")
+
+    # Trigger socket activation and wait for the service to come up
     machine.wait_for_open_port(8080)
 
     # Smoke test
-    machine.succeed("curl -fsS --max-time 10 http://localhost:8080/")
+    machine.succeed("curl -fsS --max-time 30 http://localhost:8080/")
     machine.succeed("curl -fsS --max-time 10 http://localhost:8080/users/.json")
   '';
 }

src/Distribution/Server.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.Server (
     -- * Server control
     Server(..),
@@ -10,6 +12,7 @@ module Distribution.Server (
     reloadDatafiles,
 
     -- * Server configuration
+    InfallibleListenOn(..),
     ListenOn(..),
     ServerConfig(..),
     defaultServerConfig,
@@ -45,9 +48,12 @@ import Distribution.Text
 import Distribution.Verbosity as Verbosity
 
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
+import System.Environment (lookupEnv)
 import Control.Concurrent
 import Network.URI (URI(..), URIAuth(URIAuth), nullURI)
 import Network.BSD (getHostName)
+import qualified Network.Socket as Socket
+import Text.Read (readMaybe)
 import Data.List (foldl', nubBy)
 import Data.Int  (Int64)
 import Control.Arrow (second)
@@ -60,10 +66,30 @@ import qualified Hackage.Security.Util.Path as Sec
 import Paths_hackage_server (getDataDir)
 
 
-data ListenOn = ListenOn {
-  loPortNum :: Int,
-  loIP :: String
-} deriving (Show)
+-- | Ways of listening that always yield a socket, barring IO errors.
+--
+-- This is, for example, as opposed to socket activation, which
+-- legitimately comes up empty when @LISTEN_FDS@ is not set.
+data InfallibleListenOn
+  -- | Traditional "server listens on port case"
+  = FreshlyBoundSocket { loIP :: String, loPortNum :: Int }
+  -- | Useful for testing
+  | ExplicitSocket Socket.Socket
+  deriving (Show)
+
+data ListenOn
+  = ListenOnInfallible InfallibleListenOn
+  -- | Modern socket activation (just systemd style for now) case.
+  | ListenOnSocketActivation {
+    -- | What to do when we are not socket-activated at all. Only an
+    -- 'InfallibleListenOn' will do: a fallback that could itself come up
+    -- empty would leave us with nothing to fall back to.
+    --
+    -- 'Nothing' means socket activation is required, and we should fail
+    -- rather than bind a socket ourselves.
+    loFallback :: Maybe InfallibleListenOn
+  }
+  deriving (Show)
 
 data ServerConfig = ServerConfig {
   confVerbosity :: Verbosity,
@@ -100,9 +126,11 @@ defaultServerConfig = do
                     },
     confUserContentUri = nullURI, -- This is a required argument, so the default doesn't matter
     confRequiredBaseHostHeader = "", -- This is a required argument, so the default doesn't matter
-    confListenOn  = ListenOn {
-                        loPortNum = 8080,
-                        loIP = "127.0.0.1"
+    confListenOn  = ListenOnSocketActivation {
+                        loFallback = Just FreshlyBoundSocket {
+                            loIP = "127.0.0.1",
+                            loPortNum = 8080
+                        }
                     },
     confStateDir  = "state",
     confStaticDir = dataDir,
@@ -350,10 +378,60 @@ setUpTemp sconf secs = do
     return (TempServer tid)
   where listenOn = confListenOn sconf
 
+-- | Get listening sockets via systemd-style socket activation.
+--
+-- If the @LISTEN_FDS@ environment variable is set, file descriptors 3
+-- through @3 + n - 1@ are treated as already-bound, listening sockets
+-- (per @sd_listen_fds(3)@).
+--
+-- 'Nothing' means @LISTEN_FDS@ is not set at all, i.e. we are not being
+-- socket-activated. This allows the caller to fallback as it sees fit.
+-- (That is different from @LISTEN_FDS=0@, which means we *are* being
+-- socket-activated, but were handed no sockets: 'Just' an empty list.)
+socketActivation :: IO (Maybe [Socket.Socket])
+socketActivation = do
+    mfds <- lookupEnv "LISTEN_FDS"
+    forM mfds $ \fds -> case readMaybe fds of
+      Nothing -> fail $ "LISTEN_FDS is set to " ++ show fds
+                     ++ ", which is not a number of file descriptors"
+      Just (n :: Word) ->
+        forM (takeWhile (< n) [0..]) $ \i -> do
+          let fd = fromIntegral (3 + i)
+          sock <- Socket.mkSocket fd
+          -- Set non-blocking so GHC's IO manager (epoll) can
+          -- handle accept/recv without blocking an OS thread.
+          Socket.setNonBlockIfNeeded fd
+          return sock
+
+-- | Like above, but requires a single socket (else failing, not
+-- returning 'Nothing', which is still only for the
+-- no-socket-activation-attempt case).
+--
+-- Some servers support multiple listening ports, but Happstack only
+-- supports 1.
+socketActivationExactlyOne :: IO (Maybe Socket.Socket)
+socketActivationExactlyOne = mapM exactlyOne =<< socketActivation
+  where
+    exactlyOne = \case
+      [s]     -> return s
+      []      -> fail "LISTEN_FDS is 0: no sockets were passed to us"
+      (_:_:_) -> fail "expected exactly one socket from LISTEN_FDS"
+
+acquireSocket :: InfallibleListenOn -> IO Socket.Socket
+acquireSocket (FreshlyBoundSocket ip portNum) = bindIPv4 ip portNum
+acquireSocket (ExplicitSocket s)              = return s
+
 runServer :: (ToMessage a) => ListenOn -> ServerPartT IO a -> IO ()
-runServer listenOn f
-    = do socket <- bindIPv4 (loIP listenOn) (loPortNum listenOn)
-         simpleHTTPWithSocket socket nullConf f
+runServer listenOn f = do
+    socket <- case listenOn of
+      ListenOnInfallible bs -> acquireSocket bs
+      ListenOnSocketActivation fallback -> socketActivationExactlyOne >>= \case
+        Just s  -> return s
+        -- Not socket-activated at all: fall back, if we are allowed to.
+        Nothing -> case fallback of
+          Just bs -> acquireSocket bs
+          Nothing -> fail "LISTEN_FDS is not set, but socket activation is required"
+    simpleHTTPWithSocket socket nullConf f
 
 -- | Static 503 page, based on Happstack's 404 page.
 html503 :: String