diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,126 @@ +## Unreleased + +## 0.7.0 + +### Added +- Added an Hspec-based `hprox-test` suite with characterization coverage for CLI/default parsing, pure helpers, auth-file loading and rewriting, middleware endpoints, reverse-proxy routing and rewrites, HTTP/CONNECT proxy decisions, TLS/SNI selection, Warp/runtime exception handling, runner selection, DoH behavior, and naiveproxy padding. +- Added internal domain/runtime seams for `Config`, auth loading, reverse routes, proxy runtime construction, TLS/SNI setup, Warp settings, runner selection, platform-specific Unix/QUIC startup, log output parsing, header policy, DoH requests, and runtime configuration. +- Added runtime-spec coverage for safer QUIC defaults, including 0-RTT disablement, dual-stack wildcard binds, and Alt-Svc rendering assertions +- Added pure `planPrivilegeDrop` coverage for Unix privilege-drop plans in `RuntimeSpec` + +### Changed +- Refactored `Network.HProx.run` into focused internal modules while preserving the public `Network.HProx` API and existing runtime behavior. +- Replaced tuple-heavy reverse-proxy internals with typed `ReverseRoute` and request rewrite helpers. +- Made proxy logging effects explicit by removing the hidden `unsafePerformIO` logging path. +- Centralized current header constants and strip/lookup policy, then made protocol header value comparisons case-insensitive for `X-Forwarded-Proto` and `X-Scheme`. +- Refactored DoH handling into explicit parse/resolve/respond helpers and made POST body reading support split request chunks within the existing 4096-byte limit. +- Named naiveproxy padding protocol constants and added deterministic parser/round-trip coverage. +- Updated copyright notices to 2026 in LICENSE, package metadata, and all touched source/test headers +- Hardened auth-file handling by stripping one trailing carriage return from each entry before parsing, hashing, and rewrite decisions +- Normalized reverse route host/path matching behavior is now stricter and more tolerant of case in host names +- Disabled QUIC 0-RTT startup by default and exposed configurable QUIC helper seams for safer runtime behavior tests +- Changed default QUIC bind behavior to listen on both 0.0.0.0 and :: when no explicit bind is provided, while singleton binds remain single-address +- Updated QUIC bind logging to report all interfaces when the bind address is not configured explicitly + +### Fixed +- Removed avoidable partial functions in reverse-proxy host parsing and HTTP/WebSocket proxy target selection. +- Hardened malformed HTTP proxy target parsing to reject malformed explicit ports and HTTP/2 proxy requests without a Host header while preserving bracketed IPv6 authorities. +- Replaced the Argon2 password-hash `error` path with a typed `PasswordHashError` thrown at the IO boundary. +- Normalized HTTP proxy forwarding authority to render Host from the parsed URI and omit default `:80` +- Stripped inbound Host and proxy-boundary headers (including `Forwarded`) when forwarding proxied HTTP requests +- Enforced strict `Proxy-Authorization` parsing for HTTP proxy authentication: only `Basic` credentials with valid base64 decode are accepted now +- Ensured malformed auth-file warnings redact raw line contents and report line numbers with optional username context +- Added tests covering CRLF plaintext auth-file verification/rewrite and malformed-line log redaction +- Added bounded validation for `--port` and `--quic`, including `Config` runtime validation for direct values, and tightened `--rev` route parsing to reject empty upstream/domain components before startup +- Normalized reverse-route prefixes from config tuples to canonical leading-slash form without trailing slash +- Made reverse route prefix matching boundary-aware so /api matches /api/v1 but not /apiary or /apix +- Made reverse proxy path rewrites preserve unmatched paths and handle exact and nested matches consistently +- Compared reverse-route hostnames case-insensitively after stripping ports +- Preserved `forceSSL` HTTPS redirect targets for origin-form requests by keeping request path and query; for absolute-form proxy requests the redirect now uses the parsed target and omits default `:80`/`:443` ports while preserving non-default ports +- Updated CONNECT handling to establish upstream TCP before returning 200 OK and return 502 on connect failures for HTTP/1 and HTTP/2 +- Differentiated DNS resolver failures in DoH by returning HTTP 502 (Bad Gateway) with `dns resolver failure` instead of reusing the malformed-request 400 response +- Rejected chunked DoH POST bodies that exceed the 4096-byte limit with HTTP 400 malformed-request handling +- Preserved malformed client input handling on HTTP 400 while adding successful chunked POST parsing support within existing size bounds +- Preserved Alt-Svc advertisement formatting by centralizing it in a dedicated helper used by TLS setup +- Hardened Unix privilege dropping to resolve target user/group entries before changing IDs +- Hardened TLS credential loading by adding contextual IO failures for missing or unreadable cert/key paths + +### Security +- Redacted proxy credentials in TRACE logs as `username:` so passwords are never logged +- Prevented auth-file logging from leaking password-like fragments by replacing raw-line diagnostics with non-sensitive context +- Hardened SNI matching to use ASCII case-insensitive host checks and reject invalid wildcard matches +- Disabled QUIC 0-RTT by default to reduce replay and forward-secrecy risk when accepting early data +- Verified real/effective UID/GID and supplementary groups after privilege drop and enforced stricter safety checks for user/group transitions + +## 0.6.5 + +- bump stack dependencies +- build with GHC 9.10 +- remove DROP_ALL_CAPS_EXCEPT_BIND + +## 0.6.4 + +- bump stack dependencies +- build with GHC 9.8 + +## 0.6.3 + +- bump stack dependencies +- fix Content-Length header for encoded HTTP responses in reverse proxy mode + +## 0.6.2 + +- fixes to improve ssltest result +- unix: support setuid after binding port +- remove graceful close + +## 0.6.1 + +- multiple certificates and SNI support for HTTP/3 +- install signal handler with graceful shutdown on Linux and macOS +- support ACME `http-01` challenge (RFC8555) + +## 0.6.0 + +- `--rev` now supports domain matching +- fix `Content-Length` header in HTTP/2 responses +- passwords are now Argon2 salt-hashed + +## 0.5.4 + +- routable `--rev` reverse proxy support +- fix `Keep-Alive` header in reverse HTTP/2 proxy +- add nix based build mode +- naiveproxy padding: add protocol negotiation and packet fragmentation + +## 0.5.3 + +- add macos-aarch64 build +- add `--hide` option for probe resistance +- gracefully close stream for HTTP CONNECT +- `gzip` encoding middleware removed + +## 0.5.2 + +- add Windows build +- remove `--user` option + +## 0.5.1 + +- export `LogLevel` type to make `Config` actually customizable +- add `--log` option to specify logging type + +## 0.5.0 + +- initial HTTP/3 (QUIC) support +- add logging based on fast-logger +- some minor tweaks + +## 0.4.0 + +- naiveproxy compatible [padding](https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification) support (`--naive`) +- strong TLS settings as advised by [SSL Labs ssltest](https://www.ssllabs.com/ssltest) + +## 0.3.0 + +- initial version with exposed library interface diff --git a/Changelog.md b/Changelog.md deleted file mode 100644 --- a/Changelog.md +++ /dev/null @@ -1,66 +0,0 @@ -## 0.6.4 - -- bump bump stack dependencies -- build with GHC 9.8 - -## 0.6.3 - -- bump stack dependencies -- fix Content-Length header for encoded HTTP responses in reverse proxy mode - -## 0.6.2 - -- fixes to improve ssltest result -- unix: support setuid after binding port -- remove graceful close - -## 0.6.1 - -- multiple certificates and SNI support for HTTP/3 -- install signal handler with graceful shutdown on Linux and macOS -- support ACME `http-01` challenge (RFC8555) - -## 0.6.0 - -- `--rev` now supports domain matching -- fix `Content-Length` header in HTTP/2 responses -- passwords are now Argon2 salt-hashed - -## 0.5.4 - -- routable `--rev` reverse proxy support -- fix `Keep-Alive` header in reverse HTTP/2 proxy -- add nix based build mode -- naiveproxy padding: add protocol negotiation and packet fragmentation - -## 0.5.3 - -- add macos-aarch64 build -- add `--hide` option for probe resistance -- gracefully close stream for HTTP CONNECT -- `gzip` encoding middleware removed - -## 0.5.2 - -- add Windows build -- remove `--user` option - -## 0.5.1 - -- export `LogLevel` type to make `Config` actually customizable -- add `--log` option to specify logging type - -## 0.5.0 - -- initial HTTP/3 (QUIC) support -- add logging based on fast-logger -- some minor tweaks - -## 0.4.0 - -- naiveproxy compatible [padding](https://github.com/klzgrad/naiveproxy/#padding-protocol-an-informal-specification) support (`--naive`) -- strong TLS settings as advised by [SSL Labs ssltest](https://www.ssllabs.com/ssltest) - -## 0.3.0 - -- initial version with exposed library interface diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright 2023 Bin Jin + Copyright 2026 Bin Jin Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,6 @@ [![CircleCI](https://circleci.com/gh/bjin/hprox.svg?style=shield)](https://circleci.com/gh/bjin/hprox) [![CirrusCI](https://api.cirrus-ci.com/github/bjin/hprox.svg)](https://cirrus-ci.com/github/bjin/hprox) -[![Depends](https://img.shields.io/hackage-deps/v/hprox.svg)](https://packdeps.haskellers.com/feed?needle=hprox) [![Release](https://img.shields.io/github/release/bjin/hprox.svg)](https://github.com/bjin/hprox/releases) [![Hackage](https://img.shields.io/hackage/v/hprox.svg)](https://hackage.haskell.org/package/hprox) [![License](https://img.shields.io/github/license/bjin/hprox.svg)](https://github.com/bjin/hprox/blob/master/LICENSE) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. module Main ( main diff --git a/cbits/setcap.c b/cbits/setcap.c deleted file mode 100644 --- a/cbits/setcap.c +++ /dev/null @@ -1,60 +0,0 @@ -// SPDX-License-Identifier: BSD3 -// -// Copyright (C) 2020 Kazu Yamamoto. All Rights Reserved. -// -// File taken from https://github.com/kazu-yamamoto/mighttpd2 -// See https://kazu-yamamoto.hatenablog.jp/entry/2020/12/10/150731 for details -// -#if defined(__linux__) -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "Rts.h" - -void set_capabilities (uint32_t cap) { - cap_user_header_t header = malloc(sizeof(*header)); - header->version = _LINUX_CAPABILITY_VERSION_3; - header->pid = 0; - - cap_user_data_t data = malloc(sizeof(*data)); - data->effective = cap; - data->permitted = cap; - data->inheritable = 0; - - capset(header,data); - - free(header); - free(data); -} - -void handler(int signum) { - uint32_t cap = 1 << CAP_NET_BIND_SERVICE; - set_capabilities (cap); -} - -void FlagDefaultsHook () { - if (geteuid() == 0) { - prctl(PR_SET_SECUREBITS, SECBIT_KEEP_CAPS, 0L, 0L, 0L); - - struct sigaction sa; - memset(&sa, 0, sizeof(sa)); - sa.sa_handler = handler; - sa.sa_flags = SA_RESTART; - sigaction(SIGUSR1, &sa, NULL); - } -} - -void send_signal (int tid, int sig) { - int tgid = getpid(); - syscall(SYS_tgkill, tgid, tid, sig); -} -#else -void send_signal (int tid, int sig) {} -#endif diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: hprox -version: 0.6.4 +version: 0.7.0 synopsis: a lightweight HTTP proxy server, and more description: Please see the README on GitHub at category: Web @@ -13,13 +13,13 @@ bug-reports: https://github.com/bjin/hprox/issues author: Bin Jin maintainer: bjin@ctrl-d.org -copyright: 2023 Bin Jin +copyright: 2026 Bin Jin license: Apache-2.0 license-file: LICENSE build-type: Simple extra-source-files: README.md - Changelog.md + CHANGELOG.md source-repository head type: git @@ -39,10 +39,17 @@ exposed-modules: Network.HProx other-modules: + Network.HProx.Auth + Network.HProx.Config Network.HProx.DoH + Network.HProx.Headers Network.HProx.Impl Network.HProx.Log Network.HProx.Naive + Network.HProx.Route + Network.HProx.Runtime + Network.HProx.Platform.Quic + Network.HProx.Platform.Unix Network.HProx.Util Paths_hprox hs-source-dirs: @@ -87,12 +94,6 @@ http3 >=0.0.3 , quic >=0.1.15 , warp-quic - if os(linux) - cpp-options: -DDROP_ALL_CAPS_EXCEPT_BIND - c-sources: - cbits/setcap.c - build-depends: - directory >=1.2.5.0 if !os(windows) cpp-options: -DOS_UNIX build-depends: @@ -110,7 +111,7 @@ RecordWildCards ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base + base >=4.12 && <5 , bytestring , hprox , http-types @@ -118,3 +119,83 @@ default-language: Haskell2010 if flag(static) ghc-options: -optl-static + +test-suite hprox-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Network.HProx.AuthSpec + Network.HProx.ConfigSpec + Network.HProx.DoHSpec + Network.HProx.HeadersSpec + Network.HProx.MiddlewareSpec + Network.HProx.NaiveSpec + Network.HProx.ProxySpec + Network.HProx.PureSpec + Network.HProx.RouteSpec + Network.HProx.RuntimeSpec + Network.HProx.TLSSpec + Network.HProx + Network.HProx.Auth + Network.HProx.Config + Network.HProx.DoH + Network.HProx.Headers + Network.HProx.Impl + Network.HProx.Log + Network.HProx.Naive + Network.HProx.Platform.Quic + Network.HProx.Platform.Unix + Network.HProx.Route + Network.HProx.Runtime + Network.HProx.Util + Paths_hprox + hs-source-dirs: + test + src + default-extensions: + ImportQualifiedPost + OverloadedStrings + RecordWildCards + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + async + , base >=4.12 && <5 + , base64-bytestring + , binary + , bytestring + , case-insensitive + , conduit + , conduit-extra + , crypton + , data-default-class + , directory + , dns + , fast-logger + , hspec + , http-client + , http-client-tls + , http-reverse-proxy + , http-types + , http2 + , network + , optparse-applicative + , random + , text + , tls + , tls-session-manager + , unordered-containers + , wai + , wai-extra + , warp + , warp-tls + default-language: Haskell2010 + if flag(quic) + cpp-options: -DQUIC_ENABLED + build-depends: + http3 + , quic + , warp-quic + if !os(windows) + cpp-options: -DOS_UNIX + build-depends: + unix diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs --- a/src/Network/HProx.hs +++ b/src/Network/HProx.hs @@ -1,9 +1,8 @@ -- SPDX-License-Identifier: Apache-2.0 - --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} {-| Instead of running @hprox@ binary directly, you can use this library to run HProx in front of arbitrary WAI 'Application'. @@ -18,457 +17,73 @@ , run ) where -import Data.ByteString.Char8 qualified as BS8 -import Data.Default.Class (def) -import Data.HashMap.Strict qualified as HM -import Data.List (elemIndex, elemIndices, isSuffixOf, sortOn) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Ord (Down(..)) -import Data.String (fromString) -import Data.Version (showVersion) -import Network.HTTP.Client.TLS (newTlsManager) -import Network.HTTP.Types qualified as HT -import Network.TLS qualified as TLS -import Network.TLS.SessionManager qualified as SM -import Network.Wai (Application, rawPathInfo) -import Network.Wai.Handler.Warp - (InvalidRequest(..), defaultSettings, defaultShouldDisplayException, runSettings, setHost, - setLogger, setNoParsePath, setOnException, setPort, setServerName) -import Network.Wai.Handler.WarpTLS - (OnInsecure(..), WarpTLSException, defaultTlsSettings, onInsecure, runTLS, tlsAllowedVersions, - tlsCredentials, tlsServerHooks, tlsSessionManager) - -import Control.Exception (Exception(..)) -import GHC.IO.Exception (IOErrorType(..)) -import Network.HTTP2.Client qualified as H2 -import System.IO.Error (ioeGetErrorType) - -#ifdef QUIC_ENABLED -import Control.Concurrent.Async (mapConcurrently_) -import Data.List (find) -import Network.QUIC qualified as Q -import Network.QUIC.Internal qualified as Q -import Network.Wai.Handler.Warp (setAltSvc) -import Network.Wai.Handler.WarpQUIC (runQUIC) -#endif - -#ifdef OS_UNIX -import Control.Exception (SomeException, catch) -import Network.Wai.Handler.Warp (setBeforeMainLoop) -import System.Exit -import System.Posix.Process (exitImmediately) -import System.Posix.User - -#ifdef DROP_ALL_CAPS_EXCEPT_BIND -import Foreign.C.Types (CInt(..)) -import System.Directory (listDirectory) -import System.Posix.Signals (sigUSR1) -import Text.Read (readMaybe) -#endif -#endif - -import Control.Monad -import Data.Maybe -import Options.Applicative +import Control.Monad (forM_, unless, when) +import Data.Version (showVersion) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.TLS.SessionManager qualified as SM +import Network.Wai (Application) -import Network.HProx.DoH -import Network.HProx.Impl +import Network.HProx.Auth +import Network.HProx.Config import Network.HProx.Log -import Network.HProx.Util +import Network.HProx.Platform.Unix +import Network.HProx.Runtime import Paths_hprox --- | Configuration of HProx, see @hprox --help@ for details -data Config = Config - { _bind :: !(Maybe String) - , _port :: !Int - , _ssl :: ![(String, CertFile)] - , _auth :: !(Maybe FilePath) - , _ws :: !(Maybe BS8.ByteString) - , _rev :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)] - , _doh :: !(Maybe String) - , _hide :: !Bool - , _naive :: !Bool - , _name :: !BS8.ByteString - , _acme :: !(Maybe BS8.ByteString) - , _log :: !String - , _loglevel :: !LogLevel -#ifdef OS_UNIX - , _user :: !(Maybe String) - , _group :: !(Maybe String) -#endif -#ifdef QUIC_ENABLED - , _quic :: !(Maybe Int) -#endif - } - --- | Default value of 'Config', same as running @hprox@ without arguments -defaultConfig :: Config -defaultConfig = Config Nothing 3000 [] Nothing Nothing [] Nothing False False "hprox" Nothing "stdout" INFO -#ifdef OS_UNIX - Nothing - Nothing -#endif -#ifdef QUIC_ENABLED - Nothing -#endif - --- | Certificate file pairs -data CertFile = CertFile - { certfile :: !FilePath - , keyfile :: !FilePath - } - -readCert :: CertFile -> IO TLS.Credential -readCert (CertFile c k) = either error id <$> TLS.credentialLoadX509 c k - -parser :: ParserInfo Config -parser = info (helper <*> ver <*> config) (fullDesc <> progDesc desc) - where - parseSSL s = case splitBy ':' s of - host :| [cert, key] -> Right (host, CertFile cert key) - _otherwise -> Left "invalid format for ssl certificates" - - parseRev0 s@('/':_) = case elemIndices '/' s of - [] -> Nothing - indices -> let (prefix, remote) = splitAt (last indices + 1) s - in Just (Nothing, BS8.pack prefix, BS8.pack remote) - parseRev0 remote = Just (Nothing, "/", BS8.pack remote) - - parseRev ('/':'/':s) = case elemIndex '/' s of - Nothing -> Nothing - Just ind -> let (domain, other) = splitAt ind s - in do (_, prefix, remote) <- parseRev0 other - return (Just (BS8.pack domain), prefix, remote) - - parseRev s = parseRev0 s - - desc = "a lightweight HTTP proxy server, and more" - ver = infoOption (showVersion version) (long "version" <> help "Display the version information") - - config = Config <$> bind - <*> port - <*> ssl - <*> auth - <*> ws - <*> rev - <*> doh - <*> hide - <*> naive - <*> name - <*> acme - <*> logging - <*> loglevel -#ifdef OS_UNIX - <*> user - <*> group -#endif -#ifdef QUIC_ENABLED - <*> quic -#endif - - bind = optional $ strOption - ( long "bind" - <> short 'b' - <> metavar "bind_ip" - <> help "Specify the IP address to bind to (default: all interfaces)") - - port = option auto - ( long "port" - <> short 'p' - <> metavar "port" - <> value 3000 - <> showDefault - <> help "Specify the port number") - - ssl = many $ option (eitherReader parseSSL) - ( long "tls" - <> short 's' - <> metavar "hostname:cerfile:keyfile" - <> help "Enable TLS and specify a domain with its associated TLS certificate (can be specified multiple times for multiple domains)") - - auth = optional $ strOption - ( long "auth" - <> short 'a' - <> metavar "userpass.txt" - <> help "Specify the password file for proxy authentication. Plaintext passwords should be in the format 'user:pass' and will be automatically Argon2-hashed by hprox. Ensure that the password file with plaintext password is writable") - - ws = optional $ strOption - ( long "ws" - <> metavar "remote-host:port" - <> help "Specify the remote host to handle WebSocket requests (port 443 indicates an HTTPS remote server)") - - rev = many $ option (maybeReader parseRev) - ( long "rev" - <> metavar "[//domain/][/prefix/]remote-host:port" - <> help "Specify the remote host for reverse proxy (port 443 indicates an HTTPS remote server). An optional '//domain/' will only process requests with the 'Host: domain' header, and an optional '/prefix/' can be specified as a prefix to be matched (and stripped in proxied request)") - - doh = optional $ strOption - ( long "doh" - <> metavar "dns-server:port" - <> help "Enable DNS-over-HTTPS (DoH) support (port 53 will be used if not specified)") - - hide = switch - ( long "hide" - <> help "Never send 'Proxy Authentication Required' response. Note that this might break the use of HTTPS proxy in browsers") - - naive = switch - ( long "naive" - <> help "Add naiveproxy-compatible padding (requires TLS)") - - name = strOption - ( long "name" - <> metavar "server-name" - <> value "hprox" - <> showDefault - <> help "Specify the server name for the 'Server' header") - - acme = optional $ strOption - ( long "acme" - <> metavar "ACCOUNT_THUMBPRINT" - <> help "Set the thumbprint for stateless http-01 ACME challenge as specified by RFC8555") - - logging = strOption - ( long "log" - <> metavar "" - <> value "stdout" - <> showDefault - <> help "Specify the logging type") - - loglevel = option (maybeReader logLevelReader) - ( long "loglevel" - <> metavar "" - <> value INFO - <> help "Specify the logging level (default: info)") - -#ifdef OS_UNIX - user = optional $ strOption - ( long "user" - <> short 'u' - <> metavar "nobody" - <> help "Drop root priviledge and setuid to the specified user (like nobody)") - - group = optional $ strOption - ( long "group" - <> short 'g' - <> metavar "nogroup" - <> help "Drop root priviledge and setgid to the specified group") -#endif - -#ifdef QUIC_ENABLED - quic = optional $ option auto - ( long "quic" - <> short 'q' - <> metavar "port" - <> help "Enable QUIC (HTTP/3) on UDP port") -#endif - -getLoggerType :: String -> LogType' LogStr -getLoggerType "none" = LogNone -getLoggerType "stdout" = LogStdout 4096 -getLoggerType "stderr" = LogStderr 4096 -getLoggerType file = LogFileNoRotate file 4096 - -#ifdef OS_UNIX -dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool -dropRootPriviledge _ Nothing Nothing = return False -dropRootPriviledge logger user group = do - currentUser <- getRealUserID - currentGroup <- getRealGroupID - if currentUser /= 0 || currentGroup /= 0 - then do - logger WARN $ "Unable to setuid/setgid without root priviledge" <> - ", userID=" <> toLogStr (show currentUser) <> - ", groupID=" <> toLogStr (show currentGroup) - return False - else do - let abort msg = logger ERROR msg >> exitImmediately (ExitFailure 1) - forM_ group $ \group' -> do - logger INFO $ "setgid to " <> toLogStr group' - getGroupEntryForName group' >>= setGroupID . groupID - changedGroup <- getRealGroupID - when (changedGroup == currentGroup) $ abort "failed to setgid, aborting" - forM_ user $ \user' -> do - logger INFO $ "setuid to " <> toLogStr user' - getUserEntryForName user' >>= setUserID . userID - changedUser <- getRealUserID - when (changedUser == currentUser) $ abort "failed to setuid, aborting" - logger DEBUG "testing setuid(0), verify that root priviledge can't be regranted" - catch (setUserID 0) $ \(_ :: SomeException) -> logger DEBUG "setuid(0) failed as expected" - changedUser <- getRealUserID - when (changedUser == 0) $ abort "unable to drop root priviledge, aborting" - return True - -#ifdef DROP_ALL_CAPS_EXCEPT_BIND -foreign import ccall unsafe "send_signal" - c_send_signal :: CInt -> CInt -> IO () - --- Taken from mighttpd2, see https://kazu-yamamoto.hatenablog.jp/entry/2020/12/10/150731 for details -dropAllCapsExceptBind :: IO () -dropAllCapsExceptBind = do - tids <- mapMaybe readMaybe <$> listDirectory "/proc/self/task" - forM_ tids $ \tid -> c_send_signal tid sigUSR1 -#endif -#endif - --- | Read 'Config' from command line arguments -getConfig :: IO Config -getConfig = execParser parser - -- | Run HProx in front of fallback 'Application', with specified 'Config' run :: Application -- ^ fallback application -> Config -- ^ configuration -> IO () -run fallback Config{..} = withLogger (getLoggerType _log) _loglevel $ \logger -> do - logger INFO $ "hprox " <> toLogStr (showVersion version) <> " started" - - let certfiles = _ssl - - certs <- mapM (readCert.snd) certfiles - smgr <- SM.newSessionManager SM.defaultConfig +run fallback conf@Config{..} = + either (ioError . userError) runValidated (validateRuntimeConfig conf) + where + runValidated () = + let runtimeConfig = buildRuntimeConfig conf + in withLogger (logOutputType (runtimeConfigLogOutput runtimeConfig)) _loglevel $ \logger -> do + logger INFO $ "hprox " <> toLogStr (showVersion version) <> " started" - let isSSL = not (null certfiles) - allCerts = zip (map fst certfiles) certs + allCerts <- loadTlsCredentials _ssl + smgr <- SM.newSessionManager SM.defaultConfig - when isSSL $ do - logger INFO $ "read " <> toLogStr (show $ length certs) <> " certificates" - logger INFO $ "domains: " <> toLogStr (unwords $ map fst allCerts) + let isSSL = not (null _ssl) - let settings = setHost (fromString (fromMaybe "*6" _bind)) $ - setPort _port $ - setLogger warpLogger $ - setOnException exceptionHandler $ -#ifdef OS_UNIX - setBeforeMainLoop doBeforeMainLoop $ -#endif - setNoParsePath True $ - setServerName _name defaultSettings + when isSSL $ do + logger INFO $ "read " <> toLogStr (show $ length allCerts) <> " certificates" + logger INFO $ "domains: " <> toLogStr (unwords $ map fst allCerts) + let beforeMainLoop = #ifdef OS_UNIX - doBeforeMainLoop = do - dropped <- dropRootPriviledge logger _user _group -#if defined(DROP_ALL_CAPS_EXCEPT_BIND) - when dropped $ do - logger INFO "drop all capabilities except CAP_NET_BIND_SERVICE" - dropAllCapsExceptBind -#elif defined(QUIC_ENABLED) - case (dropped, _quic) of - (True, Just qport) | qport < 1024 -> logger ERROR $ "dropping root priviledge will likely break QUIC connection over UDP port " <> toLogStr (show qport) - (True, _) -> logger INFO "root priviledge dropped" - _ -> return () + Just doBeforeMainLoop #else - when dropped $ logger INFO "root priviledge dropped" -#endif -#endif - - exceptionHandler req ex - | _loglevel > DEBUG = return () - | not (defaultShouldDisplayException ex) = return () - | Just (ioeGetErrorType -> EOF) <- fromException ex = return () - | Just (H2.BadThingHappen ex') <- fromException ex = exceptionHandler req ex' - | Just (_ :: H2.HTTP2Error) <- fromException ex = return () -#ifdef QUIC_ENABLED - | Just (Q.BadThingHappen ex') <- fromException ex = exceptionHandler req ex' - | Just (_ :: Q.QUICException) <- fromException ex = return () + Nothing #endif - | Just (_ :: WarpTLSException) <- fromException ex = return () - | Just ConnectionClosedByPeer <- fromException ex = return () - | otherwise = - logger DEBUG $ "exception: " <> toLogStr (displayException ex) <> - maybe "" (\req' -> " from: " <> logRequest req') req - - warpLogger req status _ - | rawPathInfo req == "/.hprox/health" = return () - | otherwise = - logger TRACE $ "(" <> toLogStr (HT.statusCode status) <> ") " <> logRequest req - - tlsset = defaultTlsSettings - { tlsServerHooks = def { TLS.onServerNameIndication = onSNI } - , tlsCredentials = Just (TLS.Credentials [head certs]) - , onInsecure = AllowInsecure - , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] - , tlsSessionManager = Just smgr - } - - onSNI Nothing = fail "SNI: unspecified" - onSNI (Just host) = lookupSNI host allCerts - - lookupSNI host [] = fail ("SNI: unknown hostname (" ++ show host ++ ")") - lookupSNI host ((p, cert) : cs) - | checkSNI host p = return (TLS.Credentials [cert]) - | otherwise = lookupSNI host cs - - checkSNI host pat = case pat of - '*' : '.' : p -> ('.' : p) `isSuffixOf` host - p -> host == p + settings = buildWarpSettings conf logger beforeMainLoop +#ifdef OS_UNIX + doBeforeMainLoop = do + dropped <- dropRootPriviledge logger _user _group #ifdef QUIC_ENABLED - alpn _ = return . fromMaybe "" . find (== "h3") - altsvc qport = BS8.concat ["h3=\":", BS8.pack $ show qport ,"\""] - - quicset qport = Q.defaultServerConfig - { Q.scAddresses = [(fromString (fromMaybe "0.0.0.0" _bind), fromIntegral qport)] - , Q.scVersions = [Q.Version1, Q.Version2] - , Q.scCredentials = TLS.Credentials [head certs] - , Q.scALPN = Just alpn - , Q.scTlsHooks = def { TLS.onServerNameIndication = onSNI } - , Q.scUse0RTT = True - , Q.scSessionManager = smgr - } - - runner | not isSSL = runSettings settings - | Just qport <- _quic = \app -> do - logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "0.0.0.0" _bind) <> ":" <> toLogStr qport - mapConcurrently_ ($ app) - [ runQUIC (quicset qport) settings - , runTLS tlsset (setAltSvc (altsvc qport) settings) - ] - | otherwise = runTLS tlsset settings + case (dropped, _quic) of + (True, Just qport) | qport < 1024 -> + logger ERROR $ "dropping root priviledge will likely break QUIC connection over UDP port " <> toLogStr (show qport) + (True, _) -> logger INFO "root priviledge dropped" + _ -> return () #else - runner | isSSL = runTLS tlsset settings - | otherwise = runSettings settings + when dropped $ logger INFO "root priviledge dropped" #endif +#endif - pauth <- case _auth of - Nothing -> return Nothing - Just f -> do - logger INFO $ "read username and passwords from " <> toLogStr f - userList <- BS8.lines <$> BS8.readFile f - let anyPlaintext = any (\line -> length (BS8.elemIndices ':' line) /= 2) userList - processUser userpass = case passwordReader userpass of - Nothing -> do - logger WARN $ "unable to parse line from password file: " <> toLogStr userpass - return Nothing - Just (user, pass) -> do - salted <- hashPasswordWithRandomSalt pass - logger TRACE $ "parsed user (with salted password) from password file: " <> toLogStr (passwordWriter user salted) - return $ Just (user, salted) - passwordByUser <- HM.fromList . catMaybes <$> mapM processUser userList - when anyPlaintext $ do - logger INFO $ "writing back to password file " <> toLogStr f - BS8.writeFile f (BS8.unlines [ passwordWriter u p | (u, p) <- HM.toList passwordByUser]) - let verify line = do - idx <- BS8.elemIndex ':' line - let user = BS8.take idx line - pass = BS8.drop (idx + 1) line - targetPass <- HM.lookup user passwordByUser - return $ verifyPassword targetPass pass - return $ Just (\line -> verify line == Just True) + pauth <- loadProxyAuth logger _auth - manager <- newTlsManager + manager <- newTlsManager - let revSorted = sortOn (\(a,b,_) -> Down (isJust a, BS8.length b)) _rev - pset = ProxySettings pauth (Just _name) _ws revSorted _hide (_naive && isSSL) _acme logger - proxy = healthCheckProvider $ - acmeProvider pset $ - (if isSSL then forceSSL pset else id) $ - httpProxy pset manager $ - reverseProxy pset manager fallback + let proxyRuntime = buildProxyRuntime runtimeConfig conf logger pauth isSSL + pset = runtimeProxySettings proxyRuntime + revSorted = runtimeReverseRoutes proxyRuntime + proxy = buildProxyApplication isSSL pset manager fallback - forM_ _ws $ \ws -> logger INFO $ "websocket redirect: " <> toLogStr ws - unless (null revSorted) $ logger INFO $ "reverse proxy: " <> toLogStr (show revSorted) - forM_ _doh $ \doh -> logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr doh + forM_ _ws $ \ws -> logger INFO $ "websocket redirect: " <> toLogStr ws + unless (null revSorted) $ logger INFO $ "reverse proxy: " <> toLogStr (show revSorted) + forM_ _doh $ \doh -> logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr doh - logger INFO $ "bind to TCP port " <> toLogStr (fromMaybe "[::]" _bind) <> ":" <> toLogStr _port - case _doh of - Nothing -> runner proxy - Just doh -> createResolver doh (\resolver -> runner (dnsOverHTTPS resolver proxy)) + runProxyServer conf logger settings smgr allCerts proxy diff --git a/src/Network/HProx/Auth.hs b/src/Network/HProx/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Auth.hs @@ -0,0 +1,53 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.Auth + ( loadProxyAuth + ) where + +import Control.Monad (when) +import Data.ByteString.Char8 qualified as BS8 +import Data.HashMap.Strict qualified as HM +import Data.Maybe (catMaybes) + +import Network.HProx.Log +import Network.HProx.Util + +loadProxyAuth :: Logger -> Maybe FilePath -> IO (Maybe (BS8.ByteString -> Bool)) +loadProxyAuth _ Nothing = return Nothing +loadProxyAuth logger (Just f) = do + logger INFO $ "read username and passwords from " <> toLogStr f + userList <- zip [1 :: Int ..] . map stripTrailingCarriageReturn . BS8.lines <$> BS8.readFile f + let anyPlaintext = any (\(_, line) -> length (BS8.elemIndices ':' line) /= 2) userList + processUser (lineNumber, userpass) = case passwordReader userpass of + Nothing -> do + logger WARN $ "unable to parse line " <> toLogStr lineNumber <> malformedLineUserContext userpass <> " from password file" + return Nothing + Just (user, pass) -> do + salted <- hashPasswordWithRandomSalt pass + logger TRACE $ "parsed user (with salted password) from password file: " <> toLogStr (passwordWriter user salted) + return $ Just (user, salted) + passwordByUser <- HM.fromList . catMaybes <$> mapM processUser userList + when anyPlaintext $ do + logger INFO $ "writing back to password file " <> toLogStr f + BS8.writeFile f (BS8.unlines [ passwordWriter u p | (u, p) <- HM.toList passwordByUser]) + let verify line = do + idx <- BS8.elemIndex ':' line + let user = BS8.take idx line + pass = BS8.drop (idx + 1) line + targetPass <- HM.lookup user passwordByUser + return $ verifyPassword targetPass pass + return $ Just (\line -> verify line == Just True) + +stripTrailingCarriageReturn :: BS8.ByteString -> BS8.ByteString +stripTrailingCarriageReturn line + | "\r" `BS8.isSuffixOf` line = BS8.init line + | otherwise = line + +malformedLineUserContext :: BS8.ByteString -> LogStr +malformedLineUserContext line = + case BS8.elemIndex ':' line of + Nothing -> "" + Just 0 -> "" + Just i -> " for user " <> toLogStr (BS8.take i line) diff --git a/src/Network/HProx/Config.hs b/src/Network/HProx/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Config.hs @@ -0,0 +1,234 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. +{-# LANGUAGE CPP #-} + +module Network.HProx.Config + ( CertFile(..) + , Config(..) + , defaultConfig + , getConfig + ) where + +import Data.ByteString.Char8 qualified as BS8 +import Data.List (elemIndex, elemIndices) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Version (showVersion) +import Options.Applicative + +import Network.HProx.Log +import Network.HProx.Util +import Paths_hprox + +-- | Configuration of HProx, see @hprox --help@ for details +data Config = Config + { _bind :: !(Maybe String) + , _port :: !Int + , _ssl :: ![(String, CertFile)] + , _auth :: !(Maybe FilePath) + , _ws :: !(Maybe BS8.ByteString) + , _rev :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)] + , _doh :: !(Maybe String) + , _hide :: !Bool + , _naive :: !Bool + , _name :: !BS8.ByteString + , _acme :: !(Maybe BS8.ByteString) + , _log :: !String + , _loglevel :: !LogLevel +#ifdef OS_UNIX + , _user :: !(Maybe String) + , _group :: !(Maybe String) +#endif +#ifdef QUIC_ENABLED + , _quic :: !(Maybe Int) +#endif + } + +-- | Default value of 'Config', same as running @hprox@ without arguments +defaultConfig :: Config +defaultConfig = Config + { _bind = Nothing + , _port = 3000 + , _ssl = [] + , _auth = Nothing + , _ws = Nothing + , _rev = [] + , _doh = Nothing + , _hide = False + , _naive = False + , _name = "hprox" + , _acme = Nothing + , _log = "stdout" + , _loglevel = INFO +#ifdef OS_UNIX + , _user = Nothing + , _group = Nothing +#endif +#ifdef QUIC_ENABLED + , _quic = Nothing +#endif + } + +-- | Certificate file pairs +data CertFile = CertFile + { certfile :: !FilePath + , keyfile :: !FilePath + } + +parser :: ParserInfo Config +parser = info (helper <*> ver <*> config) (fullDesc <> progDesc desc) + where + parseBoundedPort optionName raw = + case reads raw of + [(parsedPort, "")] | validPort parsedPort -> Right parsedPort + _ -> Left $ optionName <> " must be in range 1..65535" + + validPort parsedPort = parsedPort >= (1 :: Int) && parsedPort <= 65535 + + parseSSL s = case splitBy ':' s of + host :| [cert, key] -> Right (host, CertFile cert key) + _otherwise -> Left "invalid format for ssl certificates" + + parseRev0 s@('/':_) = do + (domain, prefix, remote) <- case elemIndices '/' s of + [] -> Nothing + indices -> let (prefix, remote) = splitAt (last indices + 1) s + in Just (Nothing, BS8.pack prefix, BS8.pack remote) + if BS8.null remote + then Nothing + else Just (domain, prefix, remote) + parseRev0 remote + | null remote = Nothing + | otherwise = Just (Nothing, "/", BS8.pack remote) + + parseRev ('/':'/':s) = case elemIndex '/' s of + Nothing -> Nothing + Just 0 -> Nothing + Just ind -> let (domain, other) = splitAt ind s + in do (_, prefix, remote) <- parseRev0 other + return (Just (BS8.pack domain), prefix, remote) + parseRev s = parseRev0 s + + desc = "a lightweight HTTP proxy server, and more" + ver = infoOption (showVersion version) (long "version" <> help "Display the version information") + + config = Config <$> bind + <*> port + <*> ssl + <*> auth + <*> ws + <*> rev + <*> doh + <*> hide + <*> naive + <*> name + <*> acme + <*> logging + <*> loglevel +#ifdef OS_UNIX + <*> user + <*> group +#endif +#ifdef QUIC_ENABLED + <*> quic +#endif + + bind = optional $ strOption + ( long "bind" + <> short 'b' + <> metavar "bind_ip" + <> help "Specify the IP address to bind to (default: all interfaces)") + + port = option (eitherReader (parseBoundedPort "--port")) + ( long "port" + <> short 'p' + <> metavar "port" + <> value 3000 + <> showDefault + <> help "Specify the port number") + + ssl = many $ option (eitherReader parseSSL) + ( long "tls" + <> short 's' + <> metavar "hostname:cerfile:keyfile" + <> help "Enable TLS and specify a domain with its associated TLS certificate (can be specified multiple times for multiple domains)") + + auth = optional $ strOption + ( long "auth" + <> short 'a' + <> metavar "userpass.txt" + <> help "Specify the password file for proxy authentication. Plaintext passwords should be in the format 'user:pass' and will be automatically Argon2-hashed by hprox. Ensure that the password file with plaintext password is writable") + + ws = optional $ strOption + ( long "ws" + <> metavar "remote-host:port" + <> help "Specify the remote host to handle WebSocket requests (port 443 indicates an HTTPS remote server)") + + rev = many $ option (maybeReader parseRev) + ( long "rev" + <> metavar "[//domain/][/prefix/]remote-host:port" + <> help "Specify the remote host for reverse proxy (port 443 indicates an HTTPS remote server). An optional '//domain/' will only process requests with the 'Host: domain' header, and an optional '/prefix/' can be specified as a prefix to be matched (and stripped in proxied request)") + + doh = optional $ strOption + ( long "doh" + <> metavar "dns-server:port" + <> help "Enable DNS-over-HTTPS (DoH) support (port 53 will be used if not specified)") + + hide = switch + ( long "hide" + <> help "Never send 'Proxy Authentication Required' response. Note that this might break the use of HTTPS proxy in browsers") + + naive = switch + ( long "naive" + <> help "Add naiveproxy-compatible padding (requires TLS)") + + name = strOption + ( long "name" + <> metavar "server-name" + <> value "hprox" + <> showDefault + <> help "Specify the server name for the 'Server' header") + + acme = optional $ strOption + ( long "acme" + <> metavar "ACCOUNT_THUMBPRINT" + <> help "Set the thumbprint for stateless http-01 ACME challenge as specified by RFC8555") + + logging = strOption + ( long "log" + <> metavar "" + <> value "stdout" + <> showDefault + <> help "Specify the logging type") + + loglevel = option (maybeReader logLevelReader) + ( long "loglevel" + <> metavar "" + <> value INFO + <> help "Specify the logging level (default: info)") + +#ifdef OS_UNIX + user = optional $ strOption + ( long "user" + <> short 'u' + <> metavar "nobody" + <> help "Drop root priviledge and setuid to the specified user (like nobody)") + + group = optional $ strOption + ( long "group" + <> short 'g' + <> metavar "nogroup" + <> help "Drop root priviledge and setgid to the specified group") +#endif + +#ifdef QUIC_ENABLED + quic = optional $ option (eitherReader (parseBoundedPort "--quic")) + ( long "quic" + <> short 'q' + <> metavar "port" + <> help "Enable QUIC (HTTP/3) on UDP port") +#endif + +-- | Read 'Config' from command line arguments +getConfig :: IO Config +getConfig = execParser parser diff --git a/src/Network/HProx/DoH.hs b/src/Network/HProx/DoH.hs --- a/src/Network/HProx/DoH.hs +++ b/src/Network/HProx/DoH.hs @@ -1,12 +1,17 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. module Network.HProx.DoH - ( createResolver + ( DoHRequest(..) + , createResolver , dnsOverHTTPS + , dnsOverHTTPSWithLookup + , parseDoHRequest + , parseDoHRequestWithBodyReader ) where +import Data.ByteString qualified as BS import Data.ByteString.Base64.URL qualified as Base64 import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS @@ -19,6 +24,15 @@ import Network.HProx.Util +data DoHRequest = DoHRequest + { dohIdentifier :: !DNS.Identifier + , dohQuestion :: !Question + } + deriving (Eq, Show) + +maxPostBodyLength :: Int +maxPostBodyLength = 4096 + createResolver :: String -> (Resolver -> IO a) -> IO a createResolver remote handle = do seed <- DNS.makeResolvSeed conf @@ -30,34 +44,89 @@ conf = DNS.defaultResolvConf { resolvInfo = info } dnsOverHTTPS :: Resolver -> Middleware -dnsOverHTTPS resolver fallback req respond - | pathInfo req == ["dns-query"] && isSecure req = handleDoH resolver req respond - | otherwise = fallback req respond +dnsOverHTTPS resolver = + dnsOverHTTPSWithLookup $ \Question{..} -> DNS.lookupRaw resolver qname qtype -handleDoH :: Resolver -> Application -handleDoH resolver req respond +dnsOverHTTPSWithLookup :: (Question -> IO (Either DNS.DNSError DNSMessage)) -> Middleware +dnsOverHTTPSWithLookup lookupRaw fallback req respond + | pathInfo req == ["dns-query"] && isSecure req = handleDoH lookupRaw req respond + | otherwise = fallback req respond + +handleDoH :: (Question -> IO (Either DNS.DNSError DNSMessage)) -> Application +handleDoH lookupRaw req respond = do + dohRequest <- parseDoHRequest req + case dohRequest of + Nothing -> respond errorResp + Just DoHRequest{..} -> do + resp <- lookupRaw dohQuestion + respond $ case resp of + Left _ -> resolverErrorResp + Right msg -> encodeDoHResponse dohIdentifier msg + +parseDoHRequest :: Request -> IO (Maybe DoHRequest) +parseDoHRequest req = parseDoHRequestWithBodyReader (getRequestBodyChunk req) req + +parseDoHRequestWithBodyReader :: IO BS.ByteString -> Request -> IO (Maybe DoHRequest) +parseDoHRequestWithBodyReader readChunk req | requestMethod req == "GET", - [("dns", Just dnsStr)] <- queryString req, - Right dnsQuery <- Base64.decodeUnpadded dnsStr, - Right (DNSMessage { question = [q], header = DNSHeader {..} }) <- DNS.decode dnsQuery = - handleQuery identifier q - | requestMethod req == "POST", - KnownLength len <- requestBodyLength req, - len <= 4096 = do - dnsQuery <- getRequestBodyChunk req - case DNS.decode dnsQuery of - Right (DNSMessage { question = [q], header = DNSHeader {..} }) -> handleQuery identifier q - _otherwise -> respond errorResp - | otherwise = respond errorResp + [("dns", Just dnsStr)] <- queryString req = + return $ decodeDoHQuery =<< either (const Nothing) Just (Base64.decodeUnpadded dnsStr) + | requestMethod req == "POST" = + case requestBodyLength req of + KnownLength len + | len <= fromIntegral maxPostBodyLength -> + decodeDoHQuery <$> readRequestBody readChunk (fromIntegral len) + ChunkedBody -> + decodeDoHQuery <$> readChunkedRequestBody readChunk maxPostBodyLength + _otherwise -> return Nothing + | otherwise = return Nothing + +readRequestBody :: IO BS.ByteString -> Int -> IO BS.ByteString +readRequestBody readChunk expectedLength = go expectedLength [] where - errorResp = responseLBS HT.status400 [("Content-Type", "text/plain")] "invalid dns-over-https request" + go remaining chunks + | remaining <= 0 = return $ BS.concat $ reverse chunks + | otherwise = do + chunk <- readChunk + if BS.null chunk + then return $ BS.concat $ reverse chunks + else do + let (accepted, _extra) = BS.splitAt remaining chunk + nextRemaining = remaining - BS.length accepted + go nextRemaining (accepted : chunks) - handleQuery ident Question{..} = do - resp <- DNS.lookupRaw resolver qname qtype - respond $ case resp of - Left _ -> errorResp - Right dnsResp@DNSMessage{header = header} -> - let encoded = DNS.encode (dnsResp {header = header {identifier = ident} }) in - responseKnownLength HT.status200 - [("Content-Type", "application/dns-message")] - (LBS.fromStrict encoded) +readChunkedRequestBody :: IO BS.ByteString -> Int -> IO BS.ByteString +readChunkedRequestBody readChunk maxLength = go 0 [] + where + go total chunks = do + chunk <- readChunk + if BS.null chunk + then return $ BS.concat $ reverse chunks + else do + let nextTotal = total + BS.length chunk + if nextTotal > maxLength + then return "" + else go nextTotal (chunk : chunks) + +decodeDoHQuery :: BS8.ByteString -> Maybe DoHRequest +decodeDoHQuery dnsQuery = + case DNS.decode dnsQuery of + Right (DNSMessage { question = [q], header = DNSHeader {..} }) -> + Just DoHRequest + { dohIdentifier = identifier + , dohQuestion = q + } + _otherwise -> Nothing + +encodeDoHResponse :: DNS.Identifier -> DNSMessage -> Response +encodeDoHResponse ident dnsResp@DNSMessage{header = header} = + let encoded = DNS.encode (dnsResp {header = header {identifier = ident} }) + in responseKnownLength HT.status200 + [("Content-Type", "application/dns-message")] + (LBS.fromStrict encoded) + +errorResp :: Response +errorResp = responseLBS HT.status400 [("Content-Type", "text/plain")] "invalid dns-over-https request" + +resolverErrorResp :: Response +resolverErrorResp = responseLBS HT.status502 [("Content-Type", "text/plain")] "dns resolver failure" diff --git a/src/Network/HProx/Headers.hs b/src/Network/HProx/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Headers.hs @@ -0,0 +1,55 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.Headers + ( cdnLoopHeader + , forwardedHostHeader + , forwardedProtoHeader + , headerValueEquals + , isCDNHeader + , isForwardedHeader + , isProxyHeader + , isProxyStripHeader + , xRealIPHeader + , xSchemeHeader + ) where + +import Data.ByteString qualified as BS +import Data.CaseInsensitive qualified as CI +import Network.HTTP.Types.Header (HeaderName) + +cdnLoopHeader :: HeaderName +cdnLoopHeader = "cdn-loop" + +forwardedHostHeader :: HeaderName +forwardedHostHeader = "x-forwarded-host" + +forwardedProtoHeader :: HeaderName +forwardedProtoHeader = "x-forwarded-proto" + +xRealIPHeader :: HeaderName +xRealIPHeader = "X-Real-IP" + +xSchemeHeader :: HeaderName +xSchemeHeader = "X-Scheme" + +isProxyHeader :: HeaderName -> Bool +isProxyHeader header = "proxy" `BS.isPrefixOf` CI.foldedCase header + +isForwardedHeader :: HeaderName -> Bool +isForwardedHeader header = + folded == "forwarded" || "x-forwarded" `BS.isPrefixOf` folded + where + folded = CI.foldedCase header + +isCDNHeader :: HeaderName -> Bool +isCDNHeader header = "cf-" `BS.isPrefixOf` CI.foldedCase header || header == cdnLoopHeader + +headerValueEquals :: BS.ByteString -> BS.ByteString -> Bool +headerValueEquals expected actual = CI.mk expected == CI.mk actual + +isProxyStripHeader :: HeaderName -> Bool +isProxyStripHeader header = + isProxyHeader header || isForwardedHeader header || isCDNHeader header || + header == xRealIPHeader || header == xSchemeHeader diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs --- a/src/Network/HProx/Impl.hs +++ b/src/Network/HProx/Impl.hs @@ -1,34 +1,39 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. {-# LANGUAGE ViewPatterns #-} module Network.HProx.Impl - ( ProxySettings(..) + ( HttpProxyTarget(..) + , ProxySettings(..) , acmeProvider , forceSSL , healthCheckProvider , httpConnectProxy + , httpConnectProxyWith , httpGetProxy , httpProxy , logRequest , pacProvider + , renderHttpProxyAuthority , reverseProxy + , selectHttpProxyTarget ) where import Control.Applicative ((<|>)) import Control.Concurrent.Async (cancel, wait, waitEither, withAsync) -import Control.Exception (SomeException, try) +import Control.Exception (IOException, SomeException, throwIO, try) import Control.Monad (forM_, unless, void, when) import Control.Monad.IO.Class (liftIO) import Data.Binary.Builder qualified as BB import Data.ByteString qualified as BS -import Data.ByteString.Base64 (decodeLenient) +import Data.ByteString.Base64 qualified as B64 import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.CaseInsensitive qualified as CI import Data.Conduit.Network qualified as CN +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Text.Encoding qualified as TE import Network.HTTP.Client qualified as HC import Network.HTTP.ReverseProxy @@ -43,26 +48,43 @@ import Network.Wai import Network.Wai.Middleware.StripHeaders +import Network.HProx.Headers import Network.HProx.Log import Network.HProx.Naive +import Network.HProx.Route import Network.HProx.Util data ProxySettings = ProxySettings - { proxyAuth :: !(Maybe (BS.ByteString -> Bool)) - , passPrompt :: !(Maybe BS.ByteString) - , wsRemote :: !(Maybe BS.ByteString) - , revRemoteMap :: ![(Maybe BS.ByteString, BS.ByteString, BS.ByteString)] - , hideProxyAuth :: !Bool - , naivePadding :: !Bool - , acmeThumbprint :: !(Maybe BS.ByteString) - , logger :: !Logger - } + { proxyAuth :: !(Maybe (BS.ByteString -> Bool)) + , passPrompt :: !(Maybe BS.ByteString) + , wsRemote :: !(Maybe BS.ByteString) + , revRemoteMap :: ![ReverseRoute] + , hideProxyAuth :: !Bool + , naivePadding :: !Bool + , acmeThumbprint :: !(Maybe BS.ByteString) + , logger :: !Logger + } +data HttpProxyTarget = HttpProxyTarget + { httpProxyTargetHost :: !BS.ByteString + , httpProxyTargetPort :: !Int + , httpProxyTargetRawPath :: !BS.ByteString + } + deriving (Eq, Show) + +renderHttpProxyAuthority :: HttpProxyTarget -> BS.ByteString +renderHttpProxyAuthority HttpProxyTarget{..} = renderAuthorityWithDefault 80 httpProxyTargetHost httpProxyTargetPort + +renderAuthorityWithDefault :: Int -> BS.ByteString -> Int -> BS.ByteString +renderAuthorityWithDefault defaultPort host port + | port == defaultPort = host + | otherwise = BS.concat [host, ":", BS8.pack (show port)] + logRequest :: Request -> LogStr -logRequest req = toLogStr (requestMethod req) <> - " " <> hostname <> toLogStr (rawPathInfo req) <> - " " <> toLogStr (show $ httpVersion req) <> - " " <> (if isSecure req then "(tls) " else "") +logRequest req = toLogStr (requestMethod req) <> " " + <> hostname <> toLogStr (rawPathInfo req) <> " " + <> toLogStr (show $ httpVersion req) <> " " + <> (if isSecure req then "(tls) " else "") <> toLogStr (show $ remoteHost req) where isConnect = requestMethod req == "CONNECT" @@ -81,41 +103,70 @@ redirectToSSL :: Application redirectToSSL req respond - | Just host <- requestHeaderHost req = respond $ responseKnownLength + | Just _ <- requestHeaderHost req = respond $ responseKnownLength HT.status301 - [("Location", "https://" `BS.append` host)] + [("Location", redirectLocation req)] "" - | otherwise = respond $ responseKnownLength + | otherwise = respond $ responseKnownLength (HT.mkStatus 426 "Upgrade Required") [("Upgrade", "TLS/1.0, HTTP/1.1"), ("Connection", "Upgrade")] "" -isProxyHeader :: HT.HeaderName -> Bool -isProxyHeader h = "proxy" `BS.isPrefixOf` CI.foldedCase h - -isForwardedHeader :: HT.HeaderName -> Bool -isForwardedHeader h = "x-forwarded" `BS.isPrefixOf` CI.foldedCase h +redirectLocation :: Request -> BS.ByteString +redirectLocation req + | Just HttpProxyTarget{..} <- selectHttpProxyTarget req = + BS.concat + [ "https://" + , renderRedirectAuthority httpProxyTargetHost httpProxyTargetPort + , httpProxyTargetRawPath + , rawQueryString req + ] + | Just host <- requestHeaderHost req = + BS.concat ["https://", host, originFormPathAndQuery req] + | otherwise = "https://" -isCDNHeader :: HT.HeaderName -> Bool -isCDNHeader h = "cf-" `BS.isPrefixOf` CI.foldedCase h || h == "cdn-loop" +renderRedirectAuthority :: BS.ByteString -> Int -> BS.ByteString +renderRedirectAuthority host port + | port == 80 || port == 443 = host + | otherwise = renderAuthorityWithDefault 443 host port -isToStripHeader :: HT.HeaderName -> Bool -isToStripHeader h = isProxyHeader h || isForwardedHeader h || isCDNHeader h || h == "X-Real-IP" || h == "X-Scheme" +originFormPathAndQuery :: Request -> BS.ByteString +originFormPathAndQuery req + | BS.null path || "/" `BS.isPrefixOf` path = path <> rawQueryString req + | otherwise = "" + where + path = rawPathInfo req -checkAuth :: ProxySettings -> Request -> Bool +checkAuth :: ProxySettings -> Request -> IO Bool checkAuth ProxySettings{..} req = case (proxyAuth, authRsp) of - (Nothing, _) -> True - (_, Nothing) -> False - (Just check, Just provided) -> - let decoded = decodeLenient $ snd $ BS8.spanEnd (/=' ') provided - authorized = check decoded + (Nothing, _) -> return True + (_, Nothing) -> return False + (Just check, Just provided) -> do + let decoded = parseBasicProxyAuthorization provided + authorized = maybe False check decoded authMsg = if authorized then "authorized" else "unauthorized" - logMsg = authMsg <> " request (credential: " <> toLogStr decoded <> ") from " + logMsg = authMsg <> " request (credential: " <> toLogStr (redactedCredential decoded) <> ") from " <> toLogStr (show (remoteHost req)) - in pureLogger logger TRACE logMsg authorized + logger TRACE logMsg + return authorized where authRsp = lookup HT.hProxyAuthorization (requestHeaders req) +parseBasicProxyAuthorization :: BS.ByteString -> Maybe BS.ByteString +parseBasicProxyAuthorization authHeader = + case BS8.words authHeader of + [scheme, payload] | CI.mk scheme == ("basic" :: CI.CI BS.ByteString) + -> either (const Nothing) Just (B64.decode payload) + _otherwise + -> Nothing + +redactedCredential :: Maybe BS.ByteString -> BS.ByteString +redactedCredential Nothing = "" +redactedCredential (Just decoded) = + case BS8.break (== ':') decoded of + (username, password) | not (BS.null password) -> BS.concat [username, ":"] + _otherwise -> "" + parseConnectProxy :: Request -> Maybe (BS.ByteString, Int) parseConnectProxy req | requestMethod req == "CONNECT" = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort) @@ -147,9 +198,9 @@ pacProvider :: Middleware pacProvider fallback req respond | pathInfo req == [".hprox", "config.pac"], - Just host' <- lookup "x-forwarded-host" (requestHeaders req) <|> requestHeaderHost req = - let issecure = case lookup "x-forwarded-proto" (requestHeaders req) of - Just proto -> proto == "https" + Just host' <- lookup forwardedHostHeader (requestHeaders req) <|> requestHeaderHost req = + let issecure = case lookup forwardedProtoHeader (requestHeaders req) of + Just proto -> headerValueEquals "https" proto Nothing -> isSecure req scheme = if issecure then "HTTPS" else "PROXY" defaultPort = if issecure then ":443" else ":80" @@ -180,95 +231,151 @@ where settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } - checkDomain Nothing _ = True - checkDomain _ Nothing = False - checkDomain (Just a) (Just b) = a == b + proxyResponseFor req = + case findMatchingRoute revRemoteMap (requestHeaderHost req) (rawPathInfo req) of + Nothing -> WPRApplication fallback + Just route -> routeProxyResponse route req - proxyResponseFor req = go revRemoteMap - where - go ((mTargetHost, prefix, revRemote):left) - | checkDomain mTargetHost mReqHost && prefix `BS.isPrefixOf` rawPathInfo req = - if revPort == 443 - then WPRModifiedRequestSecure nreq (ProxyDest revHost revPort) - else WPRModifiedRequest nreq (ProxyDest revHost revPort) - | otherwise = go left - where - mReqHost = fmap (fst . parseHostPortWithDefault (error "unused port number")) (requestHeaderHost req) - (revHost, revPort) = parseHostPortWithDefault 80 revRemote + routeProxyResponse route req = + let rewrite = rewriteReverseProxyRequest route (requestHeaders req) (rawPathInfo req) nreq = req - { requestHeaders = hdrs - , requestHeaderHost = Just revHost - , rawPathInfo = BS.drop (BS.length prefix - 1) (rawPathInfo req) - } - hdrs = (HT.hHost, revHost) : [ (hdn, hdv) - | (hdn, hdv) <- requestHeaders req - , not (isToStripHeader hdn) && hdn /= HT.hHost - ] - go _ = WPRApplication fallback + { requestHeaders = rewriteHeaders rewrite + , requestHeaderHost = rewriteRequestHost rewrite + , rawPathInfo = rewriteRawPath rewrite + } + dest = ProxyDest (rewriteUpstream rewrite) (rewritePort rewrite) + in if rewriteSecure rewrite + then WPRModifiedRequestSecure nreq dest + else WPRModifiedRequest nreq dest +selectHttpProxyTarget :: Request -> Maybe HttpProxyTarget +selectHttpProxyTarget req + | requestMethod req == "CONNECT" = Nothing + | isRawPathProxy = do + (host, port) <- parseProxyHostPortWithDefault defaultPort hostPortP + return HttpProxyTarget + { httpProxyTargetHost = host + , httpProxyTargetPort = port + , httpProxyTargetRawPath = newRawPathP + } + | isHTTP2Proxy || hasProxyHeader = do + hostPort <- requestHeaderHost req + (host, port) <- parseProxyHostPortWithDefault defaultPort hostPort + return HttpProxyTarget + { httpProxyTargetHost = host + , httpProxyTargetPort = port + , httpProxyTargetRawPath = rawPath + } + | otherwise = Nothing + where + rawPath = rawPathInfo req + rawPathPrefix = "http://" + defaultPort = 80 + + isRawPathProxy = rawPathPrefix `BS.isPrefixOf` rawPath + hasProxyHeader = any (isProxyHeader.fst) (requestHeaders req) + scheme = lookup xSchemeHeader (requestHeaders req) + isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && maybe False (headerValueEquals "http") scheme && isSecure req + + (hostPortP, newRawPathP) = BS8.span (/='/') $ + BS.drop (BS.length rawPathPrefix) rawPath + +parseProxyHostPortWithDefault :: Int -> BS.ByteString -> Maybe (BS.ByteString, Int) +parseProxyHostPortWithDefault defaultPort hostPort + | Just parsed <- parseHostPort hostPort = Just parsed + | BS.null hostPort = Nothing + | hasColon && not isBracketedHost = Nothing + | otherwise = Just (hostPort, defaultPort) + where + hasColon = 58 `BS.elem` hostPort -- ':' + isBracketedHost = "[" `BS.isPrefixOf` hostPort && "]" `BS.isSuffixOf` hostPort + httpGetProxy :: ProxySettings -> HC.Manager -> Middleware -httpGetProxy pset@ProxySettings{..} mgr fallback = waiProxyToSettings (return.proxyResponseFor) settings mgr +httpGetProxy pset@ProxySettings{..} mgr fallback = waiProxyToSettings proxyResponseFor settings mgr where settings = defaultWaiProxySettings { wpsSetIpHeader = SIHNone } proxyResponseFor req - | redirectWebsocket pset req = wsWrapper (ProxyDest wsHost wsPort) - | not isGETProxy = WPRApplication fallback - | checkAuth pset req = WPRModifiedRequest nreq (ProxyDest host port) - | hideProxyAuth = - pureLogger logger WARN ("unauthorized request (hidden without response): " <> logRequest req) $ - WPRApplication fallback - | otherwise = - pureLogger logger WARN ("unauthorized request: " <> logRequest req) $ - WPRResponse (proxyAuthRequiredResponse pset) + | Just (wsDest, wsWrapper) <- websocketTarget = return $ wsWrapper wsDest + | Just target@HttpProxyTarget{..} <- selectHttpProxyTarget req = do + authorized <- checkAuth pset req + if authorized + then return $ WPRModifiedRequest + (proxiedRequest target) + (ProxyDest httpProxyTargetHost httpProxyTargetPort) + else if hideProxyAuth + then do + logger WARN $ "unauthorized request (hidden without response): " <> logRequest req + return $ WPRApplication fallback + else do + logger WARN $ "unauthorized request: " <> logRequest req + return $ WPRResponse (proxyAuthRequiredResponse pset) + | otherwise = return $ WPRApplication fallback where - (wsHost, wsPort) = parseHostPortWithDefault 80 (fromJust wsRemote) - wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest - - notCONNECT = requestMethod req /= "CONNECT" - rawPath = rawPathInfo req - rawPathPrefix = "http://" - defaultPort = 80 - hostHeader = parseHostPortWithDefault defaultPort <$> requestHeaderHost req - - isRawPathProxy = rawPathPrefix `BS.isPrefixOf` rawPath - hasProxyHeader = any (isProxyHeader.fst) (requestHeaders req) - scheme = lookup "X-Scheme" (requestHeaders req) - isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && scheme == Just "http" && isSecure req - - isGETProxy = notCONNECT && (isRawPathProxy || isHTTP2Proxy || isJust hostHeader && hasProxyHeader) + websocketTarget = do + ws <- wsRemote + let (wsHost, wsPort) = parseHostPortWithDefault 80 ws + wsWrapper = if wsPort == 443 then WPRProxyDestSecure else WPRProxyDest + if wpsUpgradeToRaw defaultWaiProxySettings req + then Just (ProxyDest wsHost wsPort, wsWrapper) + else Nothing - nreq = req - { rawPathInfo = newRawPath - , requestHeaders = filter (not.isToStripHeader.fst) $ requestHeaders req - } + proxiedRequest target@HttpProxyTarget{..} = + let authority = renderHttpProxyAuthority target + in req + { rawPathInfo = httpProxyTargetRawPath + , requestHeaderHost = Just authority + , requestHeaders = + (HT.hHost, authority) : + filter (not.outgoingStripHeader.fst) (requestHeaders req) + } - ((host, port), newRawPath) - | isRawPathProxy = (parseHostPortWithDefault defaultPort hostPortP, newRawPathP) - | otherwise = (fromJust hostHeader, rawPath) - where - (hostPortP, newRawPathP) = BS8.span (/='/') $ - BS.drop (BS.length rawPathPrefix) rawPath + outgoingStripHeader header = header == HT.hHost || isProxyStripHeader header httpConnectProxy :: ProxySettings -> Middleware -httpConnectProxy pset@ProxySettings{..} fallback req@(parseConnectProxy -> Just (host, port)) respond - | checkAuth pset req = do - forM_ mPaddingType $ \paddingType -> +httpConnectProxy = httpConnectProxyWith CN.runTCPClient + +httpConnectProxyWith + :: (CN.ClientSettings -> (CN.AppData -> IO ResponseReceived) -> IO ResponseReceived) + -> ProxySettings + -> Middleware +httpConnectProxyWith runTCPClient pset@ProxySettings{..} fallback req@(parseConnectProxy -> Just (host, port)) respond = do + authorized <- checkAuth pset req + if authorized + then do + forM_ mPaddingType $ \paddingType -> logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <> " for " <> logRequest req - respondResponse - | hideProxyAuth = do - logger WARN $ "unauthorized request (hidden without response): " <> logRequest req - fallback req respond - | otherwise = do - logger WARN $ "unauthorized request: " <> logRequest req - respond (proxyAuthRequiredResponse pset) + responseStarted <- newIORef False + connected <- tryIOException $ runTCPClient settings (respondResponse responseStarted) + case connected of + Right received -> return received + Left ex -> do + started <- readIORef responseStarted + if started + then throwIO ex + else do + logger WARN $ "CONNECT upstream failure for " <> logRequest req <> ": " <> toLogStr (show ex) + respond connectFailureResponse + else if hideProxyAuth + then do + logger WARN $ "unauthorized request (hidden without response): " <> logRequest req + fallback req respond + else do + logger WARN $ "unauthorized request: " <> logRequest req + respond (proxyAuthRequiredResponse pset) where settings = CN.clientSettings port host backup = responseKnownLength HT.status500 [("Content-Type", "text/plain")] "HTTP CONNECT tunneling detected, but server does not support responseRaw" + connectFailureResponse = responseKnownLength HT.status502 [("Content-Type", "text/plain")] + "CONNECT upstream connection failed" + + tryIOException :: IO a -> IO (Either IOException a) + tryIOException = try + tryAndCatchAll :: IO a -> IO (Either SomeException a) tryAndCatchAll = try @@ -285,15 +392,18 @@ mPaddingType = if naivePadding then parseRequestForPadding req else Nothing - respondResponse - | HT.httpMajor (httpVersion req) < 2 = respond $ responseRaw (handleConnect True) backup + respondResponse responseStarted server + | HT.httpMajor (httpVersion req) < 2 = do + writeIORef responseStarted True + respond $ responseRaw (handleConnect server True) backup | otherwise = do paddingHeaders <- liftIO $ prepareResponseForPadding mPaddingType + writeIORef responseStarted True respond $ responseStream HT.status200 paddingHeaders streaming where streaming write flush = do flush - handleConnect False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush) + handleConnect server False (getRequestBodyChunk req) (\bs -> write (BB.fromByteString bs) >> flush) yieldHttp1Response = do paddingHeaders <- liftIO $ prepareResponseForPadding mPaddingType @@ -302,8 +412,8 @@ ] yield $ LBS.toStrict $ BB.toLazyByteString ("HTTP/1.1 200 OK\r\n" <> mconcat headers <> "\r\n") - handleConnect :: Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO () - handleConnect http1 fromClient' toClient' = CN.runTCPClient settings $ \server -> + handleConnect :: CN.AppData -> Bool -> IO BS.ByteString -> (BS.ByteString -> IO ()) -> IO () + handleConnect server http1 fromClient' toClient' = let toServer = CN.appSink server fromServer = CN.appSource server fromClient = do @@ -322,4 +432,4 @@ void $ runStreams 5 (runConduit clientToServer) (runConduit serverToClient) -httpConnectProxy _ fallback req respond = fallback req respond +httpConnectProxyWith _ _ fallback req respond = fallback req respond diff --git a/src/Network/HProx/Log.hs b/src/Network/HProx/Log.hs --- a/src/Network/HProx/Log.hs +++ b/src/Network/HProx/Log.hs @@ -1,20 +1,20 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. module Network.HProx.Log ( LogLevel(..) + , LogOutput(..) , LogStr , LogType'(..) , Logger , ToLogStr(..) , logLevelReader - , pureLogger + , logOutputType + , parseLogOutput , withLogger ) where -import System.IO.Unsafe (unsafePerformIO) - import System.Log.FastLogger -- | Logging level, default value is INFO @@ -24,7 +24,7 @@ | WARN | ERROR | NONE - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord) logLevelReader :: String -> Maybe LogLevel logLevelReader "trace" = Just TRACE @@ -35,15 +35,28 @@ logLevelReader "none" = Just NONE logLevelReader _ = Nothing +data LogOutput = LogOutputNone + | LogOutputStdout + | LogOutputStderr + | LogOutputFile !FilePath + deriving (Show, Eq) + +parseLogOutput :: String -> LogOutput +parseLogOutput "none" = LogOutputNone +parseLogOutput "stdout" = LogOutputStdout +parseLogOutput "stderr" = LogOutputStderr +parseLogOutput file = LogOutputFile file + +logOutputType :: LogOutput -> LogType' LogStr +logOutputType LogOutputNone = LogNone +logOutputType LogOutputStdout = LogStdout 4096 +logOutputType LogOutputStderr = LogStderr 4096 +logOutputType (LogOutputFile file) = LogFileNoRotate file 4096 + logWith :: TimedFastLogger -> LogLevel -> LogStr -> IO () logWith logger level logstr = logger (\time -> toLogStr time <> " [" <> toLogStr (show level) <> "] " <> logstr <> "\n") type Logger = LogLevel -> LogStr -> IO () - -{-# NOINLINE pureLogger #-} -pureLogger :: Logger -> LogLevel -> LogStr -> a -> a -pureLogger logger level str a = unsafePerformIO $ logger level str >> return a - withLogger :: LogType -> LogLevel -> ((LogLevel -> LogStr -> IO ()) -> IO ()) -> IO () withLogger logType logLevel toRun = do timeCache <- newTimeCache "%Y/%m/%d %T %Z" diff --git a/src/Network/HProx/Naive.hs b/src/Network/HProx/Naive.hs --- a/src/Network/HProx/Naive.hs +++ b/src/Network/HProx/Naive.hs @@ -1,6 +1,6 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. module Network.HProx.Naive ( PaddingType(..) @@ -17,7 +17,7 @@ import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS import Data.Conduit.Binary qualified as CB -import Data.Maybe (mapMaybe) +import Data.Maybe (listToMaybe, mapMaybe) import Network.HTTP.Types.Header qualified as HT import System.Random (uniformR) import System.Random.Stateful (applyAtomicGen, globalStdGen, runStateGen, uniformRM) @@ -25,6 +25,15 @@ import Data.Conduit import Network.Wai +randomPaddingMinLength :: Int +randomPaddingMinLength = 32 + +randomPaddingMaxLength :: Int +randomPaddingMaxLength = 63 + +randomPaddingPrefixLength :: Int +randomPaddingPrefixLength = 24 + randomPadding :: IO BS8.ByteString randomPadding = applyAtomicGen generate globalStdGen where @@ -32,11 +41,11 @@ countNonHuffman = length nonHuffman generate g0 = runStateGen g0 $ \gen -> do - len <- uniformRM (32, 63) gen - prefix <- replicateM 24 $ do + len <- uniformRM (randomPaddingMinLength, randomPaddingMaxLength) gen + prefix <- replicateM randomPaddingPrefixLength $ do idx <- uniformRM (0, countNonHuffman - 1) gen return $ nonHuffman !! idx - return (BS8.pack (prefix ++ replicate (len - 24) '~')) + return (BS8.pack (prefix ++ replicate (len - randomPaddingPrefixLength) '~')) randInt :: Int -> Int -> IO Int randInt minv maxv = applyAtomicGen (uniformR (minv, maxv)) globalStdGen @@ -80,8 +89,7 @@ parseRequestForPadding :: Request -> Maybe PaddingType parseRequestForPadding req | Just paddingTypesStr <- lookup paddingTypeRequestHeader (requestHeaders req) = - let paddings = mapMaybe parsePaddingType $ BS8.split ',' paddingTypesStr - in if null paddings then Nothing else Just (head paddings) + listToMaybe $ mapMaybe parsePaddingType $ BS8.split ',' paddingTypesStr | Just _ <- lookup legacyPaddingHeader (requestHeaders req) = Just Variant1 | otherwise = Nothing @@ -95,23 +103,50 @@ countPaddingsVariant1 :: Int countPaddingsVariant1 = 8 +variant1HeaderLength :: Int +variant1HeaderLength = 3 + +variant1MaxPaddingLength :: Int +variant1MaxPaddingLength = 255 + +variant1MaxFrameLength :: Int +variant1MaxFrameLength = 65535 + +variant1MaxPayloadLength :: Int +variant1MaxPayloadLength = variant1MaxFrameLength - variant1HeaderLength - variant1MaxPaddingLength + +variant1SmallPayloadThreshold :: Int +variant1SmallPayloadThreshold = 400 + +variant1LargePayloadThreshold :: Int +variant1LargePayloadThreshold = 1024 + +variant1SplitMinLength :: Int +variant1SplitMinLength = 200 + +variant1SplitMaxLength :: Int +variant1SplitMaxLength = 300 + +variant1MinFullPaddingLength :: Int +variant1MinFullPaddingLength = 100 + addPaddingVariant1 :: Int -> PaddingConduit addPaddingVariant1 0 = noPaddingConduit addPaddingVariant1 n = do mbs <- await case mbs of - Nothing -> return () - Just bs | BS.null bs -> return () - Just bs -> do - let remaining = min (BS.length bs) (65535 - 3 - 255) - toConsume <- if remaining > 400 && remaining < 1024 - then liftIO $ randInt 200 300 + Nothing -> return () + Just bs | BS.null bs -> return () + Just bs -> do + let remaining = min (BS.length bs) variant1MaxPayloadLength + toConsume <- if remaining > variant1SmallPayloadThreshold && remaining < variant1LargePayloadThreshold + then liftIO $ randInt variant1SplitMinLength variant1SplitMaxLength else return remaining let (bs0, bs1) = BS.splitAt toConsume bs unless (BS.null bs1) $ leftover bs1 let len = BS.length bs0 - minPaddingLen = if len < 100 then 255 - len else 1 - paddingLen <- liftIO $ randInt minPaddingLen 255 + minPaddingLen = if len < variant1MinFullPaddingLength then variant1MaxPaddingLength - len else 1 + paddingLen <- liftIO $ randInt minPaddingLen variant1MaxPaddingLength let header = mconcat (map (BB.singleton.fromIntegral) [len `div` 256, len `mod` 256, paddingLen]) body = BB.fromByteString bs0 tailer = BB.fromByteString (BS.replicate paddingLen 0) diff --git a/src/Network/HProx/Platform/Quic.hs b/src/Network/HProx/Platform/Quic.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Platform/Quic.hs @@ -0,0 +1,87 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +{-# LANGUAGE CPP #-} + +module Network.HProx.Platform.Quic + ( quicAddressPlan + , quicAltSvc + , quicUse0RTT + , runQuicAndTls + ) where + +import Data.ByteString.Char8 qualified as BS8 +import Network.TLS qualified as TLS +import Network.Wai (Application) +import Network.Wai.Handler.Warp (Settings) +import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) + +import Network.HProx.Log + +#ifdef QUIC_ENABLED +import Control.Concurrent.Async (mapConcurrently_) +import Data.Default.Class (def) +import Data.List (find) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Network.QUIC.Internal qualified as Q +import Network.Wai.Handler.Warp (setAltSvc) +import Network.Wai.Handler.WarpQUIC (runQUIC) +#endif + +quicAltSvc :: Int -> BS8.ByteString +quicAltSvc port = BS8.concat ["h3=\":", BS8.pack $ show port, "\""] + +quicAddressPlan :: Maybe String -> Int -> [(String, Int)] +-- Keep both wildcard sockets explicit: relying on an IPv6 wildcard socket +-- to receive IPv4 traffic depends on the host IPV6_V6ONLY default, while +-- QUIC creates one UDP socket per planned address and does not force that +-- socket option. +quicAddressPlan Nothing port = [("0.0.0.0", port), ("::", port)] +quicAddressPlan (Just bind) port = [(bind, port)] + +quicUse0RTT :: Bool +quicUse0RTT = False + +runQuicAndTls + :: Logger + -> Maybe String + -> Settings + -> TLSSettings + -> (Maybe String -> IO TLS.Credentials) + -> TLS.SessionManager + -> TLS.Credential + -> Int + -> Application + -> IO () +#ifdef QUIC_ENABLED +runQuicAndTls logger bind settings tlsSettings onSNI sessionManager defaultCert qport app = do + logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "all interfaces" bind) <> ":" <> toLogStr qport + mapConcurrently_ ($ app) + [ runQUIC (buildQuicServerConfig bind onSNI sessionManager defaultCert qport) settings + , runTLS tlsSettings (setAltSvc (quicAltSvc qport) settings) + ] + +alpn :: Q.Version -> [BS8.ByteString] -> IO BS8.ByteString +alpn _ protocols = return $ fromMaybe "" $ find (== "h3") protocols + +buildQuicServerConfig + :: Maybe String + -> (Maybe String -> IO TLS.Credentials) + -> TLS.SessionManager + -> TLS.Credential + -> Int + -> Q.ServerConfig +buildQuicServerConfig bind onSNI sessionManager cert port = Q.defaultServerConfig + { Q.scAddresses = [(fromString host, fromIntegral bindPort) | (host, bindPort) <- quicAddressPlan bind port] + , Q.scVersions = [Q.Version1, Q.Version2] + , Q.scCredentials = TLS.Credentials [cert] + , Q.scALPN = Just alpn + , Q.scTlsHooks = def { TLS.onServerNameIndication = onSNI } + , Q.scUse0RTT = quicUse0RTT + , Q.scSessionManager = sessionManager + } +#else +runQuicAndTls _ _ settings tlsSettings _ _ _ _ app = runTLS tlsSettings settings app +#endif diff --git a/src/Network/HProx/Platform/Unix.hs b/src/Network/HProx/Platform/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Platform/Unix.hs @@ -0,0 +1,134 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.HProx.Platform.Unix + ( PrivilegeDropPlan(..) + , ResolvedGroup(..) + , ResolvedUser(..) + , dropRootPriviledge + , planPrivilegeDrop + ) where + +import Control.Applicative +import Control.Monad +import Data.List (nub, sort) + +import Network.HProx.Log + +#ifdef OS_UNIX +import Control.Exception (SomeException, catch) +import System.Exit +import System.Posix.Process (exitImmediately) +import System.Posix.User +#endif + +type PrivilegeID = Integer + +data ResolvedUser = ResolvedUser + { resolvedUserName :: String + , resolvedUserID :: PrivilegeID + , resolvedUserPrimaryGroupID :: PrivilegeID + } + deriving (Eq, Show) + +data ResolvedGroup = ResolvedGroup + { resolvedGroupName :: String + , resolvedGroupID :: PrivilegeID + , resolvedGroupMembers :: [String] + } + deriving (Eq, Show) + +data PrivilegeDropPlan = PrivilegeDropPlan + { privilegeDropUserName :: Maybe String + , privilegeDropUserID :: Maybe PrivilegeID + , privilegeDropGroupName :: Maybe String + , privilegeDropGroupID :: Maybe PrivilegeID + , privilegeDropSupplementaryGroups :: [PrivilegeID] + } + deriving (Eq, Show) + +planPrivilegeDrop :: Maybe ResolvedUser -> Maybe ResolvedGroup -> [ResolvedGroup] -> PrivilegeDropPlan +planPrivilegeDrop userEntry groupEntry allGroups = PrivilegeDropPlan + { privilegeDropUserName = resolvedUserName <$> userEntry + , privilegeDropUserID = resolvedUserID <$> userEntry + , privilegeDropGroupName = resolvedGroupName <$> groupEntry + , privilegeDropGroupID = finalGroupID + , privilegeDropSupplementaryGroups = supplementaryGroups + } + where + finalGroupID = resolvedGroupID <$> groupEntry <|> resolvedUserPrimaryGroupID <$> userEntry + supplementaryGroups = case (resolvedUserName <$> userEntry, finalGroupID) of + (Just name, Just primaryGroupID) -> + nub $ primaryGroupID : [resolvedGroupID entry | entry <- allGroups, name `elem` resolvedGroupMembers entry] + _otherwise -> [] + +#ifdef OS_UNIX +dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool +dropRootPriviledge _ Nothing Nothing = return False +dropRootPriviledge logger user groupName' = do + currentUser <- getRealUserID + currentGroup <- getRealGroupID + if currentUser /= 0 || currentGroup /= 0 + then do + logger WARN $ "Unable to setuid/setgid without root priviledge" <> + ", userID=" <> toLogStr (show currentUser) <> + ", groupID=" <> toLogStr (show currentGroup) + return False + else do + let abort msg = logger ERROR msg >> exitImmediately (ExitFailure 1) + let resolveUser entry = ResolvedUser (userName entry) (fromIntegral $ userID entry) (fromIntegral $ userGroupID entry) + resolveGroup entry = ResolvedGroup (groupName entry) (fromIntegral $ groupID entry) (groupMembers entry) + resolvedUser <- fmap resolveUser <$> mapM getUserEntryForName user + resolvedGroup <- fmap resolveGroup <$> mapM getGroupEntryForName groupName' + allGroups <- maybe (return []) (const $ map resolveGroup <$> getAllGroupEntries) resolvedUser + let plan = planPrivilegeDrop resolvedUser resolvedGroup allGroups + case privilegeDropUserName plan of + Just userName' -> do + logger INFO $ "set supplementary groups for " <> toLogStr userName' + setGroups $ map fromIntegral $ privilegeDropSupplementaryGroups plan + Nothing -> + forM_ (privilegeDropGroupID plan) $ \_ -> do + logger INFO "clear supplementary groups" + setGroups [] + forM_ (privilegeDropGroupID plan) $ \gid -> do + logger INFO $ "setgid to " <> maybe (toLogStr $ show gid) toLogStr (privilegeDropGroupName plan) + setGroupID $ fromIntegral gid + verifyGroupID abort gid + forM_ (privilegeDropUserID plan) $ \uid -> do + logger INFO $ "setuid to " <> maybe (toLogStr $ show uid) toLogStr (privilegeDropUserName plan) + setUserID $ fromIntegral uid + verifyUserID abort uid + verifySupplementaryGroups abort $ privilegeDropSupplementaryGroups plan + logger DEBUG "testing setuid(0), verify that root priviledge can't be regranted" + catch (setUserID 0) $ \(_ :: SomeException) -> logger DEBUG "setuid(0) failed as expected" + changedUser <- getRealUserID + when (changedUser == 0) $ abort "unable to drop root priviledge, aborting" + return True + +verifyUserID :: (LogStr -> IO ()) -> PrivilegeID -> IO () +verifyUserID abort expectedUserID = do + realUserID <- getRealUserID + effectiveUserID <- getEffectiveUserID + when (fromIntegral realUserID /= expectedUserID || fromIntegral effectiveUserID /= expectedUserID || realUserID == 0) $ + abort "failed to setuid, aborting" + +verifyGroupID :: (LogStr -> IO ()) -> PrivilegeID -> IO () +verifyGroupID abort expectedGroupID = do + realGroupID <- getRealGroupID + effectiveGroupID <- getEffectiveGroupID + when (fromIntegral realGroupID /= expectedGroupID || fromIntegral effectiveGroupID /= expectedGroupID || realGroupID == 0) $ + abort "failed to setgid, aborting" + +verifySupplementaryGroups :: (LogStr -> IO ()) -> [PrivilegeID] -> IO () +verifySupplementaryGroups abort expectedGroups = do + changedGroups <- map fromIntegral <$> getGroups + when (sort (nub changedGroups) /= sort (nub expectedGroups)) $ + abort "failed to set supplementary groups, aborting" +#else +dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool +dropRootPriviledge _ _ _ = return False +#endif diff --git a/src/Network/HProx/Route.hs b/src/Network/HProx/Route.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Route.hs @@ -0,0 +1,123 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.Route + ( ReverseProxyRewrite(..) + , ReverseRoute(..) + , findMatchingRoute + , fromReverseRouteTuple + , hostMatches + , prefixMatches + , rewriteReverseProxyRequest + , sortReverseRoutes + ) where + +import Data.ByteString.Char8 qualified as BS8 +import Data.CaseInsensitive qualified as CI +import Data.List (sortOn) +import Data.Maybe (isJust, listToMaybe) +import Data.Ord (Down(..)) +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Header qualified as HT + +import Network.HProx.Headers +import Network.HProx.Util + +data ReverseRoute = ReverseRoute + { routeHost :: !(Maybe BS8.ByteString) + , routePrefix :: !BS8.ByteString + , routeUpstream :: !BS8.ByteString + } + deriving (Eq, Show) + +data ReverseProxyRewrite = ReverseProxyRewrite + { rewriteRoute :: !ReverseRoute + , rewriteRawPath :: !BS8.ByteString + , rewriteHeaders :: !RequestHeaders + , rewriteRequestHost :: !(Maybe BS8.ByteString) + , rewriteUpstream :: !BS8.ByteString + , rewritePort :: !Int + , rewriteSecure :: !Bool + } + deriving (Eq, Show) + +fromReverseRouteTuple :: (Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString) -> ReverseRoute +fromReverseRouteTuple (host, prefix, upstream) = ReverseRoute + { routeHost = host + , routePrefix = normalizeRoutePrefix prefix + , routeUpstream = upstream + } + +sortReverseRoutes :: [ReverseRoute] -> [ReverseRoute] +sortReverseRoutes = sortOn $ \ReverseRoute{..} -> Down (isJust routeHost, BS8.length routePrefix) + +hostMatches :: ReverseRoute -> Maybe BS8.ByteString -> Bool +hostMatches ReverseRoute{ routeHost = Nothing } _ = True +hostMatches ReverseRoute{ routeHost = Just _ } Nothing = False +hostMatches ReverseRoute{ routeHost = Just domain } (Just host) = CI.mk domain == CI.mk host + +prefixMatches :: ReverseRoute -> BS8.ByteString -> Bool +prefixMatches ReverseRoute{..} rawPath + | prefix == "/" = True + | rawPath == prefix = True + | otherwise = prefix `BS8.isPrefixOf` rawPath + && BS8.length rawPath > prefixLength + && BS8.index rawPath prefixLength == '/' + where + prefix = normalizeRoutePrefix routePrefix + prefixLength = BS8.length prefix + +findMatchingRoute :: [ReverseRoute] -> Maybe BS8.ByteString -> BS8.ByteString -> Maybe ReverseRoute +findMatchingRoute routes requestHost rawPath = + listToMaybe $ filter matches $ sortReverseRoutes routes + where + parsedHost = fmap hostOnly requestHost + matches route = hostMatches route parsedHost && prefixMatches route rawPath + +hostOnly :: BS8.ByteString -> BS8.ByteString +hostOnly host = maybe host fst (parseHostPort host) + +normalizeRoutePrefix :: BS8.ByteString -> BS8.ByteString +normalizeRoutePrefix prefix + | BS8.null prefix = "/" + | otherwise = stripTrailingSlash prefixed + where + prefixed + | "/" `BS8.isPrefixOf` prefix = prefix + | otherwise = "/" <> prefix + + stripTrailingSlash value + | BS8.length value > 1 && "/" `BS8.isSuffixOf` value = stripTrailingSlash (BS8.init value) + | otherwise = value + +rewriteReverseProxyRequest :: ReverseRoute -> RequestHeaders -> BS8.ByteString -> ReverseProxyRewrite +rewriteReverseProxyRequest route@ReverseRoute{..} requestHeaders rawPath = ReverseProxyRewrite + { rewriteRoute = route + , rewriteRawPath = rewritePath route rawPath + , rewriteHeaders = (HT.hHost, upstreamHost) : filter keepHeader requestHeaders + , rewriteRequestHost = Just upstreamHost + , rewriteUpstream = upstreamHost + , rewritePort = upstreamPort + , rewriteSecure = upstreamPort == 443 + } + where + (upstreamHost, upstreamPort) = parseHostPortWithDefault 80 routeUpstream + + keepHeader (name, _) = not (isProxyStripHeader name) && name /= HT.hHost + +rewritePath :: ReverseRoute -> BS8.ByteString -> BS8.ByteString +rewritePath route@ReverseRoute{..} rawPath + | not (prefixMatches route rawPath) = rawPath + | prefix == "/" = ensureLeadingSlash rawPath + | otherwise = + case BS8.drop (BS8.length prefix) rawPath of + "" -> "/" + rest -> ensureLeadingSlash rest + where + prefix = normalizeRoutePrefix routePrefix + +ensureLeadingSlash :: BS8.ByteString -> BS8.ByteString +ensureLeadingSlash path + | "/" `BS8.isPrefixOf` path = path + | otherwise = "/" <> path diff --git a/src/Network/HProx/Runtime.hs b/src/Network/HProx/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Network/HProx/Runtime.hs @@ -0,0 +1,333 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.HProx.Runtime + ( ProxyRuntime(..) + , RunnerPlan(..) + , RuntimeConfig(..) + , StartupStep(..) + , WarpRuntimePlan(..) + , buildProxyApplication + , buildProxyRuntime + , buildRuntimeConfig + , buildTlsSettings + , buildWarpRuntimePlan + , buildWarpSettings + , defaultCertificate + , loadTlsCredentials + , lookupSNICredentials + , lookupSNIHost + , runProxyServer + , runtimeExceptionToLog + , selectRunnerPlan + , shouldIgnoreRuntimeException + , shouldSuppressAccessLog + , shouldWrapDNSOverHTTPS + , sniPatternMatches + , startupOrder + , validateRuntimeConfig + ) where + +import Control.Exception + (IOException, SomeException, displayException, fromException, try) +import Data.ByteString.Char8 qualified as BS8 +import Data.Default.Class (def) +import Data.List (sortOn) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Ord (Down(..)) +import Data.String (fromString) +import GHC.IO.Exception (IOErrorType(..)) +import Network.HTTP.Client qualified as HC +import Network.HTTP.Types qualified as HT +import Network.HTTP2.Client qualified as H2 +import Network.TLS qualified as TLS +import Network.Wai (Application, Request, rawPathInfo) +import Network.Wai.Handler.Warp + (InvalidRequest(..), Settings, defaultSettings, defaultShouldDisplayException, runSettings, + setBeforeMainLoop, setHost, setLogger, setNoParsePath, setOnException, setPort, setServerName) +import Network.Wai.Handler.WarpTLS + (OnInsecure(..), TLSSettings, WarpTLSException, defaultTlsSettings, onInsecure, runTLS, + tlsAllowedVersions, tlsCredentials, tlsServerHooks, tlsSessionManager) + +import System.IO.Error (ioeGetErrorType) + +#ifdef QUIC_ENABLED +import Network.HProx.Platform.Quic +import Network.QUIC.Internal qualified as Q +#endif + +import Network.HProx.Config +import Network.HProx.DoH +import Network.HProx.Impl +import Network.HProx.Log +import Network.HProx.Route + +data RuntimeConfig = RuntimeConfig + { runtimeConfigLogOutput :: !LogOutput + , runtimeConfigReverseRoutes :: ![ReverseRoute] + , runtimeConfigReverseRouteTuples :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)] + } + deriving (Eq, Show) + +data ProxyRuntime = ProxyRuntime + { runtimeProxySettings :: !ProxySettings + , runtimeReverseRoutes :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)] + } + +data WarpRuntimePlan = WarpRuntimePlan + { runtimeBindHost :: !String + , runtimePort :: !Int + , runtimeServerName :: !BS8.ByteString + , runtimeNoParsePath :: !Bool + } + deriving (Eq, Show) + +data RunnerPlan + = PlainWarpRunner + | TlsWarpRunner + | QuicAndTlsRunner !Int + deriving (Eq, Show) + +data StartupStep + = InitializeLogger + | LogStartup + | ReadCertificates + | CreateTlsSessionManager + | BuildSettingsAndRunner + | LoadProxyAuth + | CreateHttpManager + | BuildProxyApplication + | LogRuntimeConfig + | StartRunner + deriving (Eq, Show) + +buildRuntimeConfig :: Config -> RuntimeConfig +buildRuntimeConfig Config{..} = RuntimeConfig + { runtimeConfigLogOutput = parseLogOutput _log + , runtimeConfigReverseRoutes = map fromReverseRouteTuple revSorted + , runtimeConfigReverseRouteTuples = revSorted + } + where + revSorted = sortOn (\(a,b,_) -> Down (isJust a, BS8.length b)) _rev + +buildProxyRuntime :: RuntimeConfig -> Config -> Logger -> Maybe (BS8.ByteString -> Bool) -> Bool -> ProxyRuntime +buildProxyRuntime RuntimeConfig{..} Config{..} logger pauth isSSL = ProxyRuntime + { runtimeProxySettings = ProxySettings + { proxyAuth = pauth + , passPrompt = Just _name + , wsRemote = _ws + , revRemoteMap = runtimeConfigReverseRoutes + , hideProxyAuth = _hide + , naivePadding = _naive && isSSL + , acmeThumbprint = _acme + , logger = logger + } + , runtimeReverseRoutes = runtimeConfigReverseRouteTuples + } + +buildProxyApplication :: Bool -> ProxySettings -> HC.Manager -> Application -> Application +buildProxyApplication isSSL pset manager fallback = + healthCheckProvider $ + acmeProvider pset $ + (if isSSL then forceSSL pset else id) $ + httpProxy pset manager $ + reverseProxy pset manager fallback + +selectRunnerPlan :: Config -> [(String, a)] -> RunnerPlan +#ifdef QUIC_ENABLED +selectRunnerPlan Config{..} certs = case certs of + [] -> PlainWarpRunner + _ -> maybe TlsWarpRunner QuicAndTlsRunner _quic +#else +selectRunnerPlan _ certs = case certs of + [] -> PlainWarpRunner + _ -> TlsWarpRunner +#endif + +shouldWrapDNSOverHTTPS :: Config -> Bool +shouldWrapDNSOverHTTPS Config{..} = isJust _doh + +validateRuntimeConfig :: Config -> Either String () +validateRuntimeConfig Config{..} = do + validatePortField "--port" _port +#ifdef QUIC_ENABLED + maybe (Right ()) (validatePortField "--quic") _quic +#endif + +validatePortField :: String -> Int -> Either String () +validatePortField field port + | port >= 1 && port <= 65535 = Right () + | otherwise = Left $ "invalid " <> field <> ": " <> show port <> " (expected 1..65535)" + +startupOrder :: [StartupStep] +startupOrder = + [ InitializeLogger + , LogStartup + , ReadCertificates + , CreateTlsSessionManager + , BuildSettingsAndRunner + , LoadProxyAuth + , CreateHttpManager + , BuildProxyApplication + , LogRuntimeConfig + , StartRunner + ] + +runProxyServer + :: Config + -> Logger + -> Settings + -> TLS.SessionManager + -> [(String, TLS.Credential)] + -> Application + -> IO () +runProxyServer conf@Config{..} logger settings sessionManager certs app = do + logger INFO $ "bind to TCP port " <> toLogStr (fromMaybe "[::]" _bind) <> ":" <> toLogStr _port + case _doh of + Nothing -> runner app + Just doh -> createResolver doh (\resolver -> runner (dnsOverHTTPS resolver app)) + where + runner = case (selectRunnerPlan conf certs, defaultCertificate certs) of + (PlainWarpRunner, _) -> runSettings settings + (TlsWarpRunner, Just defaultCert) -> + runTLS (buildTlsSettings sessionManager certs defaultCert) settings +#ifdef QUIC_ENABLED + (QuicAndTlsRunner qport, Just defaultCert) -> + runQuicAndTls + logger + _bind + settings + (buildTlsSettings sessionManager certs defaultCert) + lookupSNICredentials' + sessionManager + defaultCert + qport +#else + (QuicAndTlsRunner _, Just defaultCert) -> + runTLS (buildTlsSettings sessionManager certs defaultCert) settings +#endif + (_, Nothing) -> runSettings settings +#ifdef QUIC_ENABLED + lookupSNICredentials' host = lookupSNICredentials host certs +#endif + +buildWarpRuntimePlan :: Config -> WarpRuntimePlan +buildWarpRuntimePlan Config{..} = WarpRuntimePlan + { runtimeBindHost = fromMaybe "*6" _bind + , runtimePort = _port + , runtimeServerName = _name + , runtimeNoParsePath = True + } + +buildWarpSettings :: Config -> Logger -> Maybe (IO ()) -> Settings +buildWarpSettings config logger beforeMainLoop = + applyBeforeMainLoop $ + setHost (fromString (runtimeBindHost plan)) $ + setPort (runtimePort plan) $ + setLogger (warpAccessLogger logger) $ + setOnException (runtimeExceptionHandler logger (_loglevel config)) $ + setNoParsePath (runtimeNoParsePath plan) $ + setServerName (runtimeServerName plan) defaultSettings + where + plan = buildWarpRuntimePlan config + applyBeforeMainLoop = maybe id setBeforeMainLoop beforeMainLoop + +runtimeExceptionHandler :: Logger -> LogLevel -> Maybe Request -> SomeException -> IO () +runtimeExceptionHandler logger logLevel req ex = + case runtimeExceptionToLog logLevel ex of + Nothing -> return () + Just ex' -> + logger DEBUG $ "exception: " <> toLogStr (displayException ex') <> + maybe "" (\req' -> " from: " <> logRequest req') req + +warpAccessLogger :: Logger -> Request -> HT.Status -> Maybe Integer -> IO () +warpAccessLogger logger req status _ + | shouldSuppressAccessLog req = return () + | otherwise = + logger TRACE $ "(" <> toLogStr (HT.statusCode status) <> ") " <> logRequest req + +shouldSuppressAccessLog :: Request -> Bool +shouldSuppressAccessLog req = rawPathInfo req == "/.hprox/health" + +shouldIgnoreRuntimeException :: LogLevel -> SomeException -> Bool +shouldIgnoreRuntimeException logLevel ex = isNothing (runtimeExceptionToLog logLevel ex) + +runtimeExceptionToLog :: LogLevel -> SomeException -> Maybe SomeException +runtimeExceptionToLog logLevel ex + | logLevel > DEBUG = Nothing + | not (defaultShouldDisplayException ex) = Nothing + | Just ioe <- fromException ex + , ioeGetErrorType ioe == EOF = Nothing + | Just (H2.BadThingHappen ex') <- fromException ex = runtimeExceptionToLog logLevel ex' + | Just (_ :: H2.HTTP2Error) <- fromException ex = Nothing +#ifdef QUIC_ENABLED + | Just (Q.BadThingHappen ex') <- fromException ex = runtimeExceptionToLog logLevel ex' + | Just (_ :: Q.QUICException) <- fromException ex = Nothing +#endif + | Just (_ :: WarpTLSException) <- fromException ex = Nothing + | Just ConnectionClosedByPeer <- fromException ex = Nothing + | otherwise = Just ex + +loadTlsCredentials :: [(String, CertFile)] -> IO [(String, TLS.Credential)] +loadTlsCredentials certFiles = mapM readTlsCredential certFiles + where + readTlsCredential (name, CertFile cert key) = do + loadedCredential <- try (TLS.credentialLoadX509 cert key) + case loadedCredential of + Left err -> failWithContext name cert key $ displayException (err :: IOException) + Right (Left err) -> failWithContext name cert key err + Right (Right credential) -> return (name, credential) + + failWithContext name cert key err = + ioError $ userError $ + "failed to load TLS credential for " ++ show name ++ + " (certificate: " ++ cert ++ ", key: " ++ key ++ "): " ++ err + +buildTlsSettings :: TLS.SessionManager -> [(String, TLS.Credential)] -> TLS.Credential -> TLSSettings +buildTlsSettings sessionManager certs defaultCert = defaultTlsSettings + { tlsServerHooks = def { TLS.onServerNameIndication = lookupSNICredentials' } + , tlsCredentials = Just (TLS.Credentials [defaultCert]) + , onInsecure = AllowInsecure + , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] + , tlsSessionManager = Just sessionManager + } + where + lookupSNICredentials' host = lookupSNICredentials host certs + +lookupSNICredentials :: Maybe String -> [(String, TLS.Credential)] -> IO TLS.Credentials +lookupSNICredentials host certs = + either fail (return . TLS.Credentials . (: [])) (lookupSNIHost host certs) + +defaultCertificate :: [(String, a)] -> Maybe a +defaultCertificate [] = Nothing +defaultCertificate ((_, cert) : _) = Just cert + +lookupSNIHost :: Maybe String -> [(String, a)] -> Either String a +lookupSNIHost Nothing _ = Left "SNI: unspecified" +lookupSNIHost (Just host) certs = go certs + where + go [] = Left $ "SNI: unknown hostname (" ++ show host ++ ")" + go ((pattern, value) : rest) + | sniPatternMatches host pattern = Right value + | otherwise = go rest + +sniPatternMatches :: String -> String -> Bool +sniPatternMatches host pattern = case map asciiLower pattern of + '*' : '.' : suffix -> singleLabelWildcardMatches (map asciiLower host) suffix + exact -> map asciiLower host == exact + +singleLabelWildcardMatches :: String -> String -> Bool +singleLabelWildcardMatches host suffix = + case break (== '.') host of + ([], _) -> False + (label, '.' : rest) -> not (null label) && rest == suffix + _ -> False + +asciiLower :: Char -> Char +asciiLower char + | char >= 'A' && char <= 'Z' = toEnum (fromEnum char + 32) + | otherwise = char diff --git a/src/Network/HProx/Util.hs b/src/Network/HProx/Util.hs --- a/src/Network/HProx/Util.hs +++ b/src/Network/HProx/Util.hs @@ -1,11 +1,13 @@ -- SPDX-License-Identifier: Apache-2.0 -- --- Copyright (C) 2023 Bin Jin. All Rights Reserved. +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. module Network.HProx.Util ( Password(..) + , PasswordHashError(..) , PasswordSalted(..) , hashPasswordWithRandomSalt + , hashPasswordWithSalt , parseHostPort , parseHostPortWithDefault , passwordReader @@ -15,6 +17,7 @@ , verifyPassword ) where +import Control.Exception (Exception, throwIO) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy qualified as LBS @@ -32,36 +35,47 @@ data Password = PlainText !BS.ByteString | Salted !BS.ByteString !BS.ByteString - deriving (Show, Eq) + deriving (Show, Eq) +data PasswordHashError = PasswordHashError !String + deriving (Show, Eq) + +instance Exception PasswordHashError + data PasswordSalted = PasswordSalted !BS.ByteString !BS.ByteString - deriving (Show, Eq) + deriving (Show, Eq) splitBy :: Eq a => a -> [a] -> NonEmpty [a] splitBy _ [] = NE.singleton [] splitBy c (x:xs) - | c == x = [] <| splitBy c xs - | otherwise = let y :| ys = splitBy c xs in (x:y) :| ys + | c == x = [] <| splitBy c xs + | otherwise = let y :| ys = splitBy c xs in (x:y) :| ys passwordReader :: BS.ByteString -> Maybe (BS.ByteString, Password) passwordReader line = case BS8.split ':' line of [user, pass] -> Just (user, PlainText pass) [user, salt, hashed] -> case (Base64.decode salt, Base64.decode hashed) of - (Right salt', Right hashed') -> Just (user, Salted salt' hashed') - _otherwise -> Nothing + (Right salt', Right hashed') -> Just (user, Salted salt' hashed') + _otherwise -> Nothing _otherwise -> Nothing passwordWriter :: BS.ByteString -> PasswordSalted -> BS.ByteString passwordWriter user (PasswordSalted salt hash) = - BS.concat [user , ":" , Base64.encode salt , ":" , Base64.encode hash] + BS.concat [user, ":", Base64.encode salt, ":", Base64.encode hash] +hashPasswordWithSalt :: BS.ByteString -> Password -> Either PasswordHashError PasswordSalted +hashPasswordWithSalt salt (PlainText pass) = + case Argon2.hash Argon2.defaultOptions pass salt 48 of + CryptoFailed err -> Left (PasswordHashError $ "unable to hash password with salt: " ++ show err) + CryptoPassed h -> Right (PasswordSalted salt h) +hashPasswordWithSalt _ (Salted salt h) = Right (PasswordSalted salt h) + hashPasswordWithRandomSalt :: Password -> IO PasswordSalted -hashPasswordWithRandomSalt (PlainText pass) = do +hashPasswordWithRandomSalt password@(PlainText _) = do salt <- getRandomBytes 24 - case Argon2.hash Argon2.defaultOptions pass salt 48 of - CryptoFailed err -> error ("unable to hash password with salt: " ++ show err) - CryptoPassed h -> return (PasswordSalted salt h) -hashPasswordWithRandomSalt (Salted salt h) = return (PasswordSalted salt h) + either throwIO return (hashPasswordWithSalt salt password) +hashPasswordWithRandomSalt password@(Salted _ _) = + either throwIO return (hashPasswordWithSalt "" password) verifyPassword :: PasswordSalted -> BS8.ByteString -> Bool verifyPassword (PasswordSalted salt hashed) pass = @@ -72,7 +86,7 @@ parseHostPort :: BS.ByteString -> Maybe (BS.ByteString, Int) parseHostPort hostPort = do lastColon <- BS8.elemIndexEnd ':' hostPort - port <- BS8.readInt (BS.drop (lastColon+1) hostPort) >>= checkPort + port <- BS8.readInt (BS.drop (lastColon + 1) hostPort) >>= checkPort return (BS.take lastColon hostPort, port) where checkPort (p, bs) @@ -84,4 +98,5 @@ fromMaybe (hostPort, defaultPort) $ parseHostPort hostPort responseKnownLength :: Status -> ResponseHeaders -> LBS.ByteString -> Response -responseKnownLength status headers bs = responseLBS status (headers ++ [("Content-Length", BS8.pack $ show (LBS.length bs))]) bs +responseKnownLength status headers bs = + responseLBS status (headers ++ [("Content-Length", BS8.pack $ show (LBS.length bs))]) bs diff --git a/test/Network/HProx/AuthSpec.hs b/test/Network/HProx/AuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/AuthSpec.hs @@ -0,0 +1,168 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.AuthSpec + ( spec + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (cancel, withAsync) +import Control.Exception (SomeException, bracket, finally, try) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.IORef +import Data.Maybe (mapMaybe) +import Network.HTTP.Types qualified as HT +import Network.Socket +import Network.Socket.ByteString qualified as SocketBS +import Network.Wai (Application, responseLBS) +import System.Directory (removeFile) +import System.IO (hClose, openTempFile) +import System.Log.FastLogger qualified as FL + +import Network.HProx +import Network.HProx.Auth +import Network.HProx.Util + +import Test.Hspec + +spec :: Spec +spec = + describe "auth file handling" $ do + it "does not require proxy auth when no auth file is configured" $ + withHProx Nothing $ \port -> do + response <- rawHttpRequest port $ BS8.concat + [ "GET http://127.0.0.1:" + , BS8.pack (show port) + , "/.hprox/health HTTP/1.1\r\nHost: 127.0.0.1:" + , BS8.pack (show port) + , "\r\n\r\n" + ] + responseStatus response `shouldBe` HT.status200 + + it "hashes plaintext entries, ignores invalid lines, and rewrites salted entries" $ + withTempAuthFile "alice:secret\ninvalid-line\nbob:too:many:fields\n" $ \path -> do + withHProx (Just path) $ \_port -> do + rewritten <- BS8.lines <$> BS.readFile path + case rewritten of + [line] -> case passwordReader line of + Just ("alice", Salted salt hash) -> do + line `shouldBe` passwordWriter "alice" (PasswordSalted salt hash) + verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True + verifyPassword (PasswordSalted salt hash) "wrong" `shouldBe` False + parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed + lines' -> expectationFailure $ "unexpected rewritten auth file line count: " <> show (length lines') + + it "keeps an already salted file unchanged" $ do + salted <- hashPasswordWithRandomSalt (PlainText "secret") + let line = passwordWriter "alice" salted + original = line <> "\n" + withTempAuthFile original $ \path -> do + withHProx (Just path) $ \_port -> do + rewritten <- BS.readFile path + rewritten `shouldBe` original + + it "normalizes CRLF plaintext entries before hashing and verification" $ + withTempAuthFile "alice:secret\r\n" $ \path -> do + Just verifier <- loadProxyAuth (\_ _ -> return ()) (Just path) + verifier "alice:secret" `shouldBe` True + verifier "alice:secret\r" `shouldBe` False + [rewritten] <- BS8.lines <$> BS.readFile path + case passwordReader rewritten of + Just ("alice", Salted salt hash) -> + verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True + parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed + + it "redacts malformed auth-file lines in logs" $ + withTempAuthFile "alice:secret:hash:extra\nraw-secret-without-separators\n" $ \path -> do + logs <- newIORef [] + _ <- loadProxyAuth (\_ msg -> modifyIORef' logs (BS8.append (FL.fromLogStr msg) "\n" :)) (Just path) + renderedLogs <- BS.concat . reverse <$> readIORef logs + renderedLogs `shouldSatisfy` BS8.isInfixOf "line 1" + renderedLogs `shouldSatisfy` BS8.isInfixOf "alice" + renderedLogs `shouldSatisfy` BS8.isInfixOf "line 2" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "hash" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "extra" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "raw-secret-without-separators" + +withTempAuthFile :: BS.ByteString -> (FilePath -> IO a) -> IO a +withTempAuthFile contents action = bracket create cleanup (action . fst) + where + create = do + (path, handle) <- openTempFile "." "hprox-auth-test" + BS.hPut handle contents + hClose handle + return (path, ()) + + cleanup (path, ()) = removeFile path + +withHProx :: Maybe FilePath -> (Int -> IO a) -> IO a +withHProx authPath action = do + port <- getFreePort + let conf = defaultConfig + { _bind = Just "127.0.0.1" + , _port = port + , _auth = authPath + , _log = "none" + , _loglevel = NONE + } + withAsync (run fallback conf) $ \server -> do + waitForHealth port + action port `finally` cancel server + +fallback :: Application +fallback _req respond = respond $ responseLBS HT.status200 [] "fallback" + +getFreePort :: IO Int +getFreePort = bracket open close socketPortInt + where + open = do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 (tupleToHostAddress (127, 0, 0, 1))) + return sock + + socketPortInt sock = fromIntegral <$> socketPort sock + +waitForHealth :: Int -> IO () +waitForHealth port = go (200 :: Int) + where + go 0 = expectationFailure "hprox server did not become ready" + go attempts = do + response <- try (rawHttpRequest port $ BS8.concat + [ "GET /.hprox/health HTTP/1.1\r\nHost: 127.0.0.1:" + , BS8.pack (show port) + , "\r\n\r\n" + ]) :: IO (Either SomeException BS.ByteString) + case response of + Right bytes | responseStatus bytes == HT.status200 -> return () + _ -> threadDelay 10000 >> go (attempts - 1) + +rawHttpRequest :: Int -> BS.ByteString -> IO BS.ByteString +rawHttpRequest port request = bracket open close sendReceive + where + open = do + sock <- socket AF_INET Stream defaultProtocol + connect sock (SockAddrInet (fromIntegral port) (tupleToHostAddress (127, 0, 0, 1))) + return sock + + sendReceive sock = do + SocketBS.sendAll sock request + SocketBS.recv sock 4096 + +responseStatus :: BS.ByteString -> HT.Status +responseStatus response = + case mapMaybe parseStatusLine (take 1 $ BS8.lines response) of + status : _ -> status + [] -> HT.mkStatus 0 "invalid response" + +parseStatusLine :: BS.ByteString -> Maybe HT.Status +parseStatusLine line = case BS8.words line of + _version : codeBytes : reasonWords -> do + (code, rest) <- BS8.readInt codeBytes + if BS.null rest + then Just $ HT.mkStatus code $ BS8.unwords reasonWords + else Nothing + _ -> Nothing diff --git a/test/Network/HProx/ConfigSpec.hs b/test/Network/HProx/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/ConfigSpec.hs @@ -0,0 +1,185 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. +{-# LANGUAGE CPP #-} + +module Network.HProx.ConfigSpec + ( spec + ) where + +import Control.Exception (try) +import System.Environment (withArgs) +import System.Exit (ExitCode(..)) + +import Network.HProx + +import Test.Hspec + +spec :: Spec +spec = do + describe "defaultConfig" $ + it "matches the documented default runtime values" $ + assertDefaultConfig defaultConfig + + describe "getConfig" $ do + it "uses default configuration when no options are supplied" $ do + conf <- parseConfig [] + assertDefaultConfig conf + + it "parses long-form options into the current Config fields" $ do + conf <- parseConfig longOptionArgs + _bind conf `shouldBe` Just "127.0.0.1" + _port conf `shouldBe` 8080 + case _ssl conf of + [(host, cert)] -> do + host `shouldBe` "example.com" + certfile cert `shouldBe` "cert.pem" + keyfile cert `shouldBe` "key.pem" + value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) + _auth conf `shouldBe` Just "userpass.txt" + _ws conf `shouldBe` Just "ws.example:443" + _rev conf `shouldBe` [(Just "example.com", "/api/", "upstream:80")] + _doh conf `shouldBe` Just "1.1.1.1:53" + _hide conf `shouldBe` True + _naive conf `shouldBe` True + _name conf `shouldBe` "custom" + _acme conf `shouldBe` Just "thumbprint" + _log conf `shouldBe` "stderr" + _loglevel conf `shouldBe` DEBUG +#ifdef OS_UNIX + _user conf `shouldBe` Just "nobody" + _group conf `shouldBe` Just "nogroup" +#endif +#ifdef QUIC_ENABLED + _quic conf `shouldBe` Just 8443 +#endif + + it "parses current short aliases" $ do + conf <- parseConfig shortOptionArgs + _bind conf `shouldBe` Just "0.0.0.0" + _port conf `shouldBe` 8081 + case _ssl conf of + [(host, cert)] -> do + host `shouldBe` "short.example" + certfile cert `shouldBe` "short-cert.pem" + keyfile cert `shouldBe` "short-key.pem" + value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) + _auth conf `shouldBe` Just "short-userpass.txt" +#ifdef OS_UNIX + _user conf `shouldBe` Just "daemon" + _group conf `shouldBe` Just "daemon" +#endif +#ifdef QUIC_ENABLED + _quic conf `shouldBe` Just 9443 +#endif + + it "parses reverse proxy option forms" $ do + remoteOnly <- parseConfig ["--rev", "backend:80"] + prefixOnly <- parseConfig ["--rev", "/api/backend:80"] + domainAndPrefix <- parseConfig ["--rev", "//example.com/api/backend:80"] + _rev remoteOnly `shouldBe` [(Nothing, "/", "backend:80")] + _rev prefixOnly `shouldBe` [(Nothing, "/api/", "backend:80")] + _rev domainAndPrefix `shouldBe` [(Just "example.com", "/api/", "backend:80")] + + it "accepts only bounded listener ports" $ do + low <- parseConfig ["--port", "1"] + high <- parseConfig ["--port", "65535"] + _port low `shouldBe` 1 + _port high `shouldBe` 65535 + shouldExitWith ["--port", "0"] (ExitFailure 1) + shouldExitWith ["--port", "65536"] (ExitFailure 1) + shouldExitWith ["--port", "-1"] (ExitFailure 1) + +#ifdef QUIC_ENABLED + it "accepts only bounded QUIC ports" $ do + low <- parseConfig ["--quic", "1"] + high <- parseConfig ["--quic", "65535"] + _quic low `shouldBe` Just 1 + _quic high `shouldBe` Just 65535 + shouldExitWith ["--quic", "0"] (ExitFailure 1) + shouldExitWith ["--quic", "65536"] (ExitFailure 1) + shouldExitWith ["--quic", "-1"] (ExitFailure 1) +#endif + it "rejects invalid TLS, reverse proxy, and log-level options" $ do + shouldExitWith ["--tls", "example.com:cert-only"] (ExitFailure 1) + shouldExitWith ["--rev", "//example.com"] (ExitFailure 1) + shouldExitWith ["--rev", "/api/"] (ExitFailure 1) + shouldExitWith ["--rev", "/"] (ExitFailure 1) + shouldExitWith ["--rev", "///api/backend:80"] (ExitFailure 1) + shouldExitWith ["--loglevel", "verbose"] (ExitFailure 1) + + it "exercises help and version parser exits" $ do + shouldExitWith ["--help"] ExitSuccess + shouldExitWith ["--version"] ExitSuccess + +assertDefaultConfig :: Config -> Expectation +assertDefaultConfig conf = do + _bind conf `shouldBe` Nothing + _port conf `shouldBe` 3000 + length (_ssl conf) `shouldBe` 0 + _auth conf `shouldBe` Nothing + _ws conf `shouldBe` Nothing + _rev conf `shouldBe` [] + _doh conf `shouldBe` Nothing + _hide conf `shouldBe` False + _naive conf `shouldBe` False + _name conf `shouldBe` "hprox" + _acme conf `shouldBe` Nothing + _log conf `shouldBe` "stdout" + _loglevel conf `shouldBe` INFO +#ifdef OS_UNIX + _user conf `shouldBe` Nothing + _group conf `shouldBe` Nothing +#endif +#ifdef QUIC_ENABLED + _quic conf `shouldBe` Nothing +#endif + +parseConfig :: [String] -> IO Config +parseConfig args = withArgs args getConfig + +shouldExitWith :: [String] -> ExitCode -> Expectation +shouldExitWith args expected = do + result <- try (parseConfig args) + case result of + Left exitCode -> exitCode `shouldBe` expected + Right _ -> expectationFailure "expected parser to exit" + +longOptionArgs :: [String] +longOptionArgs = + [ "--bind", "127.0.0.1" + , "--port", "8080" + , "--tls", "example.com:cert.pem:key.pem" + , "--auth", "userpass.txt" + , "--ws", "ws.example:443" + , "--rev", "//example.com/api/upstream:80" + , "--doh", "1.1.1.1:53" + , "--hide" + , "--naive" + , "--name", "custom" + , "--acme", "thumbprint" + , "--log", "stderr" + , "--loglevel", "debug" +#ifdef OS_UNIX + , "--user", "nobody" + , "--group", "nogroup" +#endif +#ifdef QUIC_ENABLED + , "--quic", "8443" +#endif + ] + +shortOptionArgs :: [String] +shortOptionArgs = + [ "-b", "0.0.0.0" + , "-p", "8081" + , "-s", "short.example:short-cert.pem:short-key.pem" + , "-a", "short-userpass.txt" +#ifdef OS_UNIX + , "-u", "daemon" + , "-g", "daemon" +#endif +#ifdef QUIC_ENABLED + , "-q", "9443" +#endif + ] diff --git a/test/Network/HProx/DoHSpec.hs b/test/Network/HProx/DoHSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/DoHSpec.hs @@ -0,0 +1,174 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.DoHSpec + ( spec + ) where + +import Data.ByteString qualified as BS +import Data.ByteString.Base64.URL qualified as Base64 +import Data.ByteString.Lazy qualified as LBS +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Network.DNS qualified as DNS +import Network.HTTP.Types qualified as HT +import Network.Wai +import Network.Wai.Test + +import Network.HProx.DoH + +import Test.Hspec + +spec :: Spec +spec = + describe "dnsOverHTTPS" $ do + it "handles secure GET /dns-query requests with unpadded URL-safe base64" $ do + response <- runDoHRequest getDnsRequest + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier + + it "handles secure POST /dns-query requests with application/dns-message bodies" $ do + response <- runDoHRequest postDnsRequest + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier + + it "returns the current text 400 response for malformed requests" $ do + response <- runDoHRequest getDnsRequest { queryString = [("dns", Just "not-base64!")] } + simpleStatus response `shouldBe` HT.status400 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" + simpleBody response `shouldBe` "invalid dns-over-https request" + + it "rejects POST bodies beyond the current 4096-byte boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = KnownLength 4097 } (LBS.replicate 4097 0) + simpleStatus response `shouldBe` HT.status400 + simpleBody response `shouldBe` "invalid dns-over-https request" + + it "accepts chunked POST bodies within the size boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.fromStrict encodedQuery) + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier + + it "rejects chunked POST bodies beyond the size boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.replicate 4097 0) + simpleStatus response `shouldBe` HT.status400 + simpleBody response `shouldBe` "invalid dns-over-https request" + + it "returns 502 when the DNS resolver fails" $ do + response <- runDoHRequestWithApplication resolverFailureApplication getDnsRequest "" + simpleStatus response `shouldBe` HT.status502 + simpleBody response `shouldBe` "dns resolver failure" + + it "parses valid POST bodies split across multiple chunks" $ do + chunks <- newIORef [BS.take 5 encodedQuery, BS.drop 5 encodedQuery] + parsed <- parseDoHRequestWithBodyReader (popChunk chunks) postDnsRequest + parsed `shouldBe` Just DoHRequest + { dohIdentifier = requestIdentifier + , dohQuestion = decodedQuestion + } + + it "falls through outside secure /dns-query requests" $ do + insecureResponse <- runDoHRequest getDnsRequest { isSecure = False } + otherPathResponse <- runDoHRequest getDnsRequest { pathInfo = ["other"], rawPathInfo = "/other" } + simpleStatus insecureResponse `shouldBe` fallbackStatus + simpleBody insecureResponse `shouldBe` fallbackBody + simpleStatus otherPathResponse `shouldBe` fallbackStatus + simpleBody otherPathResponse `shouldBe` fallbackBody + +runDoHRequest :: Request -> IO SResponse +runDoHRequest req = runDoHRequestWithBody req requestBody + where + requestBody + | requestMethod req == "POST" = LBS.fromStrict encodedQuery + | otherwise = "" + +runDoHRequestWithBody :: Request -> LBS.ByteString -> IO SResponse +runDoHRequestWithBody req body = runSession (srequest $ SRequest req body) testApplication + +runDoHRequestWithApplication :: Application -> Request -> LBS.ByteString -> IO SResponse +runDoHRequestWithApplication app req body = runSession (srequest $ SRequest req body) app + +popChunk :: IORef [BS.ByteString] -> IO BS.ByteString +popChunk chunksRef = do + chunks <- readIORef chunksRef + case chunks of + [] -> return "" + chunk : rest -> do + writeIORef chunksRef rest + return chunk + +testApplication :: Application +testApplication = dnsOverHTTPSWithLookup lookupResponse fallback + +lookupResponse :: DNS.Question -> IO (Either DNS.DNSError DNS.DNSMessage) +lookupResponse lookupQuestion = return $ Right (DNS.makeResponse responseIdentifier lookupQuestion []) + +resolverFailureApplication :: Application +resolverFailureApplication = dnsOverHTTPSWithLookup lookupFailure fallback + +lookupFailure :: DNS.Question -> IO (Either DNS.DNSError DNS.DNSMessage) +lookupFailure _ = return $ Left (error "unused resolver error") + +fallback :: Application +fallback _req respond = respond $ responseLBS fallbackStatus [("Content-Type", "text/plain")] fallbackBody + +fallbackStatus :: HT.Status +fallbackStatus = HT.mkStatus 418 "fallback" + +fallbackBody :: LBS.ByteString +fallbackBody = "fallback" + +getDnsRequest :: Request +getDnsRequest = secureDnsRequest + { requestMethod = "GET" + , queryString = [("dns", Just (Base64.encodeUnpadded encodedQuery))] + } + +postDnsRequest :: Request +postDnsRequest = secureDnsRequest + { requestMethod = "POST" + , requestBodyLength = KnownLength (fromIntegral $ LBS.length requestBody) + } + where + requestBody = LBS.fromStrict encodedQuery + +secureDnsRequest :: Request +secureDnsRequest = defaultRequest + { isSecure = True + , pathInfo = ["dns-query"] + , rawPathInfo = "/dns-query" + } + +encodedQuery :: BS.ByteString +encodedQuery = DNS.encode queryMessage + +queryMessage :: DNS.DNSMessage +queryMessage = DNS.defaultQuery + { DNS.header = (DNS.header DNS.defaultQuery) { DNS.identifier = requestIdentifier } + , DNS.question = [question] + } + +question :: DNS.Question +question = DNS.Question + { DNS.qname = "example.com" + , DNS.qtype = DNS.A + } + +decodedQuestion :: DNS.Question +decodedQuestion = question { DNS.qname = "example.com." } + +requestIdentifier :: DNS.Identifier +requestIdentifier = 0x1234 + +responseIdentifier :: DNS.Identifier +responseIdentifier = 0x9999 + +decodedResponse :: SResponse -> Either DNS.DNSError DNS.DNSMessage +decodedResponse = DNS.decode . LBS.toStrict . simpleBody + +hasRequestIdentifier :: Either DNS.DNSError DNS.DNSMessage -> Bool +hasRequestIdentifier (Right DNS.DNSMessage{DNS.header = DNS.DNSHeader{DNS.identifier = ident}}) = + ident == requestIdentifier +hasRequestIdentifier _ = False diff --git a/test/Network/HProx/HeadersSpec.hs b/test/Network/HProx/HeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/HeadersSpec.hs @@ -0,0 +1,34 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.HeadersSpec + ( spec + ) where + +import Network.HProx.Headers + +import Test.Hspec + +spec :: Spec +spec = + describe "header policy helpers" $ do + it "detects proxy, forwarded, and CDN header families" $ do + isProxyHeader "Proxy-Connection" `shouldBe` True + isForwardedHeader "X-Forwarded-For" `shouldBe` True + isCDNHeader "cf-ray" `shouldBe` True + isCDNHeader cdnLoopHeader `shouldBe` True + + isForwardedHeader "Forwarded" `shouldBe` True + isForwardedHeader "forwarded-for" `shouldBe` False + it "preserves the current strip-header policy" $ do + map isProxyStripHeader ["Proxy-Connection", "X-Forwarded-Proto", "cf-ray", xRealIPHeader, xSchemeHeader] + `shouldBe` replicate 5 True + isProxyStripHeader "Authorization" `shouldBe` False + isProxyStripHeader "Forwarded" `shouldBe` True + isProxyStripHeader "X-Not-Forwarded" `shouldBe` False + + it "compares protocol header values case-insensitively" $ do + headerValueEquals "https" "HTTPS" `shouldBe` True + headerValueEquals "http" "HtTp" `shouldBe` True + headerValueEquals "http" "https" `shouldBe` False diff --git a/test/Network/HProx/MiddlewareSpec.hs b/test/Network/HProx/MiddlewareSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/MiddlewareSpec.hs @@ -0,0 +1,156 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.MiddlewareSpec + ( spec + ) where + +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Network.HTTP.Types qualified as HT +import Network.Wai +import Network.Wai.Test + +import Network.HProx.Impl + +import Test.Hspec + +spec :: Spec +spec = do + describe "healthCheckProvider" $ do + it "returns 200 okay for the health endpoint" $ do + response <- runApp healthCheckProvider (requestPath "/.hprox/health") + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` "okay" + + it "falls through outside the health endpoint" $ do + response <- runApp healthCheckProvider (requestPath "/not-health") + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody + + describe "acmeProvider" $ do + it "serves an insecure challenge when a thumbprint is configured" $ do + response <- runApp (acmeProvider testSettings) (requestPath "/.well-known/acme-challenge/token") + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` "token.thumbprint" + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" + + it "falls through for secure ACME requests" $ do + response <- runApp (acmeProvider testSettings) $ (requestPath "/.well-known/acme-challenge/token") + { isSecure = True + } + simpleStatus response `shouldBe` fallbackStatus + + it "falls through without a configured thumbprint" $ do + response <- runApp (acmeProvider testSettings { acmeThumbprint = Nothing }) (requestPath "/.well-known/acme-challenge/token") + simpleStatus response `shouldBe` fallbackStatus + + describe "pacProvider" $ do + it "uses forwarded host and lowercase https proto for the PAC response" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "https")] + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"HTTPS proxy.example:443\";" + , "}" + ] + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/x-ns-proxy-autoconfig" + + it "uses Host and preserves an explicit host port for insecure PAC responses" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaderHost = Just "proxy.example:8080" + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"PROXY proxy.example:8080\";" + , "}" + ] + + it "treats forwarded proto values case-insensitively" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "HTTPS")] + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"HTTPS proxy.example:443\";" + , "}" + ] + + it "falls through without a host" $ do + response <- runApp pacProvider (requestPath "/.hprox/config.pac") + simpleStatus response `shouldBe` fallbackStatus + + describe "forceSSL" $ do + it "redirects insecure origin-form requests with path and query to HTTPS" $ do + response <- runApp (forceSSL testSettings) $ (requestPath "/docs") + { requestHeaderHost = Just "example.com" + , rawQueryString = "?q=1" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/docs?q=1" + + it "redirects root origin-form requests to the HTTPS root" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "example.com" + , rawPathInfo = "/" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/" + + it "redirects insecure absolute-form proxy requests to the parsed HTTPS target" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "proxy.local" + , rawPathInfo = "http://target.example:8080/docs" + , rawQueryString = "?q=1" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example:8080/docs?q=1" + + it "omits default ports from absolute-form HTTPS redirect authorities" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "proxy.local" + , rawPathInfo = "http://target.example/docs" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example/docs" + + it "returns upgrade-required for insecure requests without Host" $ do + response <- runApp (forceSSL testSettings) defaultRequest + simpleStatus response `shouldBe` HT.mkStatus 426 "Upgrade Required" + lookup "Upgrade" (simpleHeaders response) `shouldBe` Just "TLS/1.0, HTTP/1.1" + + it "falls through for secure requests" $ do + response <- runApp (forceSSL testSettings) defaultRequest { isSecure = True } + simpleStatus response `shouldBe` fallbackStatus + +runApp :: Middleware -> Request -> IO SResponse +runApp middleware req = runSession (srequest $ SRequest req "") (middleware fallback) + +requestPath :: String -> Request +requestPath path = setPath defaultRequest (BS8.pack path) + +fallback :: Application +fallback _req respond = respond $ responseLBS fallbackStatus [("Content-Type", "text/plain")] fallbackBody + +fallbackStatus :: HT.Status +fallbackStatus = HT.mkStatus 418 "fallback" + +fallbackBody :: LBS8.ByteString +fallbackBody = "fallback" + +testSettings :: ProxySettings +testSettings = ProxySettings + { proxyAuth = Nothing + , passPrompt = Just "hprox" + , wsRemote = Nothing + , revRemoteMap = [] + , hideProxyAuth = False + , naivePadding = False + , acmeThumbprint = Just "thumbprint" + , logger = \_ _ -> return () + } diff --git a/test/Network/HProx/NaiveSpec.hs b/test/Network/HProx/NaiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/NaiveSpec.hs @@ -0,0 +1,46 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.NaiveSpec + ( spec + ) where + +import Data.ByteString qualified as BS +import Data.Conduit +import Data.Conduit.List qualified as CL +import Network.Wai + +import Network.HProx.Naive + +import Test.Hspec + +spec :: Spec +spec = do + describe "parseRequestForPadding" $ do + it "selects the first supported padding type from the request header" $ do + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding-Type-Request", "unknown,1,0")] + } + `shouldBe` Just Variant1 + + it "falls back to the legacy Padding header" $ do + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding", "opaque")] + } + `shouldBe` Just Variant1 + + it "rejects requests without supported padding headers" $ + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding-Type-Request", "unknown")] + } + `shouldBe` Nothing + + describe "padding conduits" $ do + it "round-trips NoPadding without changing chunks" $ do + chunks <- runConduit $ CL.sourceList ["hello", "world"] .| addPaddingConduit NoPadding .| removePaddingConduit NoPadding .| CL.consume + chunks `shouldBe` ["hello", "world"] + + it "round-trips Variant1 payloads without depending on random padding bytes" $ do + chunks <- runConduit $ CL.sourceList [BS.replicate 512 65] .| addPaddingConduit Variant1 .| removePaddingConduit Variant1 .| CL.consume + BS.concat chunks `shouldBe` BS.replicate 512 65 diff --git a/test/Network/HProx/ProxySpec.hs b/test/Network/HProx/ProxySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/ProxySpec.hs @@ -0,0 +1,389 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.ProxySpec + ( spec + ) where + +import Control.Concurrent.Async (withAsync) +import Control.Exception (AsyncException(..), SomeException, bracket, throwIO, try) +import Control.Monad (unless) +import Data.ByteString.Base64 qualified as B64 +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.IORef +import Network.HTTP.Client qualified as HC +import Network.HTTP.Types qualified as HT +import Network.HTTP.Types.Header qualified as HT +import Network.Socket +import Network.Socket.ByteString qualified as SocketBS +import Network.Wai +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Test +import System.Log.FastLogger qualified as FL + +import Network.HProx.Impl + +import Test.Hspec + +spec :: Spec +spec = do + describe "HTTP proxy auth decisions" $ do + it "challenges unauthorized HTTP proxy requests" $ do + response <- runProxyApp (httpProxy authRequiredSettings) rawProxyRequest + simpleStatus response `shouldBe` HT.status407 + lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" + + it "accepts valid Basic credentials" $ + Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do + response <- runProxyApp (httpProxy authorizedSettings) (proxyRequestForPort port basicAliceSecret) + simpleStatus response `shouldBe` HT.status200 + + it "rejects valid Basic credentials with the wrong password" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ basicCredential "alice:wrong") + simpleStatus response `shouldBe` HT.status407 + + it "rejects malformed base64 credentials even if lenient decoding would authenticate" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth "Basic !!!YWxpY2U6c2VjcmV0!!!") + simpleStatus response `shouldBe` HT.status407 + + it "rejects non-Basic credentials even when the payload is otherwise valid" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ "Bearer " <> B64.encode "alice:secret") + simpleStatus response `shouldBe` HT.status407 + + it "redacts proxy auth passwords in trace logs" $ + Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + response <- runProxyApp (httpProxy loggingSettings) (proxyRequestForPort port basicAliceSecret) + simpleStatus response `shouldBe` HT.status200 + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldSatisfy` BS8.isInfixOf "authorized request" + renderedLogs `shouldSatisfy` BS8.isInfixOf "alice:" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "alice:secret" + + it "falls back instead of challenging when hidden auth is enabled" $ do + response <- runProxyApp (httpProxy hiddenAuthSettings) rawProxyRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody + + describe "CONNECT proxy auth decisions" $ do + it "challenges unauthorized CONNECT requests" $ do + response <- runConnectApp authRequiredSettings connectRequest + simpleStatus response `shouldBe` HT.status407 + lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" + + it "falls back instead of challenging CONNECT requests when hidden auth is enabled" $ do + response <- runConnectApp hiddenAuthSettings connectRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody + + it "establishes an HTTP/1 CONNECT tunnel after upstream connection succeeds" $ + withTcpEchoServer $ \targetPort -> + Warp.testWithApplication (pure $ httpConnectProxy authorizedSettings fallback) $ \proxyPort -> do + response <- rawConnectRoundTrip proxyPort targetPort + response `shouldBe` "ping" + it "returns 502 when upstream CONNECT fails before tunnel establishment" $ do + port <- getFreePort + response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http11) + simpleStatus response `shouldBe` HT.status502 + + it "returns 502 for HTTP/2 CONNECT when upstream connection fails" $ do + port <- getFreePort + response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http20) + simpleStatus response `shouldBe` HT.status502 + + it "does not log upstream failure after an HTTP/2 tunnel response starts" $ + withTcpEchoServer $ \targetPort -> do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + tunnelRequest = connectRequestFor "127.0.0.1" targetPort HT.http20 + failAfterResponse _ = ioError (userError "client stream closed after connect") + result <- try (httpConnectProxy loggingSettings fallback tunnelRequest failAfterResponse) :: IO (Either SomeException ResponseReceived) + case result of + Left _ -> return () + Right _ -> expectationFailure "response failure was swallowed" + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" + + it "does not log upstream failure when HTTP/2 cancels before the tunnel response starts" $ do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + cancelledBeforeResponse _ _ = throwIO ThreadKilled + respondOk _ = ioError (userError "respond should not be called") + result <- try (httpConnectProxyWith cancelledBeforeResponse loggingSettings fallback (connectRequestFor "127.0.0.1" 443 HT.http20) respondOk) :: IO (Either SomeException ResponseReceived) + case result of + Left _ -> return () + Right _ -> expectationFailure "pre-response cancellation was swallowed" + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" + + describe "HTTP proxy fallback decisions" $ + it "falls through for non-proxy GET requests" $ do + response <- runProxyApp (httpProxy authRequiredSettings) defaultRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody + + describe "HTTP proxy target parsing" $ do + it "selects raw absolute-URI proxy targets with default ports" $ + selectHttpProxyTarget rawProxyRequest + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "example.com" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } + + it "preserves bracketed IPv6 proxy targets without explicit ports" $ + selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://[::1]/resource" } + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "[::1]" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } + + it "treats HTTP/2 proxy scheme values case-insensitively" $ + selectHttpProxyTarget http2ProxyRequest { requestHeaders = [("X-Scheme", "HTTP")] } + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "example.com" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } + + it "rejects malformed explicit ports in raw absolute-URI requests" $ + selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://example.com:not-a-port/resource" } + `shouldBe` Nothing + + it "rejects malformed explicit ports in Host-header proxy requests" $ + selectHttpProxyTarget hostHeaderProxyRequest { requestHeaderHost = Just "example.com:not-a-port" } + `shouldBe` Nothing + + it "rejects HTTP/2 proxy requests without a Host header" $ + selectHttpProxyTarget http2ProxyRequest { requestHeaderHost = Nothing } + `shouldBe` Nothing + + it "renders HTTP proxy authorities without the default port" $ do + renderHttpProxyAuthority (HttpProxyTarget "example.com" 80 "/") + `shouldBe` "example.com" + renderHttpProxyAuthority (HttpProxyTarget "example.com" 443 "/") + `shouldBe` "example.com:443" + renderHttpProxyAuthority (HttpProxyTarget "example.com" 8080 "/") + `shouldBe` "example.com:8080" + + describe "HTTP proxy upstream requests" $ + it "uses absolute URI authority for Host and strips proxy boundary headers" $ + Warp.testWithApplication (pure observeProxyRequestApp) $ \port -> do + let authority = "127.0.0.1:" <> BS8.pack (show port) + responseBody = LBS8.lines . simpleBody + proxiedReq = defaultRequest + { requestMethod = "GET" + , rawPathInfo = "http://" <> authority <> "/resource" + , requestHeaderHost = Just "evil.example" + , requestHeaders = + [ (HT.hHost, "evil.example") + , (HT.hProxyAuthorization, "Basic " <> B64.encode "alice:secret") + , ("Forwarded", "for=203.0.113.7") + , ("X-Forwarded-For", "203.0.113.7") + , ("Proxy-Connection", "keep-alive") + , ("cf-ray", "abc123") + , ("X-Real-IP", "203.0.113.7") + , ("User-Agent", "hprox-test") + ] + } + response <- runProxyApp (httpProxy authorizedSettings) proxiedReq + simpleStatus response `shouldBe` HT.status200 + responseBody response + `shouldBe` [ LBS.fromStrict authority + , LBS.fromStrict authority + , "False" + , "False" + , "False" + , "False" + , "False" + , "True" + ] +runProxyApp :: (HC.Manager -> Middleware) -> Request -> IO SResponse + +runProxyApp middleware req = do + manager <- HC.newManager HC.defaultManagerSettings + runSession (srequest $ SRequest req "") (middleware manager fallback) + +runConnectApp :: ProxySettings -> Request -> IO SResponse +runConnectApp pset req = runSession (srequest $ SRequest req "") (httpConnectProxy pset fallback) + +rawProxyRequest :: Request +rawProxyRequest = defaultRequest + { requestMethod = "GET" + , rawPathInfo = "http://example.com/resource" + , requestHeaderHost = Just "example.com" + } + +rawProxyRequestWithAuth :: BS8.ByteString -> Request +rawProxyRequestWithAuth auth = rawProxyRequest + { requestHeaders = [(HT.hProxyAuthorization, auth)] + } + +proxyRequestForPort :: Int -> BS8.ByteString -> Request +proxyRequestForPort port auth = + let authority = "127.0.0.1:" <> BS8.pack (show port) + in (rawProxyRequestWithAuth auth) + { rawPathInfo = "http://" <> authority <> "/resource" + , requestHeaderHost = Just authority + } + +basicAliceSecret :: BS8.ByteString +basicAliceSecret = basicCredential "alice:secret" + +basicCredential :: BS8.ByteString -> BS8.ByteString +basicCredential credential = "Basic " <> B64.encode credential + +hostHeaderProxyRequest :: Request +hostHeaderProxyRequest = defaultRequest + { requestMethod = "GET" + , rawPathInfo = "/resource" + , requestHeaderHost = Just "example.com" + , requestHeaders = [("Proxy-Connection", "keep-alive")] + } + +http2ProxyRequest :: Request +http2ProxyRequest = defaultRequest + { requestMethod = "GET" + , rawPathInfo = "/resource" + , requestHeaderHost = Just "example.com" + , requestHeaders = [("X-Scheme", "http")] + , httpVersion = HT.http20 + , isSecure = True + } + +connectRequest :: Request +connectRequest = defaultRequest + { requestMethod = "CONNECT" + , rawPathInfo = "example.com:443" + , requestHeaderHost = Just "example.com:443" + } + +connectRequestFor :: BS8.ByteString -> Int -> HT.HttpVersion -> Request +connectRequestFor host port version = + let authority = host <> ":" <> BS8.pack (show port) + in connectRequest + { rawPathInfo = authority + , requestHeaderHost = Just authority + , requestHeaders = [(HT.hProxyAuthorization, basicAliceSecret)] + , httpVersion = version + } + +getFreePort :: IO Int +getFreePort = bracket open close socketPortInt + where + open = do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 loopbackAddress) + return sock + + socketPortInt sock = fromIntegral <$> socketPort sock + +withTcpEchoServer :: (Int -> IO a) -> IO a +withTcpEchoServer action = bracket open close run + where + open = do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 loopbackAddress) + listen sock 1 + return sock + + run sock = + withAsync (bracket (fst <$> accept sock) close echoLoop) $ \_ -> + action . fromIntegral =<< socketPort sock + + echoLoop conn = do + bs <- SocketBS.recv conn 4096 + unless (BS8.null bs) $ do + SocketBS.sendAll conn bs + echoLoop conn + +rawConnectRoundTrip :: Int -> Int -> IO BS8.ByteString +rawConnectRoundTrip proxyPort targetPort = bracket open close $ \sock -> do + SocketBS.sendAll sock $ BS8.concat + [ "CONNECT 127.0.0.1:" + , BS8.pack (show targetPort) + , " HTTP/1.1\r\nHost: 127.0.0.1:" + , BS8.pack (show targetPort) + , "\r\nProxy-Authorization: " + , basicAliceSecret + , "\r\n\r\n" + ] + response <- SocketBS.recv sock 4096 + response `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200" + SocketBS.sendAll sock "ping" + SocketBS.recv sock 4096 + where + open = do + sock <- socket AF_INET Stream defaultProtocol + connect sock (SockAddrInet (fromIntegral proxyPort) loopbackAddress) + return sock + +loopbackAddress :: HostAddress +loopbackAddress = tupleToHostAddress (127, 0, 0, 1) + +fallback :: Application +fallback _req respond = respond $ responseLBS fallbackStatus [("Content-Type", "text/plain")] fallbackBody + +fallbackStatus :: HT.Status +fallbackStatus = HT.mkStatus 418 "fallback" + +fallbackBody :: LBS.ByteString +fallbackBody = "fallback" + +authRequiredSettings :: ProxySettings +authRequiredSettings = baseSettings + { proxyAuth = Just (const False) + } + +hiddenAuthSettings :: ProxySettings +hiddenAuthSettings = authRequiredSettings + { hideProxyAuth = True + } + +authorizedSettings :: ProxySettings +authorizedSettings = baseSettings + { proxyAuth = Just (== "alice:secret") + } + +baseSettings :: ProxySettings +baseSettings = ProxySettings + { proxyAuth = Nothing + , passPrompt = Just "hprox" + , wsRemote = Nothing + , revRemoteMap = [] + , hideProxyAuth = False + , naivePadding = False + , acmeThumbprint = Nothing + , logger = \_ _ -> return () + } + +observeProxyRequestApp :: Application +observeProxyRequestApp req respond = respond $ responseLBS + HT.status200 + [("Content-Type", "text/plain")] + (LBS8.unlines + [ LBS.fromStrict $ maybe "" id $ requestHeaderHost req + , LBS.fromStrict $ maybe "" id $ lookup HT.hHost (requestHeaders req) + , LBS8.pack $ show $ hasHeader HT.hProxyAuthorization + , LBS8.pack $ show $ hasHeader "Forwarded" + , LBS8.pack $ show $ hasHeader "X-Forwarded-For" + , LBS8.pack $ show $ hasHeader "Proxy-Connection" + , LBS8.pack $ show $ hasHeader "cf-ray" + , LBS8.pack $ show $ hasHeader "User-Agent" + ]) + where + hasHeader name = lookup name (requestHeaders req) /= Nothing diff --git a/test/Network/HProx/PureSpec.hs b/test/Network/HProx/PureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/PureSpec.hs @@ -0,0 +1,81 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.PureSpec + ( spec + ) where + +import Data.List.NonEmpty qualified as NE + +import Network.HProx.Log +import Network.HProx.Util + +import Test.Hspec + +spec :: Spec +spec = do + describe "parseHostPort" $ do + it "parses a valid host and port" $ + parseHostPort "example.com:443" `shouldBe` Just ("example.com", 443) + + it "uses the last colon as the port separator" $ + parseHostPort "example.com:proxy:8080" `shouldBe` Just ("example.com:proxy", 8080) + + it "accepts an empty host portion" $ + parseHostPort ":123" `shouldBe` Just ("", 123) + + it "rejects missing, invalid, trailing, and out-of-range ports" $ + map parseHostPort ["example.com", "example.com:http", "example.com:80x", "example.com:0", "example.com:65536", "example.com:"] + `shouldBe` replicate 6 Nothing + + describe "parseHostPortWithDefault" $ do + it "returns an explicit port when parsing succeeds" $ + parseHostPortWithDefault 80 "example.com:443" `shouldBe` ("example.com", 443) + + it "returns the original input and default port when parsing fails" $ + parseHostPortWithDefault 80 "example.com:not-a-port" `shouldBe` ("example.com:not-a-port", 80) + + describe "passwordReader" $ do + it "parses plaintext password lines" $ + passwordReader "user:pass" `shouldBe` Just ("user", PlainText "pass") + + it "parses salted password lines by base64-decoding salt and hash" $ + passwordReader "user:c2FsdA==:aGFzaA==" `shouldBe` Just ("user", Salted "salt" "hash") + + it "rejects invalid salted and over-split password lines" $ + map passwordReader ["user:not-base64:also-not-base64", "user:pass:extra:field"] + `shouldBe` [Nothing, Nothing] + + describe "passwordWriter" $ + it "writes salted password lines with base64 salt and hash" $ + passwordWriter "user" (PasswordSalted "salt" "hash") `shouldBe` "user:c2FsdA==:aGFzaA==" + + describe "hashPasswordWithSalt" $ do + it "returns a typed failure when Argon2 rejects hashing parameters" $ + case hashPasswordWithSalt "" (PlainText "pass") of + Left (PasswordHashError msg) -> msg `shouldContain` "unable to hash password with salt" + Right _ -> expectationFailure "expected typed hash failure" + + it "keeps already salted passwords without rehashing" $ + hashPasswordWithSalt "" (Salted "salt" "hash") `shouldBe` Right (PasswordSalted "salt" "hash") + + describe "logLevelReader" $ do + it "parses all current log levels" $ + map logLevelReader ["trace", "debug", "info", "warn", "error", "none"] + `shouldBe` map Just [TRACE, DEBUG, INFO, WARN, ERROR, NONE] + + it "rejects unknown log levels and different casing" $ + map logLevelReader ["", "warning", "INFO"] `shouldBe` replicate 3 Nothing + + describe "parseLogOutput" $ + it "preserves current log destination parsing policy" $ + map parseLogOutput ["none", "stdout", "stderr", "hprox.log"] + `shouldBe` [LogOutputNone, LogOutputStdout, LogOutputStderr, LogOutputFile "hprox.log"] + + describe "splitBy" $ do + it "preserves empty segments between, before, and after separators" $ + NE.toList (splitBy ':' ":a::b:") `shouldBe` ["", "a", "", "b", ""] + + it "returns one empty segment for empty input" $ + NE.toList (splitBy ':' "") `shouldBe` [""] diff --git a/test/Network/HProx/RouteSpec.hs b/test/Network/HProx/RouteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/RouteSpec.hs @@ -0,0 +1,108 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.RouteSpec + ( spec + ) where + +import Network.HProx.Route + +import Test.Hspec + +spec :: Spec +spec = + describe "ReverseRoute" $ do + it "converts and normalizes from the public Config reverse-route tuple shape" $ do + fromReverseRouteTuple (Just "example.com", "/api/", "backend:80") + `shouldBe` ReverseRoute + { routeHost = Just "example.com" + , routePrefix = "/api" + , routeUpstream = "backend:80" + } + routePrefix (fromReverseRouteTuple (Nothing, "api", "backend:80")) `shouldBe` "/api" + routePrefix (fromReverseRouteTuple (Nothing, "/", "backend:80")) `shouldBe` "/" + + it "sorts domain-specific routes before catch-all routes and longer prefixes first" $ do + let catchAllLong = ReverseRoute Nothing "/longer/" "catch-long:80" + catchAllShort = ReverseRoute Nothing "/" "catch-short:80" + hostShort = ReverseRoute (Just "example.com") "/" "host-short:80" + hostLong = ReverseRoute (Just "example.com") "/api/" "host-long:80" + sortReverseRoutes [catchAllShort, hostShort, catchAllLong, hostLong] + `shouldBe` [hostLong, hostShort, catchAllLong, catchAllShort] + + it "matches hostless routes against any request host" $ do + let route = ReverseRoute Nothing "/" "backend:80" + hostMatches route Nothing `shouldBe` True + hostMatches route (Just "example.com") `shouldBe` True + + it "matches host-specific routes case-insensitively" $ do + let route = ReverseRoute (Just "example.com") "/" "backend:80" + hostMatches route Nothing `shouldBe` False + hostMatches route (Just "example.com") `shouldBe` True + hostMatches route (Just "EXAMPLE.com") `shouldBe` True + hostMatches route (Just "other.example") `shouldBe` False + + it "matches prefixes on path boundaries" $ do + let route = ReverseRoute Nothing "/api" "backend:80" + prefixMatches route "/api" `shouldBe` True + prefixMatches route "/api/v1" `shouldBe` True + prefixMatches route "/apiary" `shouldBe` False + prefixMatches route "/apix" `shouldBe` False + prefixMatches route "/other" `shouldBe` False + + it "finds the first matching route after current route sorting" $ do + let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" + shorterHost = ReverseRoute (Just "example.com") "/" "shorter-host:80" + longerHost = ReverseRoute (Just "example.com") "/api/" "longer-host:80" + findMatchingRoute [catchAll, shorterHost, longerHost] (Just "EXAMPLE.com:8080") "/api/users" + `shouldBe` Just longerHost + + it "uses hostless routes for any request host when no host-specific route matches" $ do + let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" + hostRoute = ReverseRoute (Just "example.com") "/api/" "host:80" + findMatchingRoute [catchAll, hostRoute] (Just "other.example") "/api/users" + `shouldBe` Just catchAll + + it "does not match host-specific routes without a request host" $ do + let route = ReverseRoute (Just "example.com") "/api/" "host:80" + findMatchingRoute [route] Nothing "/api/users" `shouldBe` Nothing + + it "rewrites raw paths using normalized prefix boundaries" $ do + let route = fromReverseRouteTuple (Nothing, "/api", "backend:80") + exactRewrite = rewriteReverseProxyRequest route [] "/api" + nestedRewrite = rewriteReverseProxyRequest route [] "/api/users" + unmatchedRewrite = rewriteReverseProxyRequest route [] "/other" + rewriteRawPath exactRewrite `shouldBe` "/" + rewriteRawPath nestedRewrite `shouldBe` "/users" + rewriteRawPath unmatchedRewrite `shouldBe` "/other" + + it "selects secure upstream behavior only for port 443" $ do + let secure = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "secure.example:443") [] "/" + defaultPort = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "plain.example") [] "/" + rewriteUpstream secure `shouldBe` "secure.example" + rewritePort secure `shouldBe` 443 + rewriteSecure secure `shouldBe` True + rewriteUpstream defaultPort `shouldBe` "plain.example" + rewritePort defaultPort `shouldBe` 80 + rewriteSecure defaultPort `shouldBe` False + + it "strips current proxy, forwarded, CDN, X-Real-IP, and X-Scheme headers" $ do + let route = ReverseRoute Nothing "/" "backend:80" + headers = + [ ("Proxy-Connection", "keep-alive") + , ("X-Forwarded-For", "127.0.0.1") + , ("cf-ray", "ray") + , ("cdn-loop", "loop") + , ("X-Real-IP", "127.0.0.1") + , ("X-Scheme", "https") + , ("Authorization", "keep") + ] + rewrite = rewriteReverseProxyRequest route headers "/" + rewriteHeaders rewrite `shouldBe` [("Host", "backend"), ("Authorization", "keep")] + + it "rewrites the request Host to the upstream host" $ do + let route = ReverseRoute Nothing "/" "backend.example:8080" + rewrite = rewriteReverseProxyRequest route [("Host", "original.example")] "/" + rewriteRequestHost rewrite `shouldBe` Just "backend.example" + rewriteHeaders rewrite `shouldBe` [("Host", "backend.example")] diff --git a/test/Network/HProx/RuntimeSpec.hs b/test/Network/HProx/RuntimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/RuntimeSpec.hs @@ -0,0 +1,209 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +{-# LANGUAGE CPP #-} + +module Network.HProx.RuntimeSpec + ( spec + ) where + +import Control.Exception (SomeException, displayException, toException) +import GHC.IO.Exception (IOErrorType(..)) +import Network.HTTP2.Client qualified as H2 +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS +import System.IO.Error (mkIOError) + +#ifdef QUIC_ENABLED +import Network.HProx.Platform.Quic +import Network.QUIC.Internal qualified as Q +#endif +#ifdef OS_UNIX +import Network.HProx.Platform.Unix +#endif + +import Network.HProx.Config +import Network.HProx.Log +import Network.HProx.Route +import Network.HProx.Runtime + +import Test.Hspec + +spec :: Spec +spec = do + describe "RuntimeConfig" $ + it "normalizes log output and sorted reverse routes at the runtime boundary" $ + buildRuntimeConfig defaultConfig + { _log = "stderr" + , _rev = + [ (Nothing, "/", "catch:80") + , (Just "example.com", "/api/", "api:443") + ] + } `shouldBe` RuntimeConfig + { runtimeConfigLogOutput = LogOutputStderr + , runtimeConfigReverseRoutes = + [ ReverseRoute (Just "example.com") "/api" "api:443" + , ReverseRoute Nothing "/" "catch:80" + ] + , runtimeConfigReverseRouteTuples = + [ (Just "example.com", "/api/", "api:443") + , (Nothing, "/", "catch:80") + ] + } + + describe "runtime config validation" $ do + it "rejects direct Config listener ports outside the TCP port range" $ do + validateRuntimeConfig defaultConfig { _port = 0 } `shouldBe` Left "invalid --port: 0 (expected 1..65535)" + validateRuntimeConfig defaultConfig { _port = 65536 } `shouldBe` Left "invalid --port: 65536 (expected 1..65535)" + +#ifdef QUIC_ENABLED + it "rejects direct Config QUIC ports outside the UDP port range" $ do + validateRuntimeConfig defaultConfig { _quic = Just 0 } `shouldBe` Left "invalid --quic: 0 (expected 1..65535)" + validateRuntimeConfig defaultConfig { _quic = Just 65536 } `shouldBe` Left "invalid --quic: 65536 (expected 1..65535)" +#endif + describe "Warp runtime settings" $ do + it "captures default bind, port, server name, and no-parse-path settings" $ + buildWarpRuntimePlan defaultConfig `shouldBe` WarpRuntimePlan + { runtimeBindHost = "*6" + , runtimePort = 3000 + , runtimeServerName = "hprox" + , runtimeNoParsePath = True + } + + it "captures configured bind, port, and server name settings" $ + buildWarpRuntimePlan defaultConfig + { _bind = Just "127.0.0.1" + , _port = 8080 + , _name = "custom" + } `shouldBe` WarpRuntimePlan + { runtimeBindHost = "127.0.0.1" + , runtimePort = 8080 + , runtimeServerName = "custom" + , runtimeNoParsePath = True + } + + describe "runner selection" $ do + it "selects the plain Warp runner when no certificates are configured" $ + selectRunnerPlan defaultConfig [] `shouldBe` PlainWarpRunner + + it "selects the TLS Warp runner when certificates are configured" $ + selectRunnerPlan defaultConfig [("example.com", ())] `shouldBe` TlsWarpRunner + +#ifdef QUIC_ENABLED + it "selects concurrent QUIC and TLS when QUIC is configured with certificates" $ + selectRunnerPlan defaultConfig { _quic = Just 443 } [("example.com", ())] + `shouldBe` QuicAndTlsRunner 443 + + it "does not select QUIC without configured certificates" $ + selectRunnerPlan defaultConfig { _quic = Just 443 } [] `shouldBe` PlainWarpRunner + + it "builds safer QUIC defaults" $ do + quicUse0RTT `shouldBe` False + quicAddressPlan Nothing 8443 `shouldBe` [("0.0.0.0", 8443), ("::", 8443)] + quicAddressPlan (Just "127.0.0.1") 8443 `shouldBe` [("127.0.0.1", 8443)] + quicAltSvc 8443 `shouldBe` "h3=\":8443\"" +#endif +#ifdef OS_UNIX + describe "privilege drop planning" $ do + it "uses the target user's primary group when no group is configured" $ do + let userEntry = ResolvedUser "alice" 1001 2001 + groups = + [ ResolvedGroup "primary" 2001 [] + , ResolvedGroup "extra" 2002 ["alice"] + , ResolvedGroup "other" 2003 ["bob"] + ] + planPrivilegeDrop (Just userEntry) Nothing groups + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Just "alice" + , privilegeDropUserID = Just 1001 + , privilegeDropGroupName = Nothing + , privilegeDropGroupID = Just 2001 + , privilegeDropSupplementaryGroups = [2001, 2002] + } + + it "uses an explicit primary group for a target user" $ do + let userEntry = ResolvedUser "alice" 1001 2001 + groupEntry = ResolvedGroup "service" 3001 [] + groups = [ResolvedGroup "extra" 2002 ["alice"]] + planPrivilegeDrop (Just userEntry) (Just groupEntry) groups + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Just "alice" + , privilegeDropUserID = Just 1001 + , privilegeDropGroupName = Just "service" + , privilegeDropGroupID = Just 3001 + , privilegeDropSupplementaryGroups = [3001, 2002] + } + + it "clears supplementary groups for group-only drops" $ do + let groupEntry = ResolvedGroup "service" 3001 ["alice"] + planPrivilegeDrop Nothing (Just groupEntry) [groupEntry] + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Nothing + , privilegeDropUserID = Nothing + , privilegeDropGroupName = Just "service" + , privilegeDropGroupID = Just 3001 + , privilegeDropSupplementaryGroups = [] + } +#endif + + describe "DoH wrapping decision" $ do + it "wraps the application only when a DoH resolver is configured" $ do + shouldWrapDNSOverHTTPS defaultConfig `shouldBe` False + shouldWrapDNSOverHTTPS defaultConfig { _doh = Just "127.0.0.1:53" } `shouldBe` True + + describe "startup side-effect order" $ + it "documents the current run startup order" $ + startupOrder `shouldBe` + [ InitializeLogger + , LogStartup + , ReadCertificates + , CreateTlsSessionManager + , BuildSettingsAndRunner + , LoadProxyAuth + , CreateHttpManager + , BuildProxyApplication + , LogRuntimeConfig + , StartRunner + ] + describe "access log filtering" $ do + it "suppresses health-check access logs" $ + shouldSuppressAccessLog defaultRequest { rawPathInfo = "/.hprox/health" } `shouldBe` True + + it "keeps normal request access logs" $ + shouldSuppressAccessLog defaultRequest { rawPathInfo = "/" } `shouldBe` False + + describe "runtime exception filtering" $ do + it "suppresses all exception logs above DEBUG level" $ + shouldIgnoreRuntimeException INFO displayedException `shouldBe` True + + it "keeps ordinary displayable exceptions at DEBUG level" $ + shouldIgnoreRuntimeException DEBUG displayedException `shouldBe` False + + it "unwraps HTTP/2 wrappers before selecting the exception to log" $ + fmap displayException (runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen displayedException))) + `shouldBe` Just (displayException displayedException) + + it "suppresses EOF IO exceptions" $ + shouldIgnoreRuntimeException DEBUG eofException `shouldBe` True + + it "suppresses HTTP/2 errors and recursively classified HTTP/2 wrappers" $ do + shouldIgnoreRuntimeException DEBUG (toException H2.ConnectionIsClosed) `shouldBe` True + shouldIgnoreRuntimeException DEBUG (toException (H2.BadThingHappen eofException)) `shouldBe` True + +#ifdef QUIC_ENABLED + it "suppresses QUIC errors and recursively classified QUIC wrappers" $ do + shouldIgnoreRuntimeException DEBUG (toException Q.ConnectionIsReset) `shouldBe` True + shouldIgnoreRuntimeException DEBUG (toException (Q.BadThingHappen eofException)) `shouldBe` True +#endif + + it "suppresses Warp TLS and peer-close exceptions" $ do + shouldIgnoreRuntimeException DEBUG (toException InsecureConnectionDenied) `shouldBe` True + shouldIgnoreRuntimeException DEBUG (toException ConnectionClosedByPeer) `shouldBe` True + +displayedException :: SomeException +displayedException = toException $ userError "display me" + +eofException :: SomeException +eofException = toException $ mkIOError EOF "eof" Nothing Nothing diff --git a/test/Network/HProx/TLSSpec.hs b/test/Network/HProx/TLSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HProx/TLSSpec.hs @@ -0,0 +1,81 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Network.HProx.TLSSpec + ( spec + ) where + +import Control.Exception (ErrorCall, SomeException, displayException, fromException, try) +import Data.Maybe (isNothing) +import Network.HProx.Config (CertFile(..)) +import Network.HProx.Runtime +import Network.TLS qualified as TLS + +import System.Directory (getTemporaryDirectory, removeFile) +import System.IO (hClose, openTempFile) +import Test.Hspec + +spec :: Spec +spec = do + describe "SNI selection" $ do + it "keeps the first configured certificate as the default certificate" $ + defaultCertificate certFixtures `shouldBe` Just "first-cert" + + it "matches exact SNI hostnames case-insensitively" $ do + lookupSNIHost (Just "EXAMPLE.com") [("example.com", "cert" :: String), ("other.example", "other")] + `shouldBe` Right "cert" + sniPatternMatches "EXAMPLE.com" "example.COM" `shouldBe` True + sniPatternMatches "Ä.example.com" "ä.example.com" `shouldBe` False + + it "matches wildcard SNI hostnames case-insensitively for one label only" $ do + sniPatternMatches "api.example.com" "*.example.com" `shouldBe` True + sniPatternMatches "API.example.com" "*.EXAMPLE.com" `shouldBe` True + sniPatternMatches "deep.api.example.com" "*.example.com" `shouldBe` False + sniPatternMatches "example.com" "*.example.com" `shouldBe` False + sniPatternMatches ".example.com" "*.example.com" `shouldBe` False + sniPatternMatches "badexample.com" "*.example.com" `shouldBe` False + + it "returns the first matching configured SNI certificate" $ + lookupSNIHost (Just "api.example.com") + [ ("*.example.com", "wildcard" :: String) + , ("api.example.com", "exact") + ] `shouldBe` Right "wildcard" + + it "rejects multi-label wildcard SNI matches during lookup" $ + lookupSNIHost (Just "deep.api.example.com") [("*.example.com", "wildcard" :: String)] + `shouldBe` Left "SNI: unknown hostname (\"deep.api.example.com\")" + + it "rejects unknown and missing SNI hosts with current failure messages" $ do + lookupSNIHost (Just "unknown.example") [("example.com", "cert" :: String)] + `shouldBe` Left "SNI: unknown hostname (\"unknown.example\")" + lookupSNIHost Nothing [("example.com", "cert" :: String)] + `shouldBe` Left "SNI: unspecified" + + describe "TLS credential loading" $ + it "throws a contextual IO exception when certificate loading fails" $ do + certPath <- missingPath "hprox-missing-cert.pem" + keyPath <- missingPath "hprox-missing-key.pem" + result <- try (loadTlsCredentials [("example.com", CertFile certPath keyPath)]) :: IO (Either SomeException [(String, TLS.Credential)]) + case result of + Left ex -> do + fromException ex `shouldSatisfy` (isNothing :: Maybe ErrorCall -> Bool) + let message = displayException ex + message `shouldContain` "example.com" + message `shouldContain` certPath + message `shouldContain` keyPath + Right _ -> expectationFailure "expected TLS credential loading to fail" + +certFixtures :: [(String, String)] +certFixtures = + [ ("first.example", "first-cert") + , ("second.example", "second-cert") + ] + +missingPath :: String -> IO FilePath +missingPath template = do + tmpDir <- getTemporaryDirectory + (path, handle) <- openTempFile tmpDir template + hClose handle + removeFile path + return path diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,37 @@ +-- SPDX-License-Identifier: Apache-2.0 +-- +-- Copyright (C) 2026 Bin Jin. All Rights Reserved. + +module Main + ( main + ) where + +import Network.HProx.AuthSpec qualified as AuthSpec +import Network.HProx.ConfigSpec qualified as ConfigSpec +import Network.HProx.DoHSpec qualified as DoHSpec +import Network.HProx.HeadersSpec qualified as HeadersSpec +import Network.HProx.MiddlewareSpec qualified as MiddlewareSpec +import Network.HProx.NaiveSpec qualified as NaiveSpec +import Network.HProx.ProxySpec qualified as ProxySpec +import Network.HProx.PureSpec qualified as PureSpec +import Network.HProx.RouteSpec qualified as RouteSpec +import Network.HProx.RuntimeSpec qualified as RuntimeSpec +import Network.HProx.TLSSpec qualified as TLSSpec +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "hprox test suite" $ + it "runs" $ + True `shouldBe` True + AuthSpec.spec + ConfigSpec.spec + DoHSpec.spec + PureSpec.spec + HeadersSpec.spec + MiddlewareSpec.spec + NaiveSpec.spec + RouteSpec.spec + ProxySpec.spec + TLSSpec.spec + RuntimeSpec.spec