diff --git a/exes/Main.hs b/exes/Main.hs index 2e4723f11..936a85918 100644 --- a/exes/Main.hs +++ b/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 diff --git a/hackage-server.cabal b/hackage-server.cabal index bd88d1455..12fd000cd 100644 --- a/hackage-server.cabal +++ b/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 diff --git a/nix/nixos-module.nix b/nix/nixos-module.nix index fb29f04e8..7d10f8355 100644 --- a/nix/nixos-module.nix +++ b/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}" diff --git a/nix/test.nix b/nix/test.nix index f8892cb1b..ad475215b 100644 --- a/nix/test.nix +++ b/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") ''; } diff --git a/src/Distribution/Server.hs b/src/Distribution/Server.hs index b5a5d97f5..bd27e2b08 100644 --- a/src/Distribution/Server.hs +++ b/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