hprox 0.6.4 → 0.7.0
raw patch · 32 files changed
+3380/−756 lines, 32 filesdep +hspecdep +networkdep ~asyncdep ~basedep ~base64-bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: hspec, network
Dependency ranges changed: async, base, base64-bytestring, binary, bytestring, case-insensitive, conduit, conduit-extra, directory, dns, fast-logger, http-client, http-client-tls, http-reverse-proxy, http-types, http2, http3, optparse-applicative, quic, random, tls, tls-session-manager, wai, wai-extra, warp, warp-tls
API changes (from Hackage documentation)
Files
- CHANGELOG.md +126/−0
- Changelog.md +0/−66
- LICENSE +1/−1
- README.md +0/−1
- app/Main.hs +1/−1
- cbits/setcap.c +0/−60
- hprox.cabal +92/−11
- src/Network/HProx.hs +48/−433
- src/Network/HProx/Auth.hs +53/−0
- src/Network/HProx/Config.hs +234/−0
- src/Network/HProx/DoH.hs +98/−29
- src/Network/HProx/Headers.hs +55/−0
- src/Network/HProx/Impl.hs +224/−114
- src/Network/HProx/Log.hs +23/−10
- src/Network/HProx/Naive.hs +50/−15
- src/Network/HProx/Platform/Quic.hs +87/−0
- src/Network/HProx/Platform/Unix.hs +134/−0
- src/Network/HProx/Route.hs +123/−0
- src/Network/HProx/Runtime.hs +333/−0
- src/Network/HProx/Util.hs +30/−15
- test/Network/HProx/AuthSpec.hs +168/−0
- test/Network/HProx/ConfigSpec.hs +185/−0
- test/Network/HProx/DoHSpec.hs +174/−0
- test/Network/HProx/HeadersSpec.hs +34/−0
- test/Network/HProx/MiddlewareSpec.hs +156/−0
- test/Network/HProx/NaiveSpec.hs +46/−0
- test/Network/HProx/ProxySpec.hs +389/−0
- test/Network/HProx/PureSpec.hs +81/−0
- test/Network/HProx/RouteSpec.hs +108/−0
- test/Network/HProx/RuntimeSpec.hs +209/−0
- test/Network/HProx/TLSSpec.hs +81/−0
- test/Spec.hs +37/−0
+ CHANGELOG.md view
@@ -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:<redacted>` 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
− Changelog.md
@@ -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
LICENSE view
@@ -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.
README.md view
@@ -2,7 +2,6 @@ [](https://circleci.com/gh/bjin/hprox) [](https://cirrus-ci.com/github/bjin/hprox)-[](https://packdeps.haskellers.com/feed?needle=hprox) [](https://github.com/bjin/hprox/releases) [](https://hackage.haskell.org/package/hprox) [](https://github.com/bjin/hprox/blob/master/LICENSE)
app/Main.hs view
@@ -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
− cbits/setcap.c
@@ -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 <linux/securebits.h>-#include <signal.h>-#include <stdio.h>-#include <string.h>-#include <sys/capability.h>-#include <sys/prctl.h>-#include <sys/syscall.h>-#include <sys/types.h>-#include <unistd.h>--#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
hprox.cabal view
@@ -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 <https://github.com/bjin/hprox#readme> 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
src/Network/HProx.hs view
@@ -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 "<none|stdout|stderr|file>"- <> value "stdout"- <> showDefault- <> help "Specify the logging type")-- loglevel = option (maybeReader logLevelReader)- ( long "loglevel"- <> metavar "<trace|debug|info|warn|error|none>"- <> 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
+ src/Network/HProx/Auth.hs view
@@ -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)
+ src/Network/HProx/Config.hs view
@@ -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 "<none|stdout|stderr|file>"+ <> value "stdout"+ <> showDefault+ <> help "Specify the logging type")++ loglevel = option (maybeReader logLevelReader)+ ( long "loglevel"+ <> metavar "<trace|debug|info|warn|error|none>"+ <> 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
src/Network/HProx/DoH.hs view
@@ -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"
+ src/Network/HProx/Headers.hs view
@@ -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
src/Network/HProx/Impl.hs view
@@ -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 = "<invalid>"+redactedCredential (Just decoded) =+ case BS8.break (== ':') decoded of+ (username, password) | not (BS.null password) -> BS.concat [username, ":<redacted>"]+ _otherwise -> "<invalid>"+ 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
src/Network/HProx/Log.hs view
@@ -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"
src/Network/HProx/Naive.hs view
@@ -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)
+ src/Network/HProx/Platform/Quic.hs view
@@ -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
+ src/Network/HProx/Platform/Unix.hs view
@@ -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
+ src/Network/HProx/Route.hs view
@@ -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
+ src/Network/HProx/Runtime.hs view
@@ -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
src/Network/HProx/Util.hs view
@@ -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
+ test/Network/HProx/AuthSpec.hs view
@@ -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
+ test/Network/HProx/ConfigSpec.hs view
@@ -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+ ]
+ test/Network/HProx/DoHSpec.hs view
@@ -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
+ test/Network/HProx/HeadersSpec.hs view
@@ -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
+ test/Network/HProx/MiddlewareSpec.hs view
@@ -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 ()+ }
+ test/Network/HProx/NaiveSpec.hs view
@@ -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
+ test/Network/HProx/ProxySpec.hs view
@@ -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:<redacted>"+ 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
+ test/Network/HProx/PureSpec.hs view
@@ -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` [""]
+ test/Network/HProx/RouteSpec.hs view
@@ -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")]
+ test/Network/HProx/RuntimeSpec.hs view
@@ -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
+ test/Network/HProx/TLSSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -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