diff --git a/.changes/019-server-bind-host-port.md b/.changes/019-server-bind-host-port.md new file mode 100644 index 000000000..33c3d6121 --- /dev/null +++ b/.changes/019-server-bind-host-port.md @@ -0,0 +1,37 @@ +--- +group: platform +component: Framework +impact: breaking +category: Breaking changes +--- + +## Summary + +You can now choose which network address and port your web server listens on. Add `Application.withHost "127.0.0.1"` to accept connections from the same machine only, and `Application.withPort 9090` to change the port. `host` also accepts `"*"` (all addresses, IPv4 and IPv6), `"*4"`, `"*6"` or a literal address. + +Loopback (`"127.0.0.1"`) is the right choice when your reverse proxy runs on the same machine or in the same container as the app. If the proxy runs somewhere else (its own container with its own network, another host), it cannot reach a loopback listener; keep the default bind and restrict access with your firewall or network policy instead. + +A mistake in these settings fails at startup with a clear message instead of starting something unintended. The host must be a bare address or hostname (an empty host, a URL like `"http://127.0.0.1"`, a `host:port` pair or whitespace is rejected with `Application.withHost: ...`), and the port must be between 1 and 65535 (`0` and out-of-range values are rejected with `Application.withPort: ...`). If the port is already in use or the address does not belong to this machine, the app stops with `WebTransport could not bind :: ...`. + +Your app behaves exactly as before unless you opt in: it still listens on all IPv4 addresses on port 8080. To also accept IPv6 connections, set `Application.withHost "*"`. + +This is marked breaking for one narrow case. `WebTransport` and `Application` each gained fields, so code that builds either record by naming every field must add the new ones. Apps that use `WebTransport.server` or `Application.new` are not affected and need no change. + +## Migration + +Search your code for a `WebTransport { ... }` or `Application { ... }` record written with every field. Most apps have none and can stop here. + +- In a `WebTransport { ... }` record, add `host = "*4"` to keep the old behaviour, or `host = "127.0.0.1"` to accept local connections only. +- In an `Application { ... }` record, add `bindHost = Nothing` and `bindPort = Nothing`. + +Prefer `WebTransport.server { port = 9090 }` or `Application.withHost` and `Application.withPort` over naming every field. + +### Verify + +Build your app, then start it and request `/health` on the address you chose. To check the framework change itself, run `./dev test "Service.Transport.Web.Bind" nhcore-test-service`. All 27 examples pass, including one that starts the server on `127.0.0.1`, fetches its health endpoint and confirms the port is still free on the machine's other addresses, and one that shows a port already in use is reported as `could not bind`. + +## Agent prompt + +```text +My NeoHaskell app fails to compile after upgrading nhcore. `WebTransport` gained a `host :: Text` field and `Application` gained `bindHost :: Maybe Text` and `bindPort :: Maybe Int`. Find every place that builds a `WebTransport { ... }` or `Application { ... }` record by naming all fields (search for `WebTransport {`, `WebTransport$` followed by `{`, and `Application {`). In each `WebTransport` record add `host = "*4"` so it keeps listening on all IPv4 addresses exactly as before. In each `Application` record add `bindHost = Nothing` and `bindPort = Nothing`. Do not change anything that uses `WebTransport.server` or `Application.new`. Keep the port and every other field exactly as they were. Then build the project and run its tests. Report which files you edited and whether the build and tests pass. If my app sits behind a reverse proxy that runs on the same machine or in the same container, tell me I can use `Application.withHost "127.0.0.1"` for local-only access; if the proxy runs elsewhere, tell me to keep the default bind. Do not change the bind host without asking. +``` diff --git a/codemap/api-hot.md b/codemap/api-hot.md index 0f4a16cbc..5c06266a6 100644 --- a/codemap/api-hot.md +++ b/codemap/api-hot.md @@ -12,13 +12,13 @@ codemap/signatures/ · type-directed search: ./dev api "" - `yield :: value -> Task w value` - `ignoreError :: Task err Unit -> Task w Unit` -- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` -- `throw :: err -> Task err w` -- `fromIO :: IO value -> Task w value` +- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` +- `throw :: err -> Task err w` +- `fromIO :: IO value -> Task w value` - `asResult :: Task err value -> Task err2 (Result err value)` - `when :: Bool -> Task err Unit -> Task err Unit` - `forEach :: (element -> Task err Unit) -> Array element -> Task err Unit` -- `fromFailableIO :: Exception exception => IO result -> Task exception result` +- `fromFailableIO :: Exception exception => IO result -> Task exception result` - `map :: (input -> output) -> Task err input -> Task err output` ## Array @@ -36,7 +36,7 @@ codemap/signatures/ · type-directed search: ./dev api "" - `>>> push 3 (fromLinkedList [1,2] :: Array Int)` → `Array [1,2,3]` - `takeIf :: (a -> Bool) -> Array a -> Array a` - `>>> takeIf Basics.isEven (fromLinkedList [1,2,3,4,5,6] :: Array Int)` → `Array [2,4,6]` -- `length :: Array a -> Int` +- `length :: Array a -> Int` - `>>> length ([1,2,3] :: Array Int)` → `3` … - `append :: Array a -> Array a -> Array a` - `>>> (repeat 2 42) |> append (repeat 3 81) :: Array Int` → `Array [42,42,81,81,81]` @@ -46,13 +46,13 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Text - `fromLinkedList :: LinkedList Char -> Text` -- `toLinkedList :: Text -> LinkedList Char` +- `toLinkedList :: Text -> LinkedList Char` - `toBytes :: Text -> Bytes` - `replace :: Text -> Text -> Text -> Text` -- `trim :: Text -> Text` +- `trim :: Text -> Text` - `fromBytes :: Bytes -> Text` +- `isEmpty :: Text -> Bool` - `joinWith :: Text -> Array Text -> Text` -- `isEmpty :: Text -> Bool` - `append :: Text -> Text -> Text` - `toLower :: Text -> Text` @@ -130,7 +130,7 @@ codemap/signatures/ · type-directed search: ./dev api "" ## Maybe -- `withDefault :: a -> Maybe a -> a` +- `withDefault :: a -> Maybe a -> a` - `map :: (a -> b) -> Maybe a -> Maybe b` - `getOrDie :: HasCallStack => Maybe a -> a` - `andThen :: (a -> Maybe b) -> Maybe a -> Maybe b` @@ -294,13 +294,13 @@ when WRITING TESTS; they are not feature-code frequency signal. ## Task -- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` -- `yield :: value -> Task w value` -- `asResult :: Task err value -> Task err2 (Result err value)` +- `mapError :: (err1 -> err2) -> Task err1 value -> Task err2 value` +- `yield :: value -> Task w value` +- `asResult :: Task err value -> Task err2 (Result err value)` - `mapArray :: (element -> Task err output) -> Array element -> Task err (Array output)` -- `throw :: err -> Task err w` +- `throw :: err -> Task err w` +- `fromIO :: IO value -> Task w value` - `andThen :: (input -> Task err output) -> Task err input -> Task err output` -- `fromIO :: IO value -> Task w value` - `map :: (input -> output) -> Task err input -> Task err output` ## Array @@ -316,13 +316,13 @@ when WRITING TESTS; they are not feature-code frequency signal. ## Text -- `contains :: Text -> Text -> Bool` +- `contains :: Text -> Text -> Bool` - `toBytes :: Text -> Bytes` - `fromLinkedList :: LinkedList Char -> Text` - `length :: Text -> Int` - `repeat :: Int -> Text -> Text` - `toLinkedList :: Text -> LinkedList Char` -- `startsWith :: Text -> Text -> Bool` +- `startsWith :: Text -> Text -> Bool` - `all :: (Char -> Bool) -> Text -> Bool` ## Parser @@ -371,10 +371,10 @@ when WRITING TESTS; they are not feature-code frequency signal. ## Uuid -- `generate :: Task w Uuid` +- `generate :: Task w Uuid` - `nil :: Uuid` -- `toText :: Uuid -> Text` +- `toText :: Uuid -> Text` - `generateV5 :: Uuid -> Text -> Uuid` - `fromText :: Text -> Maybe Uuid` -*cut: 140 more modules (Map (260), Service.Application (250), Set (233), AsyncTask (225), Stream (212), …) — full surface: codemap/signatures/* +*cut: 141 more modules (Service.Application (297), Map (260), Set (233), AsyncTask (230), Stream (212), …) — full surface: codemap/signatures/* diff --git a/codemap/signatures/nhcore-service.txt b/codemap/signatures/nhcore-service.txt index fcdbe6904..3e4b113a6 100644 --- a/codemap/signatures/nhcore-service.txt +++ b/codemap/signatures/nhcore-service.txt @@ -123,7 +123,7 @@ tenantOnly :: (query -> Text) -> Maybe UserClaims -> query -> Maybe AccessError module Service.Application ApiInfo :: Text -> Text -> Text -> ApiInfo -Application :: Maybe ConfigSpec -> Maybe EventStoreFactory -> Maybe QueryObjectStoreConfigValue -> Array QueryDefinition -> QueryRegistry -> Array ServiceRunner -> Map Text TransportValue -> Map Text QueryEndpointHandler -> Array OutboundRunner -> Array OutboundLifecycleRunner -> Array Inbound -> Maybe WebAuthFactory -> Maybe OAuth2Setup -> Maybe FileUploadFactory -> Maybe SecretStore -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe DispatcherConfig -> Maybe CorsFactory -> Maybe ApiInfoFactory -> Maybe HealthCheckFactory -> Maybe DispatcherConfigFactory -> Maybe SecretStoreFactory -> Array DeferredOutboundLifecycleReg -> Array DeferredInboundReg -> Array IntegrationRegistrationEntry -> Maybe ReadinessConfig -> Application +Application :: Maybe ConfigSpec -> Maybe EventStoreFactory -> Maybe QueryObjectStoreConfigValue -> Array QueryDefinition -> QueryRegistry -> Array ServiceRunner -> Map Text TransportValue -> Map Text QueryEndpointHandler -> Array OutboundRunner -> Array OutboundLifecycleRunner -> Array Inbound -> Maybe WebAuthFactory -> Maybe OAuth2Setup -> Maybe FileUploadFactory -> Maybe SecretStore -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe DispatcherConfig -> Maybe CorsFactory -> Maybe ApiInfoFactory -> Maybe HealthCheckFactory -> Maybe DispatcherConfigFactory -> Maybe SecretStoreFactory -> Array DeferredOutboundLifecycleReg -> Array DeferredInboundReg -> Array IntegrationRegistrationEntry -> Maybe ReadinessConfig -> Maybe Text -> Maybe Int -> Application DispatcherConfig :: Int -> Int -> Bool -> Int -> Int -> Maybe Int -> Int -> Int -> DispatcherConfig FileUploadSetup :: InternalFileUploadConfig -> BlobStore -> FileStateStore -> FileUploadSetup HealthCheckConfig :: Text -> HealthCheckConfig @@ -140,6 +140,8 @@ WebAuthSetup :: Text -> AuthOverrides -> WebAuthSetup [apiVersion] :: ApiInfo -> Text [authOverrides] :: WebAuthSetup -> AuthOverrides [authServerUrl] :: WebAuthSetup -> Text +[bindHost] :: Application -> Maybe Text +[bindPort] :: Application -> Maybe Int [blobStore] :: FileUploadSetup -> BlobStore [channelWriteTimeoutMs] :: DispatcherConfig -> Int [configSpec] :: Application -> Maybe ConfigSpec @@ -224,12 +226,14 @@ withDispatcherConfig :: Typeable config => (config -> DispatcherConfig) -> Appli withEventStore :: (Typeable config, EventStoreConfig eventStoreConfig) => (config -> eventStoreConfig) -> Application -> Application withFileUpload :: Typeable config => (config -> FileUploadConfig) -> Application -> Application withHealthCheck :: Typeable config => (config -> Text) -> Application -> Application +withHost :: Text -> Application -> Application withInbound :: Typeable config => (config -> Inbound) -> Application -> Application withIntegration :: (Integration request, Typeable request, Typeable (Response request), Inspectable request) => Application -> Application withOAuth2Provider :: Typeable config => (config -> OAuth2ProviderConfig) -> Application -> Application withOAuth2StateKey :: Text -> Application -> Application withOutbound :: (OutboundIntegration handler, entity ~ EntityOf handler, event ~ EventOf entity, event ~ HandledEvent handler, FromJSON entity, FromJSON event, FromJSON (EventOf entity), Inspectable entity, Default entity, Entity entity) => Application -> Application withOutboundLifecycle :: (Typeable config, Inspectable entity) => (config -> OutboundConfig state) -> Application -> Application +withPort :: Int -> Application -> Application withQuery :: forall query (queryName :: Symbol) (entities :: [Type]). (Query query, ToSchema query, ToJSON query, FromJSON query, queryName ~ NameOf query, entities ~ EntitiesOf query, KnownSymbol queryName, WireEntities entities query) => Application -> Application withQueryEndpoint :: Text -> QueryEndpointHandler -> Application -> Application withQueryObjectStore :: QueryObjectStoreConfig config => config -> Application -> Application @@ -248,7 +252,7 @@ withInbound :: Inbound -> (Array OutboundRunner, Array OutboundLifecycleRunner, withOutboundLifecycle :: Inspectable entity => OutboundConfig state -> (Array OutboundRunner, Array OutboundLifecycleRunner, Array Inbound) -> (Array OutboundRunner, Array OutboundLifecycleRunner, Array Inbound) module Service.Application.Transports -runTransports :: Map Text TransportValue -> Map Text (Map Text EndpointHandler) -> Map Text (Map Text EndpointSchema) -> Map Text QueryEndpointHandler -> Map Text EndpointSchema -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> QuerySubscriber -> Task Text Unit +runTransports :: Map Text TransportValue -> Map Text (Map Text EndpointHandler) -> Map Text (Map Text EndpointSchema) -> Map Text QueryEndpointHandler -> Map Text EndpointSchema -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe Text -> Maybe Int -> QuerySubscriber -> Task Text Unit module Service.Application.Types ApiInfo :: Text -> Text -> Text -> ApiInfo @@ -1778,7 +1782,7 @@ FileUploadEnabled :: FileUploadRoutes -> Int64 -> FileUploadEnabled HealthCheckConfig :: Text -> HealthCheckConfig IntegrationStatus :: !Text -> !Array Text -> IntegrationStatus OAuth2Config :: OAuth2Routes -> (Text -> Task Text Unit) -> OAuth2Config -WebTransport :: Int -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe (Task Text Readiness) -> WebTransport +WebTransport :: Int -> Text -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe (Task Text Readiness) -> WebTransport [allowedHeaders] :: CorsConfig -> Array Text [allowedMethods] :: CorsConfig -> Array Text [allowedOrigins] :: CorsConfig -> Array Text @@ -1792,6 +1796,7 @@ WebTransport :: Int -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe F [fileUploadRoutes] :: FileUploadEnabled -> FileUploadRoutes [healthCheck] :: WebTransport -> Maybe HealthCheckConfig [healthPath] :: HealthCheckConfig -> Text +[host] :: WebTransport -> Text [integrationStatus] :: WebTransport -> Maybe IntegrationStatus [jwksManager] :: AuthEnabled -> JwksManager [maxAge] :: CorsConfig -> Maybe Int @@ -1803,6 +1808,7 @@ WebTransport :: Int -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe F [readinessConfig] :: WebTransport -> Maybe ReadinessConfig [readinessProbe] :: WebTransport -> Maybe (Task Text Readiness) [routes] :: OAuth2Config -> OAuth2Routes +applyBindOverrides :: Maybe Text -> Maybe Int -> WebTransport -> WebTransport buildHealthResponse :: WebTransport -> ByteString data AuthEnabled data CorsConfig @@ -1811,6 +1817,7 @@ data HealthCheckConfig data IntegrationStatus data OAuth2Config data WebTransport +hostPreference :: Text -> HostPreference instance Data.Record.Anon.Plugin.Internal.Runtime.KnownHash "WebTransport" instance Service.Transport.Transport Service.Transport.Web.WebTransport isHealthCheckPath :: Text -> WebTransport -> Bool @@ -1820,6 +1827,9 @@ respondReadiness :: WebTransport -> (Response -> Task Text ResponseReceived) -> server :: WebTransport unauthorizedResponse :: AccessError -> (Status, Text) unauthorizedResponseBody :: Text -> Text +validateBindHost :: Text -> Maybe Text +validateBindPort :: Int -> Maybe Text +warpSettings :: WebTransport -> Settings module Service.Transport.Web.BuiltinSchemas fileUploadEndpointSchemas :: Bool -> Map Text EndpointSchema diff --git a/core/nhcore.cabal b/core/nhcore.cabal index 4a0a2b444..085792dd5 100644 --- a/core/nhcore.cabal +++ b/core/nhcore.cabal @@ -475,6 +475,7 @@ test-suite nhcore-test Service.Transport.Mcp.ResponseSpec Service.Transport.WebSpec Service.Transport.Web.SwaggerUISpec + Service.Transport.Web.BindSpec Service.Transport.Web.HealthCheckSpec Service.Transport.Web.ReadinessRouteSpec Service.QueryObjectStore.InMemorySpec @@ -630,6 +631,7 @@ test-suite nhcore-test-service Service.Transport.Mcp.ResponseSpec Service.MultiTenantSpec Service.Transport.WebSpec + Service.Transport.Web.BindSpec Service.Transport.Web.HealthCheckSpec Service.Transport.Web.ReadinessRouteSpec Service.Command.AuthSpec diff --git a/core/service/Service/Application.hs b/core/service/Service/Application.hs index f62ab76d8..b0b52df92 100644 --- a/core/service/Service/Application.hs +++ b/core/service/Service/Application.hs @@ -45,6 +45,8 @@ module Service.Application ( withCors, withHealthCheck, withoutHealthCheck, + withHost, + withPort, withDispatcherConfig, useQueryObjectStore, useReadinessEndpoint, @@ -405,7 +407,11 @@ data Application = Application integrationRegistrations :: Array IntegrationRegistrationEntry, -- | Readiness endpoint configuration. Enabled by default at /ready. -- Use useReadinessEndpoint to customize. - readinessConfig :: Maybe ReadinessConfig + readinessConfig :: Maybe ReadinessConfig, + -- | Interface the WebTransport binds. Set via withHost; Nothing keeps the transport's own host. + bindHost :: Maybe Text, + -- | Port the WebTransport binds. Set via withPort; Nothing keeps the transport's own port. + bindPort :: Maybe Int } @@ -443,7 +449,9 @@ new = deferredOutboundLifecycleRegs = Array.empty, deferredInboundRegs = Array.empty, integrationRegistrations = Array.empty, - readinessConfig = Just ReadinessConfig {readinessPath = "ready", includeQueryStatus = True} + readinessConfig = Just ReadinessConfig {readinessPath = "ready", includeQueryStatus = True}, + bindHost = Nothing, + bindPort = Nothing } @@ -1319,7 +1327,7 @@ runWithResolved eventStore maybeFileUploadSetup fileUploadCleanup maybeWebAuthSe -- When transports complete (or fail), cancel inbound workers for clean shutdown -- Use Task.finally to ensure cleanup always runs even if runTransports fails result <- - Transports.runTransports app.transports combinedEndpointsByTransport combinedSchemasByTransport combinedQueryEndpoints combinedQuerySchemas maybeAuthEnabled maybeOAuth2Config maybeFileUploadEnabled app.apiInfo app.corsConfig app.healthCheckConfig maybeIntegrationStatus app.readinessConfig subscriber + Transports.runTransports app.transports combinedEndpointsByTransport combinedSchemasByTransport combinedQueryEndpoints combinedQuerySchemas maybeAuthEnabled maybeOAuth2Config maybeFileUploadEnabled app.apiInfo app.corsConfig app.healthCheckConfig maybeIntegrationStatus app.readinessConfig app.bindHost app.bindPort subscriber |> Task.finally cleanupAll |> Task.asResult @@ -1791,6 +1799,67 @@ withoutHealthCheck app = app {healthCheckConfig = Nothing, healthCheckFactory = Nothing} +-- | Set the interface the WebTransport binds. +-- +-- Overrides the host of the registered 'Web.server', whatever the order of +-- 'withTransport' and 'withHost'. Without it the transport keeps the +-- registered transport's host; 'Web.server' defaults to all IPv4 interfaces +-- (@"*4"@, unchanged from the previous @Warp.run@). +-- +-- * @"127.0.0.1"@ (or any literal address such as @"::1"@): that address only. +-- Loopback-only suits a reverse proxy in the same network namespace (same +-- host or container, shared pod network). A proxy in a separate namespace +-- cannot reach a loopback listener; keep a non-loopback bind there. +-- * @"*"@: all interfaces, IPv4 and IPv6. +-- * @"*4"@ / @"*6"@: all IPv4 / all IPv6 interfaces. +-- +-- The value is checked when the server starts ('Web.validateBindHost'): an +-- empty host, a URL such as @"http://127.0.0.1"@, a @host:port@ pair or +-- whitespace fails 'run' with @Application.withHost: ...@ before any socket is +-- opened. An address this machine does not own fails at bind time with +-- @WebTransport could not bind :@. +-- +-- Example: +-- +-- @ +-- app = Application.new +-- |> Application.withTransport WebTransport.server +-- |> Application.withHost "127.0.0.1" +-- |> Application.withService myService +-- @ +withHost :: + Text -> + Application -> + Application +withHost host app = + app {bindHost = Just host} + + +-- | Set the port the WebTransport binds. +-- +-- Overrides the port of the registered 'Web.server' (default 8080), whatever +-- the order of 'withTransport' and 'withPort'. +-- +-- Accepted range is 1..65535 ('Web.validateBindPort'). Port 0 is rejected: +-- the OS would pick a port that nothing reports back. A port already in use +-- fails at bind time with @WebTransport could not bind :@. +-- +-- Example: +-- +-- @ +-- app = Application.new +-- |> Application.withTransport WebTransport.server +-- |> Application.withPort 9090 +-- |> Application.withService myService +-- @ +withPort :: + Int -> + Application -> + Application +withPort port app = + app {bindPort = Just port} + + -- | Validate dispatcher configuration fields are positive. -- Returns 'Just errorMessage' if validation fails, 'Nothing' if valid. validateDispatcherConfig :: Dispatcher.DispatcherConfig -> Maybe Text diff --git a/core/service/Service/Application/Transports.hs b/core/service/Service/Application/Transports.hs index b044c3180..38ae350ce 100644 --- a/core/service/Service/Application/Transports.hs +++ b/core/service/Service/Application/Transports.hs @@ -17,6 +17,7 @@ import Maybe qualified import Service.ServiceDefinition.Core (TransportValue (..)) import Service.Transport (Transport (..), QueryEndpointHandler, EndpointHandler, Endpoints (..), EndpointSchema (..)) import Service.Transport.Web (WebTransport (..), AuthEnabled, OAuth2Config, FileUploadEnabled (..), CorsConfig, HealthCheckConfig, IntegrationStatus) +import Service.Transport.Web qualified as Web import Service.Transport.Web.Readiness (ReadinessConfig) import Service.Application.Types (ApiInfo) import Service.Query.Subscriber (QuerySubscriber) @@ -58,10 +59,14 @@ runTransports :: -- ^ Optional integration selection status for /health reporting Maybe ReadinessConfig -> -- ^ Optional readiness endpoint configuration for WebTransport + Maybe Text -> + -- ^ Optional bind host override for WebTransport (Application.withHost) + Maybe Int -> + -- ^ Optional bind port override for WebTransport (Application.withPort) QuerySubscriber -> -- ^ The live subscriber whose readiness state /ready will reflect Task Text Unit -runTransports transportsMap endpointsByTransport schemasByTransport queryEndpoints querySchemas maybeWebAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig subscriber = do +runTransports transportsMap endpointsByTransport schemasByTransport queryEndpoints querySchemas maybeWebAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig maybeHost maybePort subscriber = do transportsMap |> Map.entries |> Task.forEach \(transportName, transportVal) -> do @@ -84,7 +89,7 @@ runTransports transportsMap endpointsByTransport schemasByTransport queryEndpoin -- Handle WebTransport specially to configure auth, OAuth2, and file uploads case transportName of - "WebTransport" -> runWebTransport transportVal commandEndpointsForTransport commandSchemasForTransport queryEndpoints querySchemas maybeWebAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig subscriber + "WebTransport" -> runWebTransport transportVal commandEndpointsForTransport commandSchemasForTransport queryEndpoints querySchemas maybeWebAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig maybeHost maybePort subscriber _ -> runGenericTransport transportVal commandEndpointsForTransport commandSchemasForTransport queryEndpoints querySchemas @@ -110,9 +115,11 @@ runWebTransport :: Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> + Maybe Text -> + Maybe Int -> QuerySubscriber -> Task Text Unit -runWebTransport transportVal commandEndpoints commandSchemas queryEndpoints querySchemas maybeAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig subscriber = do +runWebTransport transportVal commandEndpoints commandSchemas queryEndpoints querySchemas maybeAuth maybeOAuth2 maybeFileUpload maybeApiInfo maybeCors maybeHealthCheck maybeIntegrationStatus maybeReadinessConfig maybeHost maybePort subscriber = do case transportVal of TransportValue transport -> do -- Cast the existentially-typed transport to WebTransport @@ -137,6 +144,15 @@ runWebTransport transportVal commandEndpoints commandSchemas queryEndpoints quer , readinessConfig = maybeReadinessConfig , readinessProbe = Just (Subscriber.readinessOf subscriber) } + |> Web.applyBindOverrides maybeHost maybePort + -- Reject an unusable host or port here, before any socket is opened: + -- the error names the setting and reaches Application.run's caller. + case Web.validateBindHost webTransportWithConfig.host of + Just reason -> Task.throw [fmt|Application.withHost: #{reason}|] + Nothing -> pass + case Web.validateBindPort webTransportWithConfig.port of + Just reason -> Task.throw [fmt|Application.withPort: #{reason}|] + Nothing -> pass -- Build endpoints with the configured transport let endpoints :: Endpoints WebTransport = Endpoints diff --git a/core/service/Service/Transport/Web.hs b/core/service/Service/Transport/Web.hs index 58f8f91bb..5092846db 100644 --- a/core/service/Service/Transport/Web.hs +++ b/core/service/Service/Transport/Web.hs @@ -7,6 +7,11 @@ module Service.Transport.Web ( HealthCheckConfig (..), IntegrationStatus (..), server, + hostPreference, + warpSettings, + applyBindOverrides, + validateBindHost, + validateBindPort, isHealthCheckPath, buildHealthResponse, isReadinessPath, @@ -30,6 +35,7 @@ import Basics import Bytes (Bytes) import Bytes qualified import ConcurrentVar qualified +import Control.Exception (IOException) import Log qualified import Data.Aeson qualified as Aeson import Data.ByteString qualified as GhcBS @@ -42,6 +48,7 @@ import Json qualified import LinkedList qualified import Map qualified import Maybe (Maybe (..)) +import Maybe qualified import Network.HTTP.Types.Header qualified as HTTP import Network.HTTP.Types.Method qualified as GhcMethod import Network.HTTP.Types.Status qualified as HTTP @@ -148,6 +155,17 @@ data IntegrationStatus = IntegrationStatus -- | HTTP/JSON transport using WAI/Warp. data WebTransport = WebTransport { port :: Int, + -- | Interface to bind. Set via Application.withHost. + -- + -- * @"127.0.0.1"@ (or any literal address such as @"::1"@): that address only. + -- Loopback-only suits a reverse proxy that runs in the same network + -- namespace (same host, same container, or a shared pod network); a proxy + -- in a separate namespace cannot reach this listener through its own loopback. + -- * @"*4"@: all IPv4 interfaces (the default; what @Warp.run@ bound before). + -- * @"*"@: all interfaces, IPv4 and IPv6. @"*6"@: all IPv6 interfaces. + -- + -- Checked by 'validateBindHost' before the server starts. + host :: Text, maxBodySize :: Int, -- | Optional JWT authentication. Set via Application.withAuth. authEnabled :: Maybe AuthEnabled, @@ -181,6 +199,7 @@ deriveKnownHash "WebTransport" -- | Default WebTransport configuration. -- Port defaults to 8080. +-- Host defaults to "*4" (all IPv4 interfaces, unchanged from Warp.run) - use Application.withHost "127.0.0.1" to bind loopback only, or "*" to add IPv6. -- Max body size defaults to 1MB (1048576 bytes) to prevent DoS attacks. -- Auth is disabled by default - use Application.withAuth to enable. -- OAuth2 is disabled by default - use Application.withOAuth2Provider to enable. @@ -190,6 +209,7 @@ server :: WebTransport server = WebTransport { port = 8080, + host = "*4", maxBodySize = 1048576, authEnabled = Nothing, oauth2Config = Nothing, @@ -203,6 +223,84 @@ server = } +-- | Convert a 'WebTransport' host setting into a Warp 'Warp.HostPreference'. +-- +-- @"*"@ is all interfaces, @"*4"@ and @"*6"@ are all IPv4 / IPv6 interfaces, +-- anything else is a literal address or hostname. +hostPreference :: Text -> Warp.HostPreference +hostPreference hostText = + hostText + |> Text.toLinkedList + |> fromString + + +-- | Warp settings that bind the transport's configured host and port. +warpSettings :: WebTransport -> Warp.Settings +warpSettings transport = + Warp.defaultSettings + |> Warp.setPort transport.port + |> Warp.setHost (hostPreference transport.host) + + +-- | Apply the application-level bind overrides ('Application.withHost' / +-- 'Application.withPort') to a registered transport. An absent override keeps +-- the transport's own setting, so a custom @server { port = ... }@ survives +-- when only the host is overridden (and the other way round). Pure, so the +-- composition rule is testable without starting a server. +applyBindOverrides :: Maybe Text -> Maybe Int -> WebTransport -> WebTransport +applyBindOverrides maybeHost maybePort transport = + transport + { host = maybeHost |> Maybe.withDefault transport.host + , port = maybePort |> Maybe.withDefault transport.port + } + + +-- | Check a bind host before the server starts. Accepted forms are the Warp +-- wildcards (@"*"@, @"*4"@, @"*6"@) and a bare literal address or hostname +-- such as @"127.0.0.1"@, @"::1"@ or @"localhost"@. +-- +-- The checks target the mistakes a hand-written or LLM-written config makes: +-- an empty or blank host, whitespace anywhere (including a leading or +-- trailing space, tab or newline), a URL (@"http://127.0.0.1"@), a path, or a +-- @host:port@ pair pasted into the host field. A single colon can only be a +-- port suffix because a literal IPv6 address always contains at least two. +-- Anything that passes is handed to Warp as a 'Warp.HostPreference'; an +-- address this machine does not own still fails at bind time with the +-- @could not bind@ error from 'runTransport'. +-- +-- Returns the reason the host is rejected, or 'Nothing' when it is usable. +validateBindHost :: Text -> Maybe Text +validateBindHost hostText = do + let colonCount = hostText |> Text.indexes ":" |> Array.length + let containsWhitespace = Text.words hostText != Array.wrap hostText + if Text.isEmpty (Text.trim hostText) + then Just "bind host must not be empty; use \"*4\" for all IPv4 interfaces or \"127.0.0.1\" for loopback only" + else + if containsWhitespace + then Just [fmt|bind host "#{hostText}" must not contain whitespace|] + else + if Text.contains "/" hostText + then Just [fmt|bind host "#{hostText}" looks like a URL or path; use a bare address such as "127.0.0.1", not "http://127.0.0.1"|] + else + if colonCount == 1 + then Just [fmt|bind host "#{hostText}" carries a port; set the port with Application.withPort instead|] + else Nothing + + +-- | Check a bind port before the server starts. Only 1..65535 is accepted. +-- Port 0 is rejected on purpose: the OS would pick a free port, but nothing in +-- the application reports which one, so the server would be unreachable by +-- design. Returns the reason the port is rejected, or 'Nothing' when usable. +validateBindPort :: Int -> Maybe Text +validateBindPort portNumber = + if portNumber == 0 + then Just "bind port 0 asks the OS for a random port that nothing reports back; choose a fixed port between 1 and 65535" + else + if portNumber < 0 || portNumber > 65535 + then Just [fmt|bind port #{portNumber} is outside 1..65535|] + else Nothing + + -- | Read request body with a size limit to prevent DoS attacks. -- Returns Err if the body exceeds the limit, Ok with the body bytes otherwise. readBodyWithLimit :: Int -> Wai.Request -> Task Text (Result Text Bytes) @@ -1044,12 +1142,17 @@ instance Transport WebTransport where Maybe.Nothing -> baseApp Maybe.Just cors -> corsMiddleware cors baseApp - -- Start the Warp server on the specified port + -- Start the Warp server on the configured host and port. A bind that the + -- OS refuses (port in use, address not owned by this machine) surfaces as + -- a Task error naming the host and port instead of an uncaught IOException. + let host = transport.host let port = transport.port Log.withScope [("component", "WebTransport")] do - Log.info [fmt|Starting WebTransport server on port #{port}|] + Log.info [fmt|Starting WebTransport server on #{host}:#{port}|] |> Task.ignoreError - Warp.run transport.port waiApp |> Task.fromIO + Warp.runSettings (warpSettings transport) waiApp + |> Task.fromFailableIO @IOException + |> Task.mapError (\ioError -> [fmt|WebTransport could not bind #{host}:#{port}: #{show ioError}|]) buildHandler :: diff --git a/core/test-service/Main.hs b/core/test-service/Main.hs index f00a9f639..3c83bb6bd 100644 --- a/core/test-service/Main.hs +++ b/core/test-service/Main.hs @@ -44,6 +44,7 @@ import Service.Transport.Mcp.JsonRpcSpec qualified import Service.Transport.Mcp.ProtocolSpec qualified import Service.Transport.Mcp.ResponseSpec qualified import Service.Transport.WebSpec qualified +import Service.Transport.Web.BindSpec qualified import Service.Transport.Web.HealthCheckSpec qualified import Service.Transport.Web.ReadinessRouteSpec qualified import Service.Command.AuthSpec qualified @@ -99,6 +100,7 @@ main = Hspec.hspec do Hspec.describe "Service.Transport.Mcp.Protocol" Service.Transport.Mcp.ProtocolSpec.spec Hspec.describe "Service.Transport.Mcp.Response" Service.Transport.Mcp.ResponseSpec.spec Hspec.describe "Service.Transport.Web" Service.Transport.WebSpec.spec + Hspec.describe "Service.Transport.Web.Bind" Service.Transport.Web.BindSpec.spec Hspec.describe "Health Check" Service.Transport.Web.HealthCheckSpec.spec Hspec.describe "Service.Transport.Web.ReadinessRoute" Service.Transport.Web.ReadinessRouteSpec.spec Hspec.describe "Service.Command.Auth" Service.Command.AuthSpec.spec diff --git a/core/test/Service/Transport/Web/BindSpec.hs b/core/test/Service/Transport/Web/BindSpec.hs new file mode 100644 index 000000000..88ed65fa6 --- /dev/null +++ b/core/test/Service/Transport/Web/BindSpec.hs @@ -0,0 +1,615 @@ +module Service.Transport.Web.BindSpec where + +import Array qualified +import Bytes qualified +import Json qualified +import Data.Either qualified as GhcEither +import Service.EventStore (EventStore (..)) +import AsyncTask qualified +import Core +import Http.Client qualified as Http +import Http.Client.Internal qualified as HttpInternal +import IO qualified +import Data.IORef qualified as GhcIORef +import Control.Exception qualified as GhcException +import Network.Wai qualified as GhcWai +import Network.HTTP.Types qualified as GhcHttp +import Maybe qualified +import Network.Socket qualified as GhcSocket +import Network.Wai.Handler.Warp qualified as GhcWarp +import Service.Application (Application (..)) +import Service.Application qualified as Application +import Service.EventStore.InMemory qualified as InMemory +import Service.Transport.Web (WebTransport (..), applyBindOverrides, hostPreference, server, validateBindHost, validateBindPort, warpSettings) +import Task qualified +import Test +import Text qualified +import Uuid qualified + + +spec :: Spec Unit +spec = do + describe "WebTransport bind host and port" do + describe "defaults" do + it "server binds all IPv4 interfaces by default (unchanged from Warp.run)" \_ -> do + server.host |> shouldBe "*4" + + it "server listens on port 8080 by default" \_ -> do + server.port |> shouldBe 8080 + + describe "Application builders" do + it "withHost records the bind host" \_ -> do + let app = Application.new |> Application.withHost "127.0.0.1" + app.bindHost |> shouldBe (Just "127.0.0.1") + + it "withPort records the bind port" \_ -> do + let app = Application.new |> Application.withPort 9090 + app.bindPort |> shouldBe (Just 9090) + + it "bind host and port are unset on a new Application" \_ -> do + Application.new.bindHost |> shouldBe Nothing + Application.new.bindPort |> shouldBe Nothing + + describe "hostPreference" do + it "maps a literal IPv4 address to that host" \_ -> do + show (hostPreference "127.0.0.1") |> shouldBe "Host \"127.0.0.1\"" + + it "maps * to all interfaces" \_ -> do + show (hostPreference "*") |> shouldBe "HostAny" + + it "maps *4 to all IPv4 interfaces" \_ -> do + show (hostPreference "*4") |> shouldBe "HostIPv4" + + it "maps *6 to all IPv6 interfaces" \_ -> do + show (hostPreference "*6") |> shouldBe "HostIPv6" + + it "maps a literal IPv6 address to that host" \_ -> do + show (hostPreference "::1") |> shouldBe "Host \"::1\"" + + describe "override composition" do + it "withHost and withPort apply whether they come before or after withTransport" \_ -> do + let before = + Application.new + |> Application.withHost "127.0.0.1" + |> Application.withPort 9191 + |> Application.withTransport server + let after = + Application.new + |> Application.withTransport server + |> Application.withHost "127.0.0.1" + |> Application.withPort 9191 + let bound app = applyBindOverrides app.bindHost app.bindPort server + (bound before).host |> shouldBe "127.0.0.1" + (bound before).port |> shouldBe 9191 + (bound after).host |> shouldBe "127.0.0.1" + (bound after).port |> shouldBe 9191 + + it "absent overrides preserve the transport's custom host and port" \_ -> do + let untouched = applyBindOverrides Nothing Nothing customTransport + untouched.host |> shouldBe "::1" + untouched.port |> shouldBe 7070 + + it "a host-only override keeps the transport's custom port" \_ -> do + let hostOnly = applyBindOverrides (Just "127.0.0.1") Nothing customTransport + hostOnly.host |> shouldBe "127.0.0.1" + hostOnly.port |> shouldBe 7070 + + it "a port-only override keeps the transport's custom host" \_ -> do + let portOnly = applyBindOverrides Nothing (Just 9191) customTransport + portOnly.host |> shouldBe "::1" + portOnly.port |> shouldBe 9191 + + describe "validateBindHost" do + it "accepts the Warp wildcards and bare literal addresses or hostnames" \_ -> do + let accepted = ["*", "*4", "*6", "127.0.0.1", "0.0.0.0", "::1", "::", "fe80::1", "localhost", "app.internal"] + let rejected = accepted |> Array.takeIf (\candidate -> validateBindHost candidate != Nothing) + rejected |> shouldBe [] + + it "rejects an empty or blank host" \_ -> do + validateBindHost "" |> shouldSatisfy (\reason -> reason != Nothing) + validateBindHost " " |> shouldSatisfy (\reason -> reason != Nothing) + + it "rejects a URL pasted into the host field" \_ -> do + let reason = validateBindHost "http://127.0.0.1" |> Maybe.withDefault "" + reason |> shouldSatisfy (Text.contains "URL") + + it "rejects a host that carries a port" \_ -> do + let reason = validateBindHost "127.0.0.1:8080" |> Maybe.withDefault "" + reason |> shouldSatisfy (Text.contains "withPort") + + it "rejects bracketed IPv6 host-port before startup" \_ -> do + validateBindHost "::1" |> shouldBe Nothing + case validateBindHost "[::1]:8080" of + Nothing -> fail "REGRESSION_ASSERT:bracketed-host-port-accepted" + Just reason -> reason |> shouldSatisfy (Text.contains "withPort") + + it "rejects malformed brackets and preserves bare IPv6" \_ -> do + validateBindHost "fe80::1" |> shouldBe Nothing + let bracketed = ["[::1", "::1]", "[::1]trailing"] + let accepted = bracketed |> Array.takeIf (\candidate -> validateBindHost candidate == Nothing) + accepted |> shouldBe [] + + it "rejects a host with whitespace inside" \_ -> do + validateBindHost "127.0.0.1 8080" |> shouldSatisfy (\reason -> reason != Nothing) + + it "rejects a host with leading or trailing spaces" \_ -> do + validateBindHost "127.0.0.1" |> shouldBe Nothing + let padded = [" 127.0.0.1", "127.0.0.1 ", " 127.0.0.1 "] + let accepted = padded |> Array.takeIf (\candidate -> isWhitespaceRejection candidate |> not) + accepted |> shouldBe [] + + it "rejects a host surrounded by tabs or newlines" \_ -> do + validateBindHost "localhost" |> shouldBe Nothing + let padded = ["\tlocalhost", "localhost\n", "\r\nlocalhost\t"] + let accepted = padded |> Array.takeIf (\candidate -> isWhitespaceRejection candidate |> not) + accepted |> shouldBe [] + + describe "validateBindPort" do + it "accepts the full 1..65535 range" \_ -> do + validateBindPort 1 |> shouldBe Nothing + validateBindPort 8080 |> shouldBe Nothing + validateBindPort 65535 |> shouldBe Nothing + + it "rejects port 0 and ports outside the range" \_ -> do + let reason = validateBindPort 0 |> Maybe.withDefault "" + reason |> shouldSatisfy (Text.contains "random port") + validateBindPort (-1) |> shouldSatisfy (\outOfRange -> outOfRange != Nothing) + validateBindPort 65536 |> shouldSatisfy (\outOfRange -> outOfRange != Nothing) + + describe "warpSettings" do + it "carries the configured host and port into Warp" \_ -> do + let transport = server {host = "127.0.0.1", port = 9191} + let settings = warpSettings transport + show (GhcWarp.getHost settings) |> shouldBe "Host \"127.0.0.1\"" + GhcWarp.getPort settings |> shouldBe 9191 + + describe "Application.runWith registered bind settings" do + it "applies host and port set before withTransport at runtime" \_ -> do + withHeldLoopbackPort (GhcSocket.tupleToHostAddress (127, 0, 0, 1)) \occupiedPort -> do + freePort <- getDifferentFreePort occupiedPort + let custom = server {host = "*4", port = occupiedPort} + let app = Application.new + |> Application.withHost "127.0.0.1" + |> Application.withPort freePort + |> Application.withTransport custom + withOwnedBindAt freePort app + + it "applies host and port set after withTransport at runtime" \_ -> do + withHeldLoopbackPort (GhcSocket.tupleToHostAddress (127, 0, 0, 1)) \occupiedPort -> do + freePort <- getDifferentFreePort occupiedPort + let custom = server {host = "*4", port = occupiedPort} + let app = Application.new + |> Application.withTransport custom + |> Application.withHost "127.0.0.1" + |> Application.withPort freePort + withOwnedBindAt freePort app + + it "preserves a custom registered host and port with absent overrides at runtime" \_ -> do + freePort <- getOwnedFreePort + let custom = server {host = "127.0.0.1", port = freePort} + let app = Application.new |> Application.withTransport custom + withOwnedBindAt freePort app + + it "preserves a custom registered port with a host-only override at runtime" \_ -> do + freePort <- getOwnedFreePort + let custom = server {host = "*4", port = freePort} + let app = Application.new + |> Application.withTransport custom + |> Application.withHost "127.0.0.1" + withOwnedBindAt freePort app + + it "preserves a custom registered host with a port-only override at runtime" \_ -> do + withHeldLoopbackPort (GhcSocket.tupleToHostAddress (127, 0, 0, 1)) \occupiedPort -> do + freePort <- getDifferentFreePort occupiedPort + let custom = server {host = "127.0.0.1", port = occupiedPort} + let app = Application.new + |> Application.withTransport custom + |> Application.withPort freePort + withOwnedBindAt freePort app + + describe "owned runtime probe controls" do + it "accepts the intended Application and excludes another owned interface" \_ -> do + _ <- ownedNonLoopbackAddress + freePort <- getOwnedFreePort + let app = Application.new + |> Application.withTransport server + |> Application.withHost "127.0.0.1" + |> Application.withPort freePort + withOwnedBindAt freePort app + + it "a wildcard listener defeats the owned-interface bind probe" \_ -> do + otherAddress <- ownedNonLoopbackAddress + eventStore <- InMemory.new |> Task.mapError toText + freePort <- getOwnedFreePort + (app, hits, body) <- newIdentityApplication + (Application.new + |> Application.withTransport server + |> Application.withPort freePort) + let probe = do + owned <- probeOwnedInstance hits body freePort 50 + owned |> shouldBe True + available <- canBindAddress otherAddress freePort + available |> shouldBe False + let run = AsyncTask.process (Application.runWith eventStore app) \running -> do + outcome <- AsyncTask.race (AsyncTask.waitCatch running) probe + case outcome of + AsyncTask.LeftWon result -> Task.throw [fmt|wildcard Application ended early: #{show result}|] + AsyncTask.RightWon _ -> pass + run |> Task.finally eventStore.close + + it "rejects an unrelated catch-all 200 after the intended Application bind fails" \_ -> do + eventStore <- InMemory.new |> Task.mapError toText + (identified, hits, body) <- newIdentityApplication Application.new + -- Even copying the expected body is insufficient to impersonate the + -- owned query handler. The control must actually receive a request. + competitorHits <- GhcIORef.newIORef (0 :: Int) |> Task.fromIO + let competitor _ respond = do + GhcIORef.atomicModifyIORef' competitorHits (\n -> (n + 1, ())) + respond (GhcWai.responseLBS GhcHttp.status200 [] + (body |> Text.toBytes |> Bytes.toLazyLegacy)) + let exercise = do + outcome <- Task.fromIO do + GhcWarp.testWithApplication (pure competitor) \port -> Task.runResult do + let app = identified + |> Application.withTransport server + |> Application.withHost "127.0.0.1" + |> Application.withPort port + -- First prove the intended Application cannot bind. Do not + -- assume task failure merely because a probe rejected it. + result <- Application.runWith eventStore app |> Task.asResult + case result of + Ok _ -> fail "intended Application unexpectedly took the competitor's port" + Err err -> err |> shouldSatisfy + (Text.contains [fmt|could not bind 127.0.0.1:#{port}|]) + owned <- probeOwnedInstance hits body port 0 + owned |> shouldBe False + count <- GhcIORef.readIORef hits |> Task.fromIO + count |> shouldBe 0 + received <- GhcIORef.readIORef competitorHits |> Task.fromIO + received |> shouldSatisfy (\n -> n > 0) + case outcome of + Err err -> Task.throw err + Ok _ -> pass + exercise |> Task.finally eventStore.close + + describe "running" do + it "serves /health on loopback when bound to 127.0.0.1" \_ -> do + -- A unique path alone is not identity; the owned handler must also run. + eventStore <- InMemory.new |> Task.mapError toText + freePort <- getFreePort + healthPath <- uniqueHealthPath + let app = + Application.new + |> Application.withTransport server + |> Application.withHost "127.0.0.1" + |> Application.withPort freePort + |> Application.withHealthCheck @() (\_ -> healthPath) + (ownedApp, hits, body) <- newIdentityApplication app + running <- AsyncTask.run (Application.runWith eventStore ownedApp) + let cancelApp = AsyncTask.cancel running |> Task.ignoreError + let probe = do + owned <- probeOwnedInstance hits body freePort 50 + owned |> shouldBe True + status <- getHealthStatus healthPath freePort 50 + status |> shouldBe 200 + -- Loopback isolation: the port is still free on a non-loopback + -- address, which a wildcard listener would have taken as well. + nonLoopback <- nonLoopbackAddress + canBind <- canBindElsewhere nonLoopback freePort + canBind |> shouldBe True + probe |> Task.finally cancelApp + + it "a wildcard bind occupies the port on every address (negative control for the loopback probe)" \_ -> do + eventStore <- InMemory.new |> Task.mapError toText + freePort <- getFreePort + healthPath <- uniqueHealthPath + let app = + Application.new + |> Application.withTransport server + |> Application.withPort freePort + |> Application.withHealthCheck @() (\_ -> healthPath) + (ownedApp, hits, body) <- newIdentityApplication app + running <- AsyncTask.run (Application.runWith eventStore ownedApp) + let cancelApp = AsyncTask.cancel running |> Task.ignoreError + let probe = do + owned <- probeOwnedInstance hits body freePort 50 + owned |> shouldBe True + status <- getHealthStatus healthPath freePort 50 + status |> shouldBe 200 + nonLoopback <- nonLoopbackAddress + canBind <- canBindElsewhere nonLoopback freePort + canBind |> shouldBe False + probe |> Task.finally cancelApp + + it "rejects invalid static bind before run acquires an event store" \_ -> do + let app = + Application.new + |> Application.withTransport server + |> Application.withPort 0 + result <- Application.run app |> Task.asResult + result |> shouldBe (Err "Application.withPort: bind port 0 asks the OS for a random port that nothing reports back; choose a fixed port between 1 and 65535") + + it "rejects invalid static bind before owned auth discovery" \_ -> do + requests <- GhcIORef.newIORef (0 :: Int) |> Task.fromIO + let discovery _ respond = do + GhcIORef.modifyIORef' requests (+ 1) + respond (GhcWai.responseLBS GhcHttp.status200 [] "not-json") + (result, count) <- Task.fromIO do + GhcWarp.testWithApplication (pure discovery) \authPort -> do + outcome <- IO.try (Task.runResult do + -- The owned fixture is live before the invalid application starts. + status <- getHealthStatus "fixture-control" authPort 0 + status |> shouldBe 200 + GhcIORef.writeIORef requests 0 |> Task.fromIO + eventStore <- InMemory.new |> Task.mapError toText + let app = + Application.new + |> Application.withTransport server + |> Application.withHost "http://127.0.0.1" + |> Application.withAuth @() (\_ -> [fmt|http://127.0.0.1:#{authPort}|]) + Application.runWith eventStore app |> Task.asResult) + case outcome of + Err err -> case GhcException.fromException err of + Just (asyncError :: GhcException.SomeAsyncException) -> GhcException.throwIO asyncError + Nothing -> pure () + Ok _ -> pure () + count <- GhcIORef.readIORef requests + pure (outcome, count) + case count of + 0 -> pass + _ -> fail "REGRESSION_ASSERT:invalid-bind-contacted-auth" + case result of + Err err -> fail [fmt|unexpected startup exception: #{toText err}|] + Ok (Err err) -> fail [fmt|owned auth fixture failed: #{err}|] + Ok (Ok appResult) -> case appResult of + Ok _ -> fail "runWith accepted an invalid host" + Err err -> err |> shouldBe "Application.withHost: bind host \"http://127.0.0.1\" looks like a URL or path; use a bare address such as \"127.0.0.1\", not \"http://127.0.0.1\"" + + it "an invalid host fails before any socket is opened" \_ -> do + eventStore <- InMemory.new |> Task.mapError toText + let app = + Application.new + |> Application.withTransport server + |> Application.withHost "http://127.0.0.1" + result <- Application.runWith eventStore app |> Task.asResult + case result of + Ok _ -> fail "runWith accepted a URL as the bind host" + Err err -> err |> shouldSatisfy (Text.startsWith "Application.withHost:") + + it "an invalid port fails before any socket is opened" \_ -> do + eventStore <- InMemory.new |> Task.mapError toText + let app = + Application.new + |> Application.withTransport server + |> Application.withPort 0 + result <- Application.runWith eventStore app |> Task.asResult + case result of + Ok _ -> fail "runWith accepted port 0" + Err err -> err |> shouldSatisfy (Text.startsWith "Application.withPort:") + + it "a port already in use fails with an error naming the host and port" \_ -> do + eventStore <- InMemory.new |> Task.mapError toText + (occupied, occupiedPort) <- occupyLoopbackPort + let app = + Application.new + |> Application.withTransport server + |> Application.withHost "127.0.0.1" + |> Application.withPort occupiedPort + let attempt = do + result <- Application.runWith eventStore app |> Task.asResult + case result of + Ok _ -> fail "runWith started on a port that was already in use" + Err err -> err |> shouldSatisfy (Text.contains [fmt|could not bind 127.0.0.1:#{occupiedPort}|]) + attempt |> Task.finally (GhcSocket.close occupied |> Task.fromIO) + + +-- A successful response must have run this instance's handler. The body alone +-- is not sufficient: the catch-all negative control deliberately copies it. +newIdentityApplication :: Application -> Task Text (Application, GhcIORef.IORef Int, Text) +newIdentityApplication app = do + nonce <- uniqueHealthPath + hits <- GhcIORef.newIORef (0 :: Int) |> Task.fromIO + let body = Json.encodeText nonce + let handler _ _ _ = do + GhcIORef.atomicModifyIORef' hits (\n -> (n + 1, ())) |> Task.fromIO + Task.yield body + Task.yield (app |> Application.withQueryEndpoint "BindProbe" handler, hits, body) + + +probeOwnedInstance :: GhcIORef.IORef Int -> Text -> Int -> Int -> Task Text Bool +probeOwnedInstance hits expectedBody port attemptsLeft = do + result <- + Http.request + |> Http.withUrl [fmt|http://127.0.0.1:#{port}/queries/bind-probe|] + |> Http.withTimeout 2 + |> HttpInternal.getRaw + |> Task.asResult + case result of + Ok response -> do + count <- GhcIORef.readIORef hits |> Task.fromIO + Task.yield + ( response.statusCode == 200 + && Text.fromBytes response.body == expectedBody + && count > 0 + ) + Err _ -> + if attemptsLeft <= 0 then + Task.throw "owned Application listener never answered" + else do + AsyncTask.sleep 100 + probeOwnedInstance hits expectedBody port (attemptsLeft - 1) + + +-- Never treat nonLoopbackAddress's fallback as a distinct-interface proof. +ownedNonLoopbackAddress :: Task Text GhcSocket.HostAddress +ownedNonLoopbackAddress = do + address <- nonLoopbackAddress + let (firstOctet, _, _, _) = GhcSocket.hostAddressToTuple address + firstOctet |> shouldSatisfy (\octet -> octet != 127 && octet != 0) + preflight <- canBindAddress address 0 + preflight |> shouldBe True + Task.yield address + + +assertLiteralLoopbackBind :: Int -> Task Text Unit +assertLiteralLoopbackBind port = do + address <- ownedNonLoopbackAddress + available <- canBindAddress address port + available |> shouldBe True + + +withOwnedBindAt :: Int -> Application -> Task Text Unit +withOwnedBindAt port configured = do + eventStore <- InMemory.new |> Task.mapError toText + (app, hits, body) <- newIdentityApplication configured + let probe = do + owned <- probeOwnedInstance hits body port 50 + owned |> shouldBe True + assertLiteralLoopbackBind port + let run = + AsyncTask.process (Application.runWith eventStore app) \running -> do + outcome <- AsyncTask.race (AsyncTask.waitCatch running) probe + case outcome of + AsyncTask.LeftWon result -> + Task.throw [fmt|Application ended before the owned bind probe: #{show result}|] + AsyncTask.RightWon _ -> pass + run |> Task.finally eventStore.close + + +-- Use this rather than broad IO.try for NEW socket probes. Catch only IOException; +-- asynchronous cancellation must propagate through bracket, not become False. +canBindAddress :: GhcSocket.HostAddress -> Int -> Task Text Bool +canBindAddress address port = Task.fromIO do + GhcException.bracket + (GhcSocket.socket GhcSocket.AF_INET GhcSocket.Stream GhcSocket.defaultProtocol) + GhcSocket.close + \sock -> do + outcome <- GhcException.try @GhcException.IOException + (GhcSocket.bind sock (GhcSocket.SockAddrInet (fromIntegral port) address)) + case outcome of + GhcEither.Left _ -> pure False + GhcEither.Right _ -> pure True + + +-- The loopback port reservation is held throughout action. +withHeldLoopbackPort :: GhcSocket.HostAddress -> (Int -> Task Text value) -> Task Text value +withHeldLoopbackPort address action = do + result <- Task.fromIO do + GhcException.bracket + (GhcSocket.socket GhcSocket.AF_INET GhcSocket.Stream GhcSocket.defaultProtocol) + GhcSocket.close + \sock -> do + GhcSocket.bind sock (GhcSocket.SockAddrInet 0 address) + GhcSocket.listen sock 1 + port <- GhcSocket.socketPort sock + Task.runResult (action (fromIntegral port)) + case result of + Ok value -> Task.yield value + Err err -> Task.throw err + + +getOwnedFreePort :: Task Text Int +getOwnedFreePort = + withHeldLoopbackPort (GhcSocket.tupleToHostAddress (127, 0, 0, 1)) Task.yield + + +getDifferentFreePort :: Int -> Task Text Int +getDifferentFreePort excluded = do + port <- getOwnedFreePort + if port == excluded then getDifferentFreePort excluded else Task.yield port + +-- | Does 'validateBindHost' reject this host because of whitespace? +isWhitespaceRejection :: Text -> Bool +isWhitespaceRejection candidate = + validateBindHost candidate + |> Maybe.withDefault "" + |> Text.contains "whitespace" + + +-- | A transport with a custom host and port, for the single-setting cases. +customTransport :: WebTransport +customTransport = server {host = "::1", port = 7070} + + +-- | A health path no other test (or stray process) serves. +uniqueHealthPath :: Task Text Text +uniqueHealthPath = do + uuid <- Uuid.generate + let suffix = Uuid.toText uuid |> Text.replace "-" "" + Task.yield [fmt|health-#{suffix}|] + + +-- | Ask the OS for a currently free loopback port. +getFreePort :: Task Text Int +getFreePort = do + let hints = GhcSocket.defaultHints {GhcSocket.addrSocketType = GhcSocket.Stream} + addrInfos <- GhcSocket.getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") |> Task.fromIO + case addrInfos of + [] -> Task.throw "no loopback address available" + (addr : _) -> do + sock <- GhcSocket.openSocket addr |> Task.fromIO + GhcSocket.bind sock (GhcSocket.addrAddress addr) |> Task.fromIO + port <- GhcSocket.socketPort sock |> Task.fromIO + GhcSocket.close sock |> Task.fromIO + Task.yield (fromIntegral port) + + +-- | Hold a loopback port open so a later bind on it must fail. +occupyLoopbackPort :: Task Text (GhcSocket.Socket, Int) +occupyLoopbackPort = do + let hints = GhcSocket.defaultHints {GhcSocket.addrSocketType = GhcSocket.Stream} + addrInfos <- GhcSocket.getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") |> Task.fromIO + case addrInfos of + [] -> Task.throw "no loopback address available" + (addr : _) -> do + sock <- GhcSocket.openSocket addr |> Task.fromIO + GhcSocket.bind sock (GhcSocket.addrAddress addr) |> Task.fromIO + GhcSocket.listen sock 1 |> Task.fromIO + port <- GhcSocket.socketPort sock |> Task.fromIO + Task.yield (sock, fromIntegral port) + + +-- | An IPv4 address of this machine that is not loopback. The OS fills it in +-- when a UDP socket is pointed at a routable address; nothing is sent. +nonLoopbackAddress :: Task Text GhcSocket.HostAddress +nonLoopbackAddress = Task.fromIO do + sock <- GhcSocket.socket GhcSocket.AF_INET GhcSocket.Datagram GhcSocket.defaultProtocol + GhcSocket.connect sock (GhcSocket.SockAddrInet 9 (GhcSocket.tupleToHostAddress (10, 255, 255, 255))) + localName <- GhcSocket.getSocketName sock + GhcSocket.close sock + case localName of + GhcSocket.SockAddrInet _ address -> pure address + _ -> pure (GhcSocket.tupleToHostAddress (127, 0, 0, 1)) + + +-- | Can a fresh TCP socket still bind @address:port@? True when the running +-- server only holds loopback, False when a wildcard listener owns the port on +-- every address. Warp sets SO_REUSEADDR, so this probe discriminates on +-- address, not on the reuse flag. +canBindElsewhere :: GhcSocket.HostAddress -> Int -> Task Text Bool +canBindElsewhere address port = Task.fromIO do + sock <- GhcSocket.socket GhcSocket.AF_INET GhcSocket.Stream GhcSocket.defaultProtocol + outcome <- GhcSocket.bind sock (GhcSocket.SockAddrInet (fromIntegral port) address) |> IO.try + GhcSocket.close sock + case outcome of + Ok _ -> pure True + Err _ -> pure False + + +-- | GET the health path on loopback, retrying while the server is still binding. +getHealthStatus :: Text -> Int -> Int -> Task Text Int +getHealthStatus healthPath port attemptsLeft = do + result <- + Http.request + |> Http.withUrl [fmt|http://127.0.0.1:#{port}/#{healthPath}|] + |> Http.withTimeout 2 + |> HttpInternal.getRaw + |> Task.asResult + case result of + Ok response -> Task.yield response.statusCode + Err _ -> + if attemptsLeft <= 0 + then Task.throw "/health never answered on the bound loopback port" + else do + AsyncTask.sleep 100 + getHealthStatus healthPath port (attemptsLeft - 1) diff --git a/docs/changes/019-server-bind-host-port.md b/docs/changes/019-server-bind-host-port.md new file mode 100644 index 000000000..5bc4665fc --- /dev/null +++ b/docs/changes/019-server-bind-host-port.md @@ -0,0 +1,105 @@ +# Change 019: Make the Warp bind host and port configurable + +The web server always bound Warp's default host on a port fixed in code, so an +app running behind a reverse proxy could not restrict itself to loopback and +could not choose its port without building a `WebTransport` by hand. The +maintainer accepted a loopback-bind fix and asked to "make the port configurable +too". `WebTransport` gains a `host` field (default `"*4"`, all IPv4 interfaces — +exactly what `Warp.run` bound before, so behaviour is unchanged) and `Application` gains `withHost` and `withPort` +builders next to the other `with*` builders. `runTransport` now starts Warp with +`runSettings` built from that host and port, and logs `:`. + +Input contract: the host is a Warp wildcard (`"*"`, `"*4"`, `"*6"`) or a bare +literal address / hostname; the port is `1..65535`. An empty host, a URL or path +in the host field, a `host:port` pair, whitespace, port `0` or an out-of-range +port is rejected before any socket is opened, with an error that names the +builder (`Application.withHost: …` / `Application.withPort: …`). A bind the OS +refuses (port in use, address not owned) fails with +`WebTransport could not bind :: …` instead of an uncaught +`IOException`; the `Task.finally` cleanup in `Application.run` still releases +the resources the run owns (JWKS manager, dispatcher, file upload). + +```yaml spec +issue: adhoc:server-bind-host-port +kind: feature +touches: [http-transport] +breaking: true +new-dependency: false +new-capability: false +new-extension-point: false +``` + +## Contract delta + +`WebTransport` and `Application` are public records, so adding a field changes +their constructor signature lines (a `-`/`+` pair each). `runTransports` gains +the two optional overrides that carry `withHost` / `withPort` to the transport. +`hostPreference` and `warpSettings` are the small, testable conversion from the +transport's host and port to Warp settings. `applyBindOverrides` is the pure +override rule; `validateBindHost` / `validateBindPort` are the pure input checks +that `runWebTransport` runs before starting Warp. + +```diff signatures +- Service.Application: Application :: Maybe ConfigSpec -> Maybe EventStoreFactory -> Maybe QueryObjectStoreConfigValue -> Array QueryDefinition -> QueryRegistry -> Array ServiceRunner -> Map Text TransportValue -> Map Text QueryEndpointHandler -> Array OutboundRunner -> Array OutboundLifecycleRunner -> Array Inbound -> Maybe WebAuthFactory -> Maybe OAuth2Setup -> Maybe FileUploadFactory -> Maybe SecretStore -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe DispatcherConfig -> Maybe CorsFactory -> Maybe ApiInfoFactory -> Maybe HealthCheckFactory -> Maybe DispatcherConfigFactory -> Maybe SecretStoreFactory -> Array DeferredOutboundLifecycleReg -> Array DeferredInboundReg -> Array IntegrationRegistrationEntry -> Maybe ReadinessConfig -> Application ++ Service.Application: Application :: Maybe ConfigSpec -> Maybe EventStoreFactory -> Maybe QueryObjectStoreConfigValue -> Array QueryDefinition -> QueryRegistry -> Array ServiceRunner -> Map Text TransportValue -> Map Text QueryEndpointHandler -> Array OutboundRunner -> Array OutboundLifecycleRunner -> Array Inbound -> Maybe WebAuthFactory -> Maybe OAuth2Setup -> Maybe FileUploadFactory -> Maybe SecretStore -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe DispatcherConfig -> Maybe CorsFactory -> Maybe ApiInfoFactory -> Maybe HealthCheckFactory -> Maybe DispatcherConfigFactory -> Maybe SecretStoreFactory -> Array DeferredOutboundLifecycleReg -> Array DeferredInboundReg -> Array IntegrationRegistrationEntry -> Maybe ReadinessConfig -> Maybe Text -> Maybe Int -> Application ++ Service.Application: [bindHost] :: Application -> Maybe Text ++ Service.Application: [bindPort] :: Application -> Maybe Int ++ Service.Application: withHost :: Text -> Application -> Application ++ Service.Application: withPort :: Int -> Application -> Application +- Service.Application.Transports: runTransports :: Map Text TransportValue -> Map Text (Map Text EndpointHandler) -> Map Text (Map Text EndpointSchema) -> Map Text QueryEndpointHandler -> Map Text EndpointSchema -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> QuerySubscriber -> Task Text Unit ++ Service.Application.Transports: runTransports :: Map Text TransportValue -> Map Text (Map Text EndpointHandler) -> Map Text (Map Text EndpointSchema) -> Map Text QueryEndpointHandler -> Map Text EndpointSchema -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe Text -> Maybe Int -> QuerySubscriber -> Task Text Unit +- Service.Transport.Web: WebTransport :: Int -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe (Task Text Readiness) -> WebTransport ++ Service.Transport.Web: WebTransport :: Int -> Text -> Int -> Maybe AuthEnabled -> Maybe OAuth2Config -> Maybe FileUploadEnabled -> Maybe ApiInfo -> Maybe CorsConfig -> Maybe HealthCheckConfig -> Maybe IntegrationStatus -> Maybe ReadinessConfig -> Maybe (Task Text Readiness) -> WebTransport ++ Service.Transport.Web: [host] :: WebTransport -> Text ++ Service.Transport.Web: hostPreference :: Text -> HostPreference ++ Service.Transport.Web: warpSettings :: WebTransport -> Settings ++ Service.Transport.Web: applyBindOverrides :: Maybe Text -> Maybe Int -> WebTransport -> WebTransport ++ Service.Transport.Web: validateBindHost :: Text -> Maybe Text ++ Service.Transport.Web: validateBindPort :: Int -> Maybe Text +``` + +## Criteria + +| ID | Behavior | Proving test | Level | Boundary | +|----|----------|--------------|-------|----------| +| C1 | `WebTransport` binds all IPv4 interfaces on port 8080 by default, exactly as before (`Warp.run`) | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#server binds all IPv4 interfaces by default (unchanged from Warp.run)`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#server listens on port 8080 by default` | unit | none | +| C2 | `Application.withHost` / `Application.withPort` record the bind host and port, and a new `Application` leaves them unset | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#withHost records the bind host`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#withPort records the bind port`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#bind host and port are unset on a new Application` | unit | none | +| C3 | The host text maps to the right Warp `HostPreference` (`127.0.0.1`, `*`, `*4`, `*6`, `::1`) | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#maps a literal IPv4 address to that host`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#maps * to all interfaces`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#maps *4 to all IPv4 interfaces`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#maps *6 to all IPv6 interfaces`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#maps a literal IPv6 address to that host` | unit | none | +| C4 | The Warp settings the transport runs with carry the configured host and port | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#carries the configured host and port into Warp` | unit | none | +| C5 | An application started with `withHost "127.0.0.1"` and `withPort ` answers `GET /` on loopback (instance identity) and leaves the port free on a non-loopback address (loopback exclusion); the same probe finds the port taken when the default wildcard bind is used (negative control) | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#serves /health on loopback when bound to 127.0.0.1`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#a wildcard bind occupies the port on every address (negative control for the loopback probe)` | integration | http:real | +| C6 | Overrides apply whatever the order of `withTransport` and the builders; an absent override preserves the transport's own host/port; a host-only override keeps a custom port and a port-only override keeps a custom host | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#withHost and withPort apply whether they come before or after withTransport`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#absent overrides preserve the transport's custom host and port`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#a host-only override keeps the transport's custom port`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#a port-only override keeps the transport's custom host` | unit | none | +| C7 | `validateBindHost` accepts the Warp wildcards and bare literal addresses or hostnames, and rejects an empty host, a URL, a `host:port` pair and whitespace anywhere, including surrounding spaces, tabs and newlines; `validateBindPort` accepts `1..65535` and rejects `0` and out-of-range ports | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#accepts the Warp wildcards and bare literal addresses or hostnames`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects an empty or blank host`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects a URL pasted into the host field`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects a host that carries a port`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects a host with whitespace inside`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects a host with leading or trailing spaces`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects a host surrounded by tabs or newlines`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#accepts the full 1..65535 range`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects port 0 and ports outside the range` | unit | none | +| C8 | An invalid host or port makes `Application.runWith` fail with an `Application.withHost:` / `Application.withPort:` error before any socket is opened | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#an invalid host fails before any socket is opened`
`hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#an invalid port fails before any socket is opened` | unit | none | +| C9 | A port already in use fails with `could not bind :` | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#a port already in use fails with an error naming the host and port` | integration | http:real | + +C8 uses an in-memory application and rejects the setting before Warp starts, +so it has no real HTTP boundary. C5 exercises real HTTP listeners; C9 exercises +Warp's socket-bind failure against an occupied port. Their exact selectors +are attested with the `WebTransport bind host and port` fixture group printed +by BindSpec. + +## User impact + +Breaking only for code that builds the records positionally or with every field +named; nothing else changes. Apps that use `WebTransport.server` and apps built with `Application.new` +and the `with*` builders are unaffected and keep binding all IPv4 interfaces +on port 8080 unless they opt in; an app that already sets `server { port = ... }` +keeps that port, because an absent `withPort` preserves the transport's own +setting. Migration: a program that writes `WebTransport { ... }` with all fields +must add `host = "*4"` (the previous behaviour) or `host = "127.0.0.1"` for +loopback only; a program that writes `Application { ... }` with all fields must +add `bindHost = Nothing` and `bindPort = Nothing`. The testbed uses +`WebTransport.server` with no overrides, so its behaviour is unchanged. +New ways to use it: `Application.withHost "127.0.0.1"` and +`Application.withPort 9090`; `host` also accepts `"*"`, `"*4"`, `"*6"` or a +literal address. Loopback-only is the right choice when the reverse proxy runs +in the same network namespace as the app (same host or container, or a shared +pod network); a proxy in a separate namespace cannot reach the listener through +its own loopback and needs a non-loopback bind. A mistyped host or port now fails +at startup with a message naming the builder, instead of binding something +unintended or dying with a raw `IOException`. + +## ADR + +[ADR-0079](../decisions/0079-configurable-web-bind-host-and-port.md): why the +default stays `"*4"` (no new IPv6 surface) and why the overrides live on `Application`. diff --git a/docs/changes/027-bind-validation-runtime-proof.md b/docs/changes/027-bind-validation-runtime-proof.md new file mode 100644 index 000000000..39f5daa82 --- /dev/null +++ b/docs/changes/027-bind-validation-runtime-proof.md @@ -0,0 +1,58 @@ +# Change 027: Enforce the existing bind validation and runtime proof contract + +Continuation of change019 and [NickSeagull’s maintainer-reviewed authorized follow-up](https://github.com/neohaskell/NeoHaskell/pull/909#issuecomment-6040979623), source identity `NickSeagull`, comment `6040979623`. It requests earliest-practical checks, owned cleanup, instance identity/isolation and single-setting preservation; it does not approve a new config API or a new machine receipt. Keep the existing static builders, `*4` default, custom transport settings and port range1..65535. Fix early validation and representative bracket misuse; prove owned-instance identity and real assembly behavior without a configuration API redesign. Preliminary regression draft, not final approval/readiness. + +```yaml spec +issue: adhoc:bind-validation-runtime-proof +kind: bug +touches: [http-transport, service-wiring] +breaking: false +new-dependency: false +new-capability: false +new-extension-point: false +``` + +## Contract delta + +No public signatures or new production constants. Present static overrides for a registered WebTransport are checked in run/runWith before avoidable owned startup effects. Effective transport settings remain validated before listener startup. Existing no-WebTransport behavior is not expanded in this slice. Bare IPv6 remains supported; bracketed host:port and malformed bracket input produce actionable diagnostics. Port0 rejection remains, with truthful existing-breaking disclosure in change019 rather than new ephemeral-port behavior. + +```diff signatures +``` + +## Criteria + +| ID | Behavior | Proving test | Level | Boundary | +|----|----------|--------------|-------|----------| +| C1 | Bracketed host:port is rejected by the existing validator, with withPort guidance; bare IPv6 still accepted | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects bracketed IPv6 host-port before startup` | unit | none | +| C2 | Malformed bracketed IPv6 is rejected, bare IPv6 retained | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects malformed brackets and preserves bare IPv6` | unit | none | +| C3 | Invalid present static bind override with a registered WebTransport fails before auth discovery; a positive control proves the owned auth HTTP fixture is reachable | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects invalid static bind before owned auth discovery` | integration | http:real | +| C4 | run rejects an invalid known static override before attempting event-store setup | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects invalid static bind before run acquires an event store` | unit | none | +| C5 | applies host and port set before withTransport at runtime | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#applies host and port set before withTransport at runtime` | integration | http:real | +| C6 | applies host and port set after withTransport at runtime | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#applies host and port set after withTransport at runtime` | integration | http:real | +| C7 | preserves a custom registered host and port with absent overrides at runtime | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#preserves a custom registered host and port with absent overrides at runtime` | integration | http:real | +| C8 | preserves a custom registered port with a host-only override at runtime | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#preserves a custom registered port with a host-only override at runtime` | integration | http:real | +| C9 | preserves a custom registered host with a port-only override at runtime | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#preserves a custom registered host with a port-only override at runtime` | integration | http:real | +| C10 | accepts the intended Application and excludes another owned interface | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#accepts the intended Application and excludes another owned interface` | integration | http:real | +| C11 | a wildcard listener defeats the owned-interface bind probe | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#a wildcard listener defeats the owned-interface bind probe` | integration | http:real | +| C12 | rejects an unrelated catch-all 200 after the intended Application bind fails | `hspec:nhcore-test-service:core/test/Service/Transport/Web/BindSpec.hs#rejects an unrelated catch-all 200 after the intended Application bind fails` | integration | http:real | + +### Remaining executable criteria before implementation + +- Invalid present override with a real registered WebTransport and owned local auth fixture yields the intended validation error and zero discovery requests; fixture positive control proves it is listening. Cover run/runWith at their real effect boundary. +- Both builder orders, absent overrides, host-only/custom-port and port-only/custom-host consume the registered transport via real Application.runWith. Reset-to-default call-site mutant fails; original implementation currently preserves these settings. +- Intended application lifecycle is tied to readiness. A competing catch-all200 with failed intended bind cannot satisfy the success oracle. Preserve loopback exclusion and wildcard negative control. +- A bind-failure fixture with an observable owned worker proves its shutdown, not just the returned error. Wider inherited lifecycle defects require separate exact scope if discovered. + +These are mandatory unfinished tests, not passing locators. Native committed-red C1 and current verified receipt precede new product edits; final exact criteria and authentic continuation approval/review records remain required. Existing explicit maintainer requests are scoped authority, not fabricated receipt or final Gate2. + +## User impact + +Existing static builder signatures and custom transport settings are preserved. Invalid bracket input fails earlier and clearly. Invalid known bind settings no longer lose their intended error behind avoidable startup work. `*4`/`*6` are family preferences with platform-specific fallback; this change does not promise strict family isolation. Document existing port0 rejection accurately. No new config-factory API, no expanded transportless validation, no broad lifecycle rewrite or Local/FileUpload changes. + +## ADR + +Existing ADR0079 owns bind choices. ADR0035 config-factory parity/explicit deferral remains a separate unresolved decision; this repair does not claim to settle it or infer approval. No new mechanical ADR trigger for fulfilling the existing validation contract. + +## Localized scope and verification + +Files: Service/Application.hs entry run/runWith, Service/Application/Transports.hs effective validation, Service/Transport/Web.hs validateBindHost, core/test/Service/Transport/Web/BindSpec.hs and test-surfaces, change019/ADR0079/fragment wording, generated codemap. Tests copy-adapt current BindSpec and its held-loopback/socket fixture. Preserve all existing expectations; add tests first. Security design review is local-only after authentic Gate1 continuation and before product edits. Runtime tests use owned loopback listeners/synthetic payloads only. Full required suites/testbed and exact-head CI remain separate gates; no unrelated PostgreSQL access. diff --git a/docs/changes/test-surfaces.json b/docs/changes/test-surfaces.json index 08eb0ae1f..4efb1c4f9 100644 --- a/docs/changes/test-surfaces.json +++ b/docs/changes/test-surfaces.json @@ -38,6 +38,87 @@ } }, "boundaries": [ + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "rejects an unrelated catch-all 200 after the intended Application bind fails", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "a wildcard listener defeats the owned-interface bind probe", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "accepts the intended Application and excludes another owned interface", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "preserves a custom registered host with a port-only override at runtime", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "preserves a custom registered port with a host-only override at runtime", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "preserves a custom registered host and port with absent overrides at runtime", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "applies host and port set after withTransport at runtime", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "applies host and port set before withTransport at runtime", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Actual Application.runWith WebTransport, per-instance query-handler acknowledgment and nonce, owned local sockets and explicit interface preflight" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "rejects invalid static bind before owned auth discovery", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "Owned Warp loopback discovery server with request counter, positive HTTP200 control before reset; Application.runWith actual WebTransport and invalid static host" + }, { "kind": "script", "path": "testbed/scripts/cold-start-readiness.sh", @@ -213,6 +294,33 @@ "boundary": "postgres:real", "expected_examples": 1, "fixture": "Service.QueryObjectStore.Postgres" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "serves /health on loopback when bound to 127.0.0.1", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "WebTransport bind host and port" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "a wildcard bind occupies the port on every address (negative control for the loopback probe)", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "WebTransport bind host and port" + }, + { + "kind": "hspec", + "suite": "nhcore-test-service", + "path": "core/test/Service/Transport/Web/BindSpec.hs", + "match": "a port already in use fails with an error naming the host and port", + "boundary": "http:real", + "expected_examples": 1, + "fixture": "WebTransport bind host and port" } ] } diff --git a/docs/decisions/0079-configurable-web-bind-host-and-port.md b/docs/decisions/0079-configurable-web-bind-host-and-port.md new file mode 100644 index 000000000..02a55962b --- /dev/null +++ b/docs/decisions/0079-configurable-web-bind-host-and-port.md @@ -0,0 +1,64 @@ +# ADR-0079: Configurable web bind host and port + +## Status + +Accepted + +## Context + +`WebTransport` always bound Warp's default host and a port fixed in `server`. +Apps behind a reverse proxy want loopback-only binding, and the port could only +be changed by editing the `WebTransport` record, which `Application` hides +inside an existing transport value. The maintainer accepted a loopback-bind fix +and asked for the port to be configurable too. + +## Decision + +Add `host :: Text` to `WebTransport` and start Warp with `runSettings`, using +`setPort` and `setHost`. The text maps to Warp's `HostPreference`: `"*"` all +interfaces, `"*4"`, `"*6"`, or a literal address such as `"127.0.0.1"`. + +The default is `"*4"`: exactly what the previous `Warp.run` bound (all IPv4 +interfaces). A loopback default would silently break containers and any app +that is reached from another machine; a `"*"` default would silently start +listening on IPv6 too, a new reachable surface on dual-stack hosts whose +firewall rules only cover IPv4. Neither change belongs in a "make it +configurable" PR, so both loopback-only and IPv6 are opt-in through `withHost`. + +Add `Application.withHost` and `Application.withPort`, stored as `bindHost` and +`bindPort` and applied when the web transport starts. They are on `Application`, +like `withCors` and `withHealthCheck`, because `withTransport` stores the +transport as an opaque value, so a builder cannot edit it. The override applies +whatever the order of `withTransport` and the builder. + +The host and port stay plain `Text` and `Int` (no wrapper types), but the +contract is checked before Warp starts: `validateBindHost` accepts the Warp +wildcards and a bare literal address or hostname and rejects an empty host, a +URL or path, a `host:port` pair and whitespace; `validateBindPort` accepts +`1..65535` and rejects `0` (the OS would pick a port nothing reports back). +The error names the builder (`Application.withHost: …`). A bind the OS refuses +is caught as an `IOException` and re-thrown as +`WebTransport could not bind :: …`, so it travels the same +`Task.finally` cleanup path as every other startup failure. + +## Consequences + +- Constructing `WebTransport` or `Application` with every field named must add + the new fields. This is the one breaking effect; `WebTransport.server` users + are unaffected. +- Apps can bind loopback only, or choose the port, in one line. +- The start-up log now shows `:`. +- The default is unchanged: all IPv4 interfaces (`"*4"`), exactly what + `Warp.run` bound before. IPv6 (`"*"` or `"*6"`) and loopback-only are opt-in + through `withHost`. +- Loopback-only is advised only when the reverse proxy shares the app's + network namespace (same host or container, shared pod network). A proxy in + a separate namespace cannot reach a loopback listener; it needs a + non-loopback bind plus firewalling. +- A mistyped host or port fails at startup with a message naming the builder; + a port in use or an address this machine does not own fails with + `could not bind :` instead of an uncaught `IOException`. +- The loopback test proves exclusion, not only reachability: it serves a + per-test unique health path (instance identity) and checks that the port is + still bindable on a non-loopback address, with a wildcard-bind negative + control that shows the probe fails when the listener is not loopback-only. diff --git a/docs/decisions/README.md b/docs/decisions/README.md index ef1a0d635..1a6307565 100644 --- a/docs/decisions/README.md +++ b/docs/decisions/README.md @@ -92,6 +92,7 @@ ADRs document significant architectural decisions made during the development of | [0076](0076-restore-resumable-change-pipeline.md) | Restore the resumable contract-delta change pipeline | Implemented | | [0077](0077-local-release-notes-and-main-publication.md) | Local release notes and coordinated publication from main | Implemented | | [0078](0078-documentation-image-zoom.md) | Documentation Image Zoom | Accepted | +| [0079](0079-configurable-web-bind-host-and-port.md) | Configurable web bind host and port | Accepted |