checkpoint
This commit is contained in:
CarterPerez-dev
parent
0dbfff88da
commit
8f89000277
|
|
@ -1,9 +1,24 @@
|
|||
.stack-work
|
||||
# Haskell build artifacts
|
||||
.stack-work/
|
||||
dist/
|
||||
dist-newstyle/
|
||||
cabal.project.local
|
||||
cabal.project.local~
|
||||
.HTF/
|
||||
.ghc.environment.*
|
||||
|
||||
# Editor files
|
||||
*.swp
|
||||
*.swo
|
||||
*~
|
||||
.DS_Store
|
||||
|
||||
# Test certificates (self-signed, regenerate with script)
|
||||
examples/certs/
|
||||
|
||||
# Logs
|
||||
*.log
|
||||
|
||||
# Private progress tracking
|
||||
PROGRESS.md
|
||||
decisions.md
|
||||
|
|
|
|||
|
|
@ -0,0 +1,46 @@
|
|||
[style]
|
||||
based_on_style = pep8
|
||||
column_limit = 74
|
||||
indent_width = 4
|
||||
continuation_indent_width = 4
|
||||
indent_closing_brackets = false
|
||||
dedent_closing_brackets = true
|
||||
indent_blank_lines = false
|
||||
spaces_before_comment = 2
|
||||
spaces_around_power_operator = false
|
||||
spaces_around_default_or_named_assign = true
|
||||
space_between_ending_comma_and_closing_bracket = false
|
||||
space_inside_brackets = false
|
||||
spaces_around_subscript_colon = true
|
||||
blank_line_before_nested_class_or_def = false
|
||||
blank_line_before_class_docstring = false
|
||||
blank_lines_around_top_level_definition = 2
|
||||
blank_lines_between_top_level_imports_and_variables = 2
|
||||
blank_line_before_module_docstring = false
|
||||
split_before_logical_operator = true
|
||||
split_before_first_argument = true
|
||||
split_before_named_assigns = true
|
||||
split_complex_comprehension = true
|
||||
split_before_expression_after_opening_paren = false
|
||||
split_before_closing_bracket = true
|
||||
split_all_comma_separated_values = true
|
||||
split_all_top_level_comma_separated_values = false
|
||||
coalesce_brackets = false
|
||||
each_dict_entry_on_separate_line = true
|
||||
allow_multiline_lambdas = false
|
||||
allow_multiline_dictionary_keys = false
|
||||
split_penalty_import_names = 0
|
||||
join_multiple_lines = false
|
||||
align_closing_bracket_with_visual_indent = true
|
||||
arithmetic_precedence_indication = false
|
||||
split_penalty_for_added_line_split = 275
|
||||
use_tabs = false
|
||||
split_before_dot = false
|
||||
split_arguments_when_comma_terminated = true
|
||||
i18n_function_call = ['_', 'N_', 'gettext', 'ngettext']
|
||||
i18n_comment = ['# Translators:', '# i18n:']
|
||||
split_penalty_comprehension = 80
|
||||
split_penalty_after_opening_bracket = 280
|
||||
split_penalty_before_if_expr = 0
|
||||
split_penalty_bitwise_operator = 290
|
||||
split_penalty_logical_operator = 0
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
# Ᾰenebris Makefile - Common development commands
|
||||
|
||||
.PHONY: help build run logs stop restart clean test backend kill-all
|
||||
|
||||
help:
|
||||
@echo "Ᾰenebris Development Commands:"
|
||||
@echo ""
|
||||
@echo " make build - Build the project"
|
||||
@echo " make run - Start Ᾰenebris proxy"
|
||||
@echo " make logs - Watch logs in real-time"
|
||||
@echo " make stop - Stop the proxy"
|
||||
@echo " make restart - Restart the proxy"
|
||||
@echo " make clean - Clean build artifacts"
|
||||
@echo ""
|
||||
@echo " make backend - Start test backend (port 8000)"
|
||||
@echo " make test - Run tests (when implemented)"
|
||||
@echo " make kill-all - Kill proxy + backend"
|
||||
@echo ""
|
||||
|
||||
build:
|
||||
@echo "Building Ᾰenebris..."
|
||||
@stack build
|
||||
|
||||
run:
|
||||
@echo "Starting Ᾰenebris on port 8081..."
|
||||
@nohup stack run examples/config.yaml > aenebris.log 2>&1 &
|
||||
@sleep 2
|
||||
@echo "Proxy started! PID: $$(pgrep -f 'aenebris examples' | head -1)"
|
||||
@echo "Run 'make logs' to watch output"
|
||||
|
||||
logs:
|
||||
@echo "Watching Ᾰenebris logs (Ctrl+C to exit)..."
|
||||
@tail -f aenebris.log
|
||||
|
||||
stop:
|
||||
@echo "Stopping Ᾰenebris..."
|
||||
@pkill -f 'aenebris examples' || echo "Proxy not running"
|
||||
|
||||
restart: stop
|
||||
@sleep 1
|
||||
@make run
|
||||
|
||||
clean:
|
||||
@echo "Cleaning build artifacts..."
|
||||
@stack clean
|
||||
@rm -f aenebris.log nohup.out
|
||||
|
||||
backend:
|
||||
@echo "Starting test backend on port 8000..."
|
||||
@python3 examples/test_backend.py > backend.log 2>&1 &
|
||||
@sleep 1
|
||||
@echo "Backend started! PID: $$(pgrep -f test_backend | head -1)"
|
||||
|
||||
# Run tests (placeholder for now)
|
||||
test:
|
||||
@echo "Running tests..."
|
||||
@stack test
|
||||
|
||||
kill-all:
|
||||
@echo "Killing all processes..."
|
||||
@pkill -f 'aenebris examples' || echo "Proxy not running"
|
||||
@pkill -f test_backend || echo "Backend not running"
|
||||
@echo "All processes stopped"
|
||||
|
|
@ -19,9 +19,16 @@ library
|
|||
hs-source-dirs: src
|
||||
exposed-modules: Aenebris.Proxy
|
||||
, Aenebris.Config
|
||||
, Aenebris.Backend
|
||||
, Aenebris.LoadBalancer
|
||||
, Aenebris.HealthCheck
|
||||
, Aenebris.TLS
|
||||
, Aenebris.Middleware.Security
|
||||
, Aenebris.Middleware.Redirect
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.7 && < 5
|
||||
, warp >= 3.3
|
||||
, warp-tls >= 3.4
|
||||
, wai >= 3.2
|
||||
, http-types >= 0.12
|
||||
, http-conduit >= 2.3
|
||||
|
|
@ -30,6 +37,18 @@ library
|
|||
, text >= 2.0
|
||||
, yaml >= 0.11
|
||||
, aeson >= 2.0
|
||||
, async >= 2.2
|
||||
, stm >= 2.5
|
||||
, time >= 1.9
|
||||
, containers >= 0.6
|
||||
, vector >= 0.12
|
||||
, tls >= 2.1
|
||||
, x509 >= 1.7
|
||||
, x509-store >= 1.6
|
||||
, x509-validation >= 1.6
|
||||
, case-insensitive >= 1.2
|
||||
, directory >= 1.3
|
||||
, data-default-class >= 0.1
|
||||
ghc-options: -Wall
|
||||
-Wcompat
|
||||
-Widentities
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@ main = do
|
|||
|
||||
putStrLn $ "Loading configuration from: " ++ configPath
|
||||
|
||||
-- Load configuration
|
||||
result <- loadConfig configPath
|
||||
case result of
|
||||
Left err -> do
|
||||
|
|
@ -29,7 +28,6 @@ main = do
|
|||
exitFailure
|
||||
|
||||
Right config -> do
|
||||
-- Validate configuration
|
||||
case validateConfig config of
|
||||
Left err -> do
|
||||
hPutStrLn stderr $ "ERROR: Invalid configuration"
|
||||
|
|
@ -37,10 +35,13 @@ main = do
|
|||
exitFailure
|
||||
|
||||
Right () -> do
|
||||
putStrLn "✓ Configuration loaded and validated successfully"
|
||||
putStrLn "Configuration loaded and validated successfully"
|
||||
|
||||
-- Create HTTP client manager
|
||||
-- Create HTTP client manager with connection pooling
|
||||
manager <- newManager defaultManagerSettings
|
||||
|
||||
-- Initialize proxy state (load balancers + health checkers)
|
||||
proxyState <- initProxyState config manager
|
||||
|
||||
-- Start the proxy
|
||||
startProxy config manager
|
||||
startProxy proxyState
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
ⒸAngelaMos | 2025
|
||||
CarterPerez-dev | CertGames.com
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
1. Redistributions of source code must retain the above copyright notice, this
|
||||
list of conditions and the following disclaimer.
|
||||
|
||||
2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
this list of conditions and the following disclaimer in the documentation
|
||||
and/or other materials provided with the distribution.
|
||||
|
||||
3. Neither the name of the copyright holder nor the names of its contributors
|
||||
may be used to endorse or promote products derived from this software
|
||||
without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||||
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
|
||||
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
|
||||
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
|
||||
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,964 @@
|
|||
# Advanced Load Balancing Implementation Guide for Haskell Reverse Proxies
|
||||
|
||||
**Production-grade load balancing architecture for high-performance Haskell proxies targeting 100k+ req/s, featuring STM-based connection tracking, async health checking, and composable algorithms.**
|
||||
|
||||
Load balancing in Haskell reverse proxies requires careful orchestration of concurrent state management, efficient algorithm selection, and robust failure detection. For the Ᾰenebris project milestone, this guide synthesizes battle-tested patterns from production systems like Keter, Mighty, and modern libraries to deliver type-safe, composable implementations that leverage Haskell's concurrency primitives. The architecture balances functional purity with performance pragmatism, using **IORef for hot paths** and **STM for complex transactions** while maintaining sub-microsecond selection latency.
|
||||
|
||||
## Algorithm implementations optimized for Haskell
|
||||
|
||||
The foundation of any load balancer is its selection algorithm. **Round-robin with IORef achieves ~9.7ns read/write operations**, making it ideal for high-throughput scenarios. The critical design choice is between IORef (minimal overhead) and TVar (composability), with each serving distinct architectural needs.
|
||||
|
||||
### Round-robin: IORef-based implementation
|
||||
|
||||
For pure round-robin without complex state coordination, **IORef with `atomicModifyIORef'` provides optimal performance**:
|
||||
|
||||
```haskell
|
||||
import Data.IORef
|
||||
import Data.Vector (Vector, (!))
|
||||
import qualified Data.Vector as V
|
||||
|
||||
data RoundRobinBalancer a = RoundRobinBalancer
|
||||
{ backends :: Vector a
|
||||
, counter :: IORef Int
|
||||
}
|
||||
|
||||
newRRBalancer :: [a] -> IO (RoundRobinBalancer a)
|
||||
newRRBalancer bs = RoundRobinBalancer (V.fromList bs) <$> newIORef 0
|
||||
|
||||
selectBackend :: RoundRobinBalancer a -> IO a
|
||||
selectBackend balancer = do
|
||||
let backends' = backends balancer
|
||||
len = V.length backends'
|
||||
idx <- atomicModifyIORef' (counter balancer) $ \i ->
|
||||
let next = (i + 1) `mod` len
|
||||
in (next, i)
|
||||
return $ backends' ! idx
|
||||
```
|
||||
|
||||
The strict `atomicModifyIORef'` variant is essential - the lazy version causes space leaks under high load. Vector indexing provides O(1) access, and modulo wraparound handles counter overflow safely. This pattern **scales linearly to 8+ cores** without contention issues.
|
||||
|
||||
**Alternative: Hackage's `roundRobin` package** (version 0.1.2.0) provides a pre-built solution using NonEmpty for type-level guarantees of at least one backend:
|
||||
|
||||
```haskell
|
||||
import Data.RoundRobin
|
||||
|
||||
rr <- newRoundRobin (backend1 :| [backend2, backend3])
|
||||
backend <- select rr -- Thread-safe selection
|
||||
```
|
||||
|
||||
### Least connections: Heap-based and STM approaches
|
||||
|
||||
Least connections requires tracking active connection counts per backend. **Two proven patterns emerge**: heap-based (Rob Pike inspired) and direct STM comparison.
|
||||
|
||||
**Heap-based implementation** (from wagdav/load-balancer):
|
||||
|
||||
```haskell
|
||||
import Data.Heap (MinPrioHeap)
|
||||
import qualified Data.Heap as DH
|
||||
import Control.Concurrent.STM
|
||||
|
||||
type Pool a = MinPrioHeap Int (Worker a)
|
||||
|
||||
data Worker a = Worker Int (TChan (Request a))
|
||||
|
||||
-- Dispatch to least-loaded worker
|
||||
dispatch :: Pool a -> Request a -> IO (Pool a)
|
||||
dispatch pool request = do
|
||||
let ((priority, worker), pool') = fromJust $ view pool
|
||||
schedule worker request
|
||||
return $ insert (priority + 1, worker) pool'
|
||||
|
||||
-- Mark completion and decrement
|
||||
completed :: Pool a -> Worker a -> Pool a
|
||||
completed pool worker =
|
||||
let (matchingWorkers, pool') = partition (\item -> snd item == worker) pool
|
||||
[(priority, w)] = toList matchingWorkers
|
||||
in insert (priority - 1, w) pool'
|
||||
```
|
||||
|
||||
The heap automatically maintains the least-loaded worker at the root with **O(log n) insertion and extraction**. Workers report completion asynchronously via TChan, enabling loose coupling and independent failure handling.
|
||||
|
||||
**Direct STM comparison** for simpler architectures:
|
||||
|
||||
```haskell
|
||||
data Backend = Backend
|
||||
{ backendHost :: String
|
||||
, backendPort :: Int
|
||||
, activeConnections :: TVar Int
|
||||
}
|
||||
|
||||
trackConnection :: Backend -> IO a -> IO a
|
||||
trackConnection backend action =
|
||||
bracket_
|
||||
(atomically $ modifyTVar' (activeConnections backend) (+1))
|
||||
(atomically $ modifyTVar' (activeConnections backend) (subtract 1))
|
||||
action
|
||||
|
||||
selectLeastConnections :: [Backend] -> STM Backend
|
||||
selectLeastConnections backends = do
|
||||
conns <- mapM (readTVar . activeConnections) backends
|
||||
let minConns = minimum conns
|
||||
idx = fromJust $ findIndex (== minConns) conns
|
||||
return $ backends !! idx
|
||||
```
|
||||
|
||||
This pattern **composes naturally with health checks** - the STM transaction can atomically read both connection counts and health status. The tradeoff is performance: STM transactions have O(n) lookup time where n equals TVars accessed, roughly 2x slower than IORef for simple operations but vastly superior for composed logic.
|
||||
|
||||
**Hackage's `load-balancing` package** (version 1.0.1.1) provides production-tested least-connections with round-robin tie-breaking:
|
||||
|
||||
```haskell
|
||||
import Control.Concurrent.LoadDistribution
|
||||
|
||||
lb <- evenlyDistributed (return $ Set.fromList backends)
|
||||
withResource lb $ \maybeBackend ->
|
||||
case maybeBackend of
|
||||
Just backend -> proxyRequest backend
|
||||
Nothing -> handleNoBackends
|
||||
```
|
||||
|
||||
### Weighted distribution: Smooth weighted round-robin
|
||||
|
||||
The **nginx smooth weighted round-robin algorithm produces optimal distribution patterns**, avoiding bursts of identical backend selection. For weights {5, 1, 1}, it generates {a, a, b, a, c, a, a} instead of the naive {c, b, a, a, a, a, a}.
|
||||
|
||||
**Algorithm mechanics**: On each selection, increase each backend's `current_weight` by its `weight`, select the backend with maximum `current_weight`, then reduce the selected backend's weight by the total weight sum.
|
||||
|
||||
```haskell
|
||||
data WeightedBackend a = WeightedBackend
|
||||
{ backend :: a
|
||||
, weight :: Int
|
||||
, currentWeight :: TVar Int
|
||||
}
|
||||
|
||||
smoothWeightedSelect :: [WeightedBackend a] -> IO a
|
||||
smoothWeightedSelect backends = atomically $ do
|
||||
-- Increase all current weights by their base weights
|
||||
forM_ backends $ \wb ->
|
||||
modifyTVar' (currentWeight wb) (+ weight wb)
|
||||
|
||||
-- Find backend with maximum current weight
|
||||
weights <- mapM (readTVar . currentWeight) backends
|
||||
let maxWeight = maximum weights
|
||||
selected = backends !! fromJust (findIndex (== maxWeight) weights)
|
||||
|
||||
-- Reduce selected backend's current weight by total
|
||||
let totalWeight = sum (map weight backends)
|
||||
modifyTVar' (currentWeight selected) (subtract totalWeight)
|
||||
|
||||
return $ backend selected
|
||||
```
|
||||
|
||||
This **STM-based implementation guarantees atomicity** across multiple backend updates. For weights {5, 1, 1}, the execution trace shows smooth distribution:
|
||||
|
||||
```
|
||||
Initial: a=0 b=0 c=0
|
||||
Step 1: a=5 b=1 c=1 → select a → a=-2
|
||||
Step 2: a=3 b=2 c=2 → select a → a=-4
|
||||
Step 3: a=1 b=3 c=3 → select b → b=-4
|
||||
Step 4: a=6 b=-3 c=4 → select a → a=-1
|
||||
```
|
||||
|
||||
**No existing Haskell library implements smooth WRR** - this is a critical implementation gap. The nginx algorithm (commit 52327e0) provides the reference implementation, and the pattern above is production-ready.
|
||||
|
||||
### Performance characteristics and selection criteria
|
||||
|
||||
| Algorithm | Complexity | Concurrency Primitive | Use Case | Throughput |
|
||||
|-----------|------------|----------------------|----------|------------|
|
||||
| Round-robin (IORef) | O(1) | IORef | Simple equal distribution | 100k+ req/s |
|
||||
| Round-robin (TVar) | O(1) | TVar | Composable with health checks | 80k+ req/s |
|
||||
| Least connections (heap) | O(log n) | STM + TChan | Dynamic load awareness | 50k+ req/s |
|
||||
| Least connections (direct) | O(n) | STM | Simple setups, few backends | 40k+ req/s |
|
||||
| Smooth WRR | O(n) | STM | Weighted backends, quality distribution | 60k+ req/s |
|
||||
|
||||
**Decision matrix**: Use IORef round-robin for maximum throughput with equal backends. Use STM-based smooth WRR when backend capacities differ. Use heap-based least connections when request processing time varies significantly (e.g., database queries vs static files).
|
||||
|
||||
## STM patterns for connection tracking
|
||||
|
||||
Software Transactional Memory enables **composable atomic updates across multiple shared variables**, critical for coordinating health checks, connection counts, and metrics. Understanding STM's performance characteristics prevents common pitfalls.
|
||||
|
||||
### TVar architecture for shared state
|
||||
|
||||
**TVar provides transactional guarantees** but with performance tradeoffs. Each `readTVar` or `writeTVar` adds an entry to the transaction log with O(n) lookup cost. The key insight: **keep transactions small and minimize TVars touched per transaction**.
|
||||
|
||||
```haskell
|
||||
data BackendState = BackendState
|
||||
{ bsBackends :: TVar (Map BackendId Backend)
|
||||
, bsMetrics :: TVar Metrics
|
||||
, bsHealthStatus :: TVar (Map BackendId HealthStatus)
|
||||
}
|
||||
|
||||
-- BAD: Touches many TVars in single transaction
|
||||
countAllConnections :: [Backend] -> STM Int
|
||||
countAllConnections backends =
|
||||
sum <$> mapM (readTVar . activeConns) backends
|
||||
|
||||
-- GOOD: Maintain aggregate counter
|
||||
data BackendPool = BackendPool
|
||||
{ totalConnections :: TVar Int
|
||||
, backends :: [Backend]
|
||||
}
|
||||
|
||||
-- Update both atomically
|
||||
updateConnections :: BackendPool -> Backend -> IO ()
|
||||
updateConnections pool backend = atomically $ do
|
||||
modifyTVar' (totalConnections pool) (+1)
|
||||
modifyTVar' (activeConns backend) (+1)
|
||||
```
|
||||
|
||||
**TMVar vs TVar choice**: TVar holds a value always; TMVar can be empty. Use TMVar for **synchronization and signaling** (producer/consumer), TVar for **shared state**. TMVar is just `TVar (Maybe a)` with blocking operations - use the simpler primitive when blocking isn't needed.
|
||||
|
||||
### Avoiding contention through striping
|
||||
|
||||
**Striped pools reduce contention** by partitioning resources across multiple TVars. The `resource-pool` package (used by Yesod) implements this pattern:
|
||||
|
||||
```haskell
|
||||
data Pool a = Pool
|
||||
{ localPools :: SmallArray (LocalPool a)
|
||||
, reaperRef :: IORef ()
|
||||
}
|
||||
|
||||
data LocalPool a = LocalPool
|
||||
{ localPool :: TVar (Stripe a)
|
||||
}
|
||||
|
||||
data Stripe a = Stripe
|
||||
{ available :: Int -- Count of available resources
|
||||
, queue :: Queue a -- Available resources
|
||||
, waiting :: Queue (TMVar (Maybe a)) -- Waiting threads
|
||||
}
|
||||
```
|
||||
|
||||
Each stripe operates independently, **reducing transaction conflicts**. Configure stripe count to match CPU cores (default uses `getNumCapabilities`). This pattern **scales STM performance to 40+ cores** before plateauing.
|
||||
|
||||
### Connection pool implementation with STM
|
||||
|
||||
Production-grade connection tracking combines **bracket for resource safety with STM for atomic updates**:
|
||||
|
||||
```haskell
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (bracket_)
|
||||
|
||||
data Backend = Backend
|
||||
{ backendId :: Int
|
||||
, connections :: TVar Int
|
||||
, maxConnections :: Int
|
||||
, healthy :: TVar Bool
|
||||
}
|
||||
|
||||
-- Acquire connection with capacity checking
|
||||
acquireConnection :: Backend -> STM ()
|
||||
acquireConnection backend = do
|
||||
current <- readTVar (connections backend)
|
||||
isHealthy <- readTVar (healthy backend)
|
||||
when (current >= maxConnections backend) retry
|
||||
when (not isHealthy) retry
|
||||
writeTVar (connections backend) (current + 1)
|
||||
|
||||
-- Release connection
|
||||
releaseConnection :: Backend -> STM ()
|
||||
releaseConnection backend =
|
||||
modifyTVar' (connections backend) (subtract 1)
|
||||
|
||||
-- Safe usage pattern
|
||||
withConnection :: Backend -> IO a -> IO a
|
||||
withConnection backend action =
|
||||
bracket_
|
||||
(atomically $ acquireConnection backend)
|
||||
(atomically $ releaseConnection backend)
|
||||
action
|
||||
```
|
||||
|
||||
The `retry` primitive is STM's killer feature - **threads automatically block until the transaction can succeed**. When connections become available or health status changes, waiting threads wake and retry. No manual condition variables or polling needed.
|
||||
|
||||
### Performance optimization strategies
|
||||
|
||||
**Key findings from production systems**:
|
||||
|
||||
1. **Keep transactions small**: Long transactions are vulnerable to starvation. Short transactions repeatedly abort long ones under contention.
|
||||
|
||||
2. **Move pure computation outside transactions**:
|
||||
```haskell
|
||||
-- BAD: Expensive computation inside transaction
|
||||
badPattern = atomically $ do
|
||||
val <- expensiveComputation -- Recomputed on every retry!
|
||||
tvar <- readTVar someTVar
|
||||
|
||||
-- GOOD: Pure computation outside
|
||||
goodPattern = do
|
||||
let val = expensiveComputation
|
||||
atomically $ do
|
||||
tvar <- readTVar someTVar
|
||||
writeTVar someTVar (combine val tvar)
|
||||
```
|
||||
|
||||
3. **Use IORef for simple counters**: For single-variable updates without composition needs, **IORef is 2-3x faster**:
|
||||
- IORef read/write: ~9.7ns
|
||||
- MVar operations: ~15ns
|
||||
- TVar operations: ~20ns (single variable)
|
||||
|
||||
4. **Batch updates when possible**: Instead of N separate transactions, combine related updates:
|
||||
```haskell
|
||||
-- Update multiple backend states atomically
|
||||
updateHealthChecks :: [Backend] -> [(Backend, Bool)] -> STM ()
|
||||
updateHealthChecks backends results =
|
||||
forM_ results $ \(backend, isHealthy) ->
|
||||
writeTVar (healthy backend) isHealthy
|
||||
```
|
||||
|
||||
**GC pressure consideration**: Large pinned arrays (>409 bytes) cause GHC to take a global lock, becoming a bottleneck beyond 16 cores. Pool and reuse buffers in high-performance scenarios.
|
||||
|
||||
## Async health checking with circuit breakers
|
||||
|
||||
Health checking separates the **control plane** (detecting failures) from the **data plane** (routing requests). Async patterns using Control.Concurrent.Async enable **non-blocking health probes** that run independently of request handling.
|
||||
|
||||
### HTTP health check implementation
|
||||
|
||||
Use `http-client` with connection pooling for efficient health checks:
|
||||
|
||||
```haskell
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.TLS
|
||||
import System.Timeout
|
||||
import Control.Concurrent.Async
|
||||
|
||||
data HealthCheckConfig = HealthCheckConfig
|
||||
{ hcInterval :: Int -- Seconds between checks
|
||||
, hcTimeout :: Int -- Request timeout (seconds)
|
||||
, hcEndpoint :: String -- Health endpoint path
|
||||
, hcMaxFailures :: Int -- Failures before marking unhealthy
|
||||
, hcRecoveryAttempts :: Int -- Successes before marking healthy
|
||||
}
|
||||
|
||||
defaultConfig :: HealthCheckConfig
|
||||
defaultConfig = HealthCheckConfig
|
||||
{ hcInterval = 10
|
||||
, hcTimeout = 2
|
||||
, hcEndpoint = "/health"
|
||||
, hcMaxFailures = 3
|
||||
, hcRecoveryAttempts = 2
|
||||
}
|
||||
|
||||
performHealthCheck :: Manager -> HealthCheckConfig -> Backend -> IO Bool
|
||||
performHealthCheck manager config backend = do
|
||||
let url = backendUrl backend ++ hcEndpoint config
|
||||
result <- timeout (hcTimeout config * 1000000) $ do
|
||||
req <- parseRequest url
|
||||
response <- httpLbs req manager
|
||||
return $ statusCode (responseStatus response) == 200
|
||||
|
||||
return $ fromMaybe False result
|
||||
```
|
||||
|
||||
**Key optimizations**: Share a single `Manager` across all health checks to leverage connection pooling. Set appropriate `managerConnCount` (default 2 per route is too low for production - use 100+).
|
||||
|
||||
### Periodic scheduling with async
|
||||
|
||||
**Control.Concurrent.Async provides resource-safe concurrent operations**. The `withAsync` combinator automatically cancels threads when they leave scope:
|
||||
|
||||
```haskell
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async
|
||||
import Control.Monad (forever)
|
||||
|
||||
healthCheckLoop :: Manager -> HealthCheckConfig -> [Backend] -> IO ()
|
||||
healthCheckLoop manager config backends = forever $ do
|
||||
-- Check all backends concurrently
|
||||
results <- mapConcurrently
|
||||
(performHealthCheck manager config)
|
||||
backends
|
||||
|
||||
-- Update backend states
|
||||
zipWithM_ (updateBackendState config) backends results
|
||||
|
||||
-- Wait for next interval
|
||||
threadDelay (hcInterval config * 1000000)
|
||||
|
||||
-- Start health checker (automatically cleaned up)
|
||||
startHealthChecker :: HealthCheckConfig -> [Backend] -> IO (Async ())
|
||||
startHealthChecker config backends = do
|
||||
manager <- newTlsManager
|
||||
async $ healthCheckLoop manager config backends
|
||||
```
|
||||
|
||||
**Concurrency patterns**: Use `mapConcurrently` to check all backends in parallel, reducing total check time. Use `race` to implement timeout-based failure detection. Use `link` to propagate exceptions from health checker to main thread.
|
||||
|
||||
**Alternative: async-timer package** provides built-in periodic scheduling:
|
||||
|
||||
```haskell
|
||||
import Control.Concurrent.Async.Timer
|
||||
|
||||
let timerConf = setInterval 10000 $ -- 10 seconds
|
||||
setInitDelay 0 defaultConf
|
||||
|
||||
withAsyncTimer timerConf $ \timer -> do
|
||||
forever $ do
|
||||
timerWait timer
|
||||
checkAndUpdateBackends
|
||||
```
|
||||
|
||||
### State transitions with failure thresholds
|
||||
|
||||
Implement **hysteresis** to prevent flapping - require multiple consecutive failures before marking unhealthy, multiple successes before marking healthy:
|
||||
|
||||
```haskell
|
||||
data BackendState = Healthy | Unhealthy | Recovering
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Backend = Backend
|
||||
{ backendState :: TVar BackendState
|
||||
, backendFailures :: TVar Int
|
||||
, backendSuccesses :: TVar Int
|
||||
}
|
||||
|
||||
updateBackendState :: HealthCheckConfig -> Backend -> Bool -> IO ()
|
||||
updateBackendState config backend healthy = atomically $ do
|
||||
state <- readTVar (backendState backend)
|
||||
failures <- readTVar (backendFailures backend)
|
||||
successes <- readTVar (backendSuccesses backend)
|
||||
|
||||
case (state, healthy) of
|
||||
(Healthy, False) -> do
|
||||
let newFailures = failures + 1
|
||||
writeTVar (backendFailures backend) newFailures
|
||||
when (newFailures >= hcMaxFailures config) $ do
|
||||
writeTVar (backendState backend) Unhealthy
|
||||
writeTVar (backendFailures backend) 0
|
||||
|
||||
(Unhealthy, True) -> do
|
||||
writeTVar (backendState backend) Recovering
|
||||
writeTVar (backendSuccesses backend) 1
|
||||
|
||||
(Recovering, True) -> do
|
||||
let newSuccesses = successes + 1
|
||||
writeTVar (backendSuccesses backend) newSuccesses
|
||||
when (newSuccesses >= hcRecoveryAttempts config) $ do
|
||||
writeTVar (backendState backend) Healthy
|
||||
writeTVar (backendSuccesses backend) 0
|
||||
|
||||
(Recovering, False) -> do
|
||||
writeTVar (backendState backend) Unhealthy
|
||||
writeTVar (backendSuccesses backend) 0
|
||||
|
||||
_ -> return ()
|
||||
```
|
||||
|
||||
This state machine **prevents transient failures from cascading**. A backend must fail `hcMaxFailures` consecutive checks (e.g., 3) before removal, and succeed `hcRecoveryAttempts` consecutive checks (e.g., 2) before returning to rotation.
|
||||
|
||||
### Circuit breaker integration
|
||||
|
||||
**Circuit breakers prevent cascading failures** by failing fast when a backend is degraded. The `circuit-breaker` package (Hackage) provides type-level configuration:
|
||||
|
||||
```haskell
|
||||
import System.CircuitBreaker
|
||||
|
||||
-- Define circuit breaker at type level
|
||||
-- 1000ms = error expiry time, 4 = threshold
|
||||
testBreaker :: CircuitBreaker "Test" 1000 4
|
||||
testBreaker = undefined
|
||||
|
||||
proxyWithCircuitBreaker :: Backend -> Request -> IO Response
|
||||
proxyWithCircuitBreaker backend req = do
|
||||
cbConf <- initialBreakerState
|
||||
|
||||
result <- flip runReaderT cbConf $
|
||||
withBreaker testBreaker $ liftIO $ forwardRequest backend req
|
||||
|
||||
case result of
|
||||
Left (CircuitBreakerClosed msg) ->
|
||||
-- Circuit open, return cached response or error
|
||||
return $ errorResponse 503 "Service Temporarily Unavailable"
|
||||
Right response ->
|
||||
return response
|
||||
```
|
||||
|
||||
Circuit breaker states: **Active** (closed, requests pass), **Testing** (half-open, testing recovery), **Waiting** (open, blocking requests). When error threshold (4) is reached within the time window (1000ms), the circuit opens and blocks requests until the window expires.
|
||||
|
||||
**Production pattern**: Combine circuit breakers with health checks for defense in depth:
|
||||
|
||||
```haskell
|
||||
selectBackendWithCircuitBreaker :: BackendPool -> IO (Maybe Backend)
|
||||
selectBackendWithCircuitBreaker pool = do
|
||||
healthy <- getHealthyBackends pool
|
||||
available <- filterM isCircuitBreakerClosed healthy
|
||||
case available of
|
||||
[] -> return Nothing
|
||||
backends -> Just <$> selectFromPool backends
|
||||
```
|
||||
|
||||
### Exponential backoff for failed backends
|
||||
|
||||
**Implement jittered exponential backoff** to avoid thundering herd when backends recover:
|
||||
|
||||
```haskell
|
||||
import System.Random (randomRIO)
|
||||
|
||||
data BackoffConfig = BackoffConfig
|
||||
{ initialDelay :: Int -- microseconds
|
||||
, maxDelay :: Int
|
||||
, maxRetries :: Int
|
||||
}
|
||||
|
||||
exponentialBackoffWithJitter :: BackoffConfig -> IO a -> IO (Maybe a)
|
||||
exponentialBackoffWithJitter config action = go 0 (initialDelay config)
|
||||
where
|
||||
go retries delay
|
||||
| retries >= maxRetries config = return Nothing
|
||||
| otherwise = do
|
||||
result <- try action
|
||||
case result of
|
||||
Right val -> return (Just val)
|
||||
Left (_ :: SomeException) -> do
|
||||
-- Add jitter: random value up to 50% of delay
|
||||
jitter <- randomRIO (0, delay `div` 2)
|
||||
threadDelay (delay + jitter)
|
||||
let nextDelay = min (delay * 2) (maxDelay config)
|
||||
go (retries + 1) nextDelay
|
||||
```
|
||||
|
||||
**Jitter is critical** - without it, all failed requests retry simultaneously, creating load spikes. With jitter, retries spread over time.
|
||||
|
||||
**Alternative: Use the `retry` package** (Hackage, widely adopted):
|
||||
|
||||
```haskell
|
||||
import Control.Retry
|
||||
|
||||
recovering
|
||||
(exponentialBackoff 50000 <> limitRetries 5)
|
||||
[const $ Handler $ \e -> return (isRetryable e)]
|
||||
(\_ -> performHealthCheck backend)
|
||||
```
|
||||
|
||||
The `retry` package uses **Monoid composition** for retry policies - combine `exponentialBackoff`, `limitRetries`, and `capDelay` to build complex policies declaratively.
|
||||
|
||||
## Integration with Warp and WAI
|
||||
|
||||
Warp is the **highest-performance Haskell web server**, achieving throughput comparable to nginx (~50,000-80,000 req/s single-threaded, scaling linearly to 8+ workers). Integration with load balancing leverages WAI middleware and reverse proxy libraries.
|
||||
|
||||
### Using http-reverse-proxy
|
||||
|
||||
**Two approaches**: raw socket (minimal overhead) and WAI-based (full feature set). For load balancing, **use the WAI approach** for request modification and middleware composition:
|
||||
|
||||
```haskell
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.HTTP.ReverseProxy
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Control.Concurrent.STM
|
||||
|
||||
data ProxyConfig = ProxyConfig
|
||||
{ pcBackends :: TVar [Backend]
|
||||
, pcManager :: Manager
|
||||
, pcBalancer :: LoadBalancer
|
||||
}
|
||||
|
||||
proxyApp :: ProxyConfig -> Application
|
||||
proxyApp config req respond = do
|
||||
mBackend <- selectHealthyBackend (pcBalancer config)
|
||||
case mBackend of
|
||||
Nothing ->
|
||||
respond $ responseLBS status503 [] "No healthy backends available"
|
||||
Just backend ->
|
||||
waiProxyTo
|
||||
(\_ -> return $ WPRProxyDest (ProxyDest
|
||||
(backendHost backend)
|
||||
(backendPort backend)))
|
||||
defaultOnExc
|
||||
(pcManager config)
|
||||
req
|
||||
respond
|
||||
```
|
||||
|
||||
**Key functions**:
|
||||
- `waiProxyTo`: Full request/response control
|
||||
- `WPRProxyDest`: Route to specific backend
|
||||
- `WPRModifiedRequest`: Modify request before proxying
|
||||
- `defaultOnExc`: Exception handler
|
||||
|
||||
**WebSocket support**: Use `waiProxyToSettings` with `wpsUpgradeToRaw = True` for WebSocket tunneling.
|
||||
|
||||
### Middleware for request routing
|
||||
|
||||
Middleware composes via function application. **Build a middleware stack** for logging, authentication, and routing:
|
||||
|
||||
```haskell
|
||||
import Network.Wai (Middleware, mapResponseHeaders)
|
||||
|
||||
-- Add load balancer info header
|
||||
addBackendHeader :: Backend -> Middleware
|
||||
addBackendHeader backend app req respond =
|
||||
app req $ respond . mapResponseHeaders
|
||||
((hBackend, encodeUtf8 $ backendId backend) :)
|
||||
|
||||
-- Connection tracking middleware
|
||||
trackingMiddleware :: ServerMetrics -> Middleware
|
||||
trackingMiddleware metrics app req respond = do
|
||||
atomically $ modifyTVar' (activeConnections metrics) (+1)
|
||||
atomically $ modifyTVar' (totalRequests metrics) (+1)
|
||||
|
||||
let respond' res = do
|
||||
atomically $ modifyTVar' (activeConnections metrics) (subtract 1)
|
||||
respond res
|
||||
|
||||
app req respond' `onException`
|
||||
atomically (modifyTVar' (errorCount metrics) (+1))
|
||||
|
||||
-- Compose middleware
|
||||
main = do
|
||||
config <- initProxyConfig
|
||||
let app = trackingMiddleware metrics
|
||||
$ proxyApp config
|
||||
run 8000 app
|
||||
```
|
||||
|
||||
### Performance optimization for 100k+ req/s
|
||||
|
||||
**Warp architecture** uses lightweight green threads (100,000+ possible) with one thread per connection. The GHC I/O manager provides non-blocking I/O via epoll/kqueue. Key optimizations:
|
||||
|
||||
1. **Minimize system calls**: Warp uses only `recv()`, `send()`, and `sendfile()`. Eliminate `open()`/`stat()`/`close()` via file descriptor caching.
|
||||
|
||||
2. **Specialize hot paths**: Use custom HTTP response composer instead of generic Builder. Cache date strings (regenerate once per second).
|
||||
|
||||
3. **Avoid locks**: Use lock-free atomic operations (`atomicModifyIORef`) instead of MVar spin locks. Warp's timeout manager uses double-IORef for lock-free status updates.
|
||||
|
||||
4. **Proper data structures**: ByteString for buffers (enables zero-copy splicing), Vector for backend lists (O(1) indexing).
|
||||
|
||||
**Compile-time optimizations**:
|
||||
|
||||
```cabal
|
||||
ghc-options: -Wall -O2 -threaded
|
||||
-rtsopts -with-rtsopts=-N
|
||||
-fspec-constr -fspecialise
|
||||
-funbox-strict-fields
|
||||
```
|
||||
|
||||
**Runtime settings**:
|
||||
|
||||
```bash
|
||||
./proxy +RTS -N -A64m -I0 -qg
|
||||
```
|
||||
|
||||
- `-N`: Use all CPU cores
|
||||
- `-A64m`: Large allocation area (fewer GCs)
|
||||
- `-I0`: Disable idle GC
|
||||
- `-qg`: Parallel GC
|
||||
|
||||
**Benchmarking**: Historical data shows **Mighty (Warp-based) achieved 50,000 req/s single-threaded**, scaling linearly to 8 workers. Modern Warp (2024-2025) includes further optimizations. Use `weighttp` or `wrk` for multi-threaded load testing.
|
||||
|
||||
### HTTP client connection pooling
|
||||
|
||||
**Manager configuration is critical** for backend connections:
|
||||
|
||||
```haskell
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Client.TLS
|
||||
|
||||
manager <- newManager $ defaultManagerSettings
|
||||
{ managerConnCount = 1000 -- Max connections per backend
|
||||
, managerIdleConnectionCount = 500 -- Idle connections to keep
|
||||
, managerResponseTimeout = responseTimeoutMicro 60000000
|
||||
}
|
||||
```
|
||||
|
||||
**Connection pooling impact**: Without pooling, each request establishes a new TCP connection (expensive handshake, especially for TLS). With pooling, **10-100x faster** for repeated requests to the same backend.
|
||||
|
||||
**Pool configuration guidelines**:
|
||||
- `managerConnCount`: Set to 500-5000 per backend based on capacity
|
||||
- `managerIdleConnectionCount`: Keep 50-80% of max connections idle
|
||||
- Share single Manager across application (thread-safe)
|
||||
|
||||
## Production implementation blueprint
|
||||
|
||||
Combining all patterns into a **production-ready architecture** for Milestone 1.3:
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module LoadBalancer where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.HTTP.ReverseProxy
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import qualified Data.Vector as V
|
||||
|
||||
-- Core data types
|
||||
data Backend = Backend
|
||||
{ backendId :: Int
|
||||
, backendHost :: ByteString
|
||||
, backendPort :: Int
|
||||
, backendWeight :: Int
|
||||
, currentWeight :: TVar Int
|
||||
, activeConns :: TVar Int
|
||||
, state :: TVar BackendState
|
||||
, failures :: TVar Int
|
||||
}
|
||||
|
||||
data BackendState = Healthy | Unhealthy | Recovering
|
||||
|
||||
data Strategy = RoundRobin | LeastConnections | SmoothWeightedRR
|
||||
|
||||
data ProxyConfig = ProxyConfig
|
||||
{ backends :: V.Vector Backend
|
||||
, strategy :: Strategy
|
||||
, healthChecker :: Async ()
|
||||
, httpManager :: Manager
|
||||
, rrCounter :: IORef Int
|
||||
}
|
||||
|
||||
-- Backend selection dispatcher
|
||||
selectBackend :: ProxyConfig -> IO (Maybe Backend)
|
||||
selectBackend config =
|
||||
case strategy config of
|
||||
RoundRobin -> selectRoundRobin config
|
||||
LeastConnections -> selectLeastConnections config
|
||||
SmoothWeightedRR -> selectWeightedRR config
|
||||
|
||||
-- Round-robin implementation
|
||||
selectRoundRobin :: ProxyConfig -> IO (Maybe Backend)
|
||||
selectRoundRobin config = do
|
||||
let backends' = backends config
|
||||
len = V.length backends'
|
||||
idx <- atomicModifyIORef' (rrCounter config) $ \i ->
|
||||
((i + 1) `mod` len, i)
|
||||
|
||||
-- Find next healthy backend
|
||||
findHealthy backends' idx len
|
||||
where
|
||||
findHealthy backends' start remaining
|
||||
| remaining <= 0 = return Nothing
|
||||
| otherwise = do
|
||||
let backend = backends' V.! start
|
||||
isHealthy <- atomically $ (== Healthy) <$> readTVar (state backend)
|
||||
if isHealthy
|
||||
then return (Just backend)
|
||||
else findHealthy backends'
|
||||
((start + 1) `mod` V.length backends')
|
||||
(remaining - 1)
|
||||
|
||||
-- Least connections implementation
|
||||
selectLeastConnections :: ProxyConfig -> IO (Maybe Backend)
|
||||
selectLeastConnections config = do
|
||||
let backends' = V.toList (backends config)
|
||||
healthy <- filterM isHealthy backends'
|
||||
case healthy of
|
||||
[] -> return Nothing
|
||||
bs -> do
|
||||
conns <- forM bs $ \b -> do
|
||||
count <- atomically $ readTVar (activeConns b)
|
||||
return (count, b)
|
||||
return $ Just $ snd $ minimum conns
|
||||
where
|
||||
isHealthy b = atomically $ (== Healthy) <$> readTVar (state b)
|
||||
|
||||
-- Smooth weighted round-robin
|
||||
selectWeightedRR :: ProxyConfig -> IO (Maybe Backend)
|
||||
selectWeightedRR config = atomically $ do
|
||||
let backends' = V.toList (backends config)
|
||||
|
||||
-- Increase current weights
|
||||
forM_ backends' $ \wb ->
|
||||
modifyTVar' (currentWeight wb) (+ backendWeight wb)
|
||||
|
||||
-- Select backend with max current weight
|
||||
weights <- mapM (readTVar . currentWeight) backends'
|
||||
let maxWeight = maximum weights
|
||||
selected = backends' !! fromJust (findIndex (== maxWeight) weights)
|
||||
|
||||
-- Check health
|
||||
isHealthy <- (== Healthy) <$> readTVar (state selected)
|
||||
guard isHealthy
|
||||
|
||||
-- Reduce selected backend's current weight
|
||||
let totalWeight = sum (map backendWeight backends')
|
||||
modifyTVar' (currentWeight selected) (subtract totalWeight)
|
||||
|
||||
return selected
|
||||
|
||||
-- Main proxy application
|
||||
proxyApp :: ProxyConfig -> Application
|
||||
proxyApp config req respond = do
|
||||
mBackend <- selectBackend config
|
||||
case mBackend of
|
||||
Nothing ->
|
||||
respond $ responseLBS status503 [] "No healthy backends"
|
||||
Just backend -> do
|
||||
-- Track connection
|
||||
atomically $ modifyTVar' (activeConns backend) (+1)
|
||||
|
||||
let dest = ProxyDest (backendHost backend) (backendPort backend)
|
||||
respond' res = do
|
||||
atomically $ modifyTVar' (activeConns backend) (subtract 1)
|
||||
respond res
|
||||
|
||||
waiProxyTo
|
||||
(\_ -> return $ WPRProxyDest dest)
|
||||
defaultOnExc
|
||||
(httpManager config)
|
||||
req
|
||||
respond'
|
||||
|
||||
-- Health checker (runs asynchronously)
|
||||
healthCheckLoop :: Manager -> [Backend] -> IO ()
|
||||
healthCheckLoop manager backends = forever $ do
|
||||
results <- mapConcurrently (checkHealth manager) backends
|
||||
zipWithM_ updateHealth backends results
|
||||
threadDelay 10000000 -- 10 seconds
|
||||
where
|
||||
checkHealth mgr backend = do
|
||||
let url = "http://" <> backendHost backend <> ":"
|
||||
<> show (backendPort backend) <> "/health"
|
||||
result <- timeout 2000000 $ do
|
||||
req <- parseRequest (unpack url)
|
||||
response <- httpLbs req mgr
|
||||
return $ statusCode (responseStatus response) == 200
|
||||
return $ fromMaybe False result
|
||||
|
||||
updateHealth backend healthy = atomically $ do
|
||||
currentState <- readTVar (state backend)
|
||||
failureCount <- readTVar (failures backend)
|
||||
case (currentState, healthy) of
|
||||
(Healthy, False) -> do
|
||||
let newFailures = failureCount + 1
|
||||
writeTVar (failures backend) newFailures
|
||||
when (newFailures >= 3) $ do
|
||||
writeTVar (state backend) Unhealthy
|
||||
writeTVar (failures backend) 0
|
||||
(Unhealthy, True) ->
|
||||
writeTVar (state backend) Recovering
|
||||
(Recovering, True) ->
|
||||
writeTVar (state backend) Healthy
|
||||
_ -> return ()
|
||||
|
||||
-- Initialization
|
||||
initProxyConfig :: [BackendSpec] -> Strategy -> IO ProxyConfig
|
||||
initProxyConfig specs strat = do
|
||||
backends <- V.fromList <$> mapM createBackend (zip [0..] specs)
|
||||
manager <- newTlsManager
|
||||
counter <- newIORef 0
|
||||
checker <- async $ healthCheckLoop manager (V.toList backends)
|
||||
|
||||
return ProxyConfig
|
||||
{ backends = backends
|
||||
, strategy = strat
|
||||
, healthChecker = checker
|
||||
, httpManager = manager
|
||||
, rrCounter = counter
|
||||
}
|
||||
where
|
||||
createBackend (idx, spec) = Backend idx
|
||||
<$> pure (bsHost spec)
|
||||
<*> pure (bsPort spec)
|
||||
<*> pure (bsWeight spec)
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO 0
|
||||
<*> newTVarIO Healthy
|
||||
<*> newTVarIO 0
|
||||
|
||||
-- Main entry point
|
||||
main :: IO ()
|
||||
main = do
|
||||
let backendSpecs =
|
||||
[ BackendSpec "localhost" 8001 5
|
||||
, BackendSpec "localhost" 8002 1
|
||||
, BackendSpec "localhost" 8003 1
|
||||
]
|
||||
|
||||
config <- initProxyConfig backendSpecs SmoothWeightedRR
|
||||
|
||||
let settings = setPort 8000
|
||||
$ setTimeout 30
|
||||
$ defaultSettings
|
||||
|
||||
putStrLn "Load balancing proxy started on port 8000"
|
||||
runSettings settings (proxyApp config)
|
||||
```
|
||||
|
||||
## Library recommendations with versions
|
||||
|
||||
**Core infrastructure** (2024-2025 ecosystem):
|
||||
|
||||
- **warp** (3.3+): High-performance HTTP server - `ghc-options: -threaded`
|
||||
- **http-reverse-proxy** (0.6+): Reverse proxy primitives, WebSocket support
|
||||
- **http-client** (0.7+): HTTP client with connection pooling
|
||||
- **http-client-tls** (0.3+): TLS support via Haskell-native `tls` package
|
||||
|
||||
**Load balancing utilities**:
|
||||
|
||||
- **load-balancing** (1.0.1.1): Least-connections with round-robin tie-breaking
|
||||
- **roundRobin** (0.1.2.0): Simple round-robin selection
|
||||
- **resource-pool** (0.4+): Striped connection pooling (used by Yesod)
|
||||
|
||||
**Resilience libraries**:
|
||||
|
||||
- **retry** (0.9+): Exponential backoff and retry policies (Monoid-composable)
|
||||
- **circuit-breaker** (0.1+): Type-level circuit breakers with automatic backoff
|
||||
- **stamina** (0.2+): Modern "retries for humans" with Retry-After support
|
||||
|
||||
**Async \u0026 concurrency**:
|
||||
|
||||
- **async** (2.2+): Safe concurrent operations - use `withAsync` for automatic cleanup
|
||||
- **stm** (2.5+): Software Transactional Memory
|
||||
- **async-timer** (0.3+): Periodic timer execution
|
||||
|
||||
## Common pitfalls and solutions
|
||||
|
||||
**STM starvation**: Long transactions vulnerable to repeated aborts by short transactions. **Solution**: Keep transactions under 10 TVars, move pure computation outside `atomically`.
|
||||
|
||||
**Memory allocation bottlenecks**: GHC takes global lock for objects >409 bytes. **Solution**: Pool and reuse buffers. Configure larger allocation area (`+RTS -A64m`).
|
||||
|
||||
**Thundering herd**: All workers wake on new connection. **Solution**: Use prefork (multiple processes) instead of `-N` threading, or wait for parallel I/O manager integration.
|
||||
|
||||
**Health check storms**: All checks start simultaneously after deployment. **Solution**: Add random initial delay: `threadDelay =<< randomRIO (0, hcInterval config * 1000000)`.
|
||||
|
||||
**Circuit breaker cascades**: One slow backend causes all circuits to open. **Solution**: Implement per-backend circuit breakers with independent thresholds.
|
||||
|
||||
**Connection pool exhaustion**: Backends slow down, pool fills up. **Solution**: Set `managerIdleConnectionCount` conservatively (50-80% of max), implement connection timeout validation.
|
||||
|
||||
**WebSocket routing fails**: Standard proxy doesn't upgrade connections. **Solution**: Use `waiProxyToSettings` with `wpsUpgradeToRaw = True` for WebSocket support.
|
||||
|
||||
## Testing and validation strategies
|
||||
|
||||
**Property-based testing** with QuickCheck:
|
||||
|
||||
```haskell
|
||||
prop_roundRobinFairness :: [Backend] -> Property
|
||||
prop_roundRobinFairness backends =
|
||||
length backends > 0 ==> monadicIO $ do
|
||||
let selections = replicateM (length backends * 100) (selectBackend balancer)
|
||||
distribution <- run $ countSelections <$> selections
|
||||
assert $ all (\count -> count >= 90 && count <= 110) distribution
|
||||
```
|
||||
|
||||
**Concurrency testing** with dejafu:
|
||||
|
||||
```haskell
|
||||
import Test.DejaFu
|
||||
|
||||
testNoDeadlock :: IO ()
|
||||
testNoDeadlock = autocheck $ do
|
||||
balancer <- setup
|
||||
concurrently_
|
||||
(selectBackend balancer)
|
||||
(selectBackend balancer)
|
||||
```
|
||||
|
||||
**Load testing**: Use `wrk` for HTTP benchmarking:
|
||||
|
||||
```bash
|
||||
wrk -t12 -c400 -d30s http://localhost:8000/
|
||||
```
|
||||
|
||||
**Metrics collection**: Integrate `ekg` for real-time monitoring:
|
||||
|
||||
```haskell
|
||||
import System.Remote.Monitoring
|
||||
|
||||
main = do
|
||||
forkServer "localhost" 8081 -- Metrics dashboard
|
||||
store <- getStore
|
||||
registerGauge "active_connections" (readTVarIO activeConns) store
|
||||
```
|
||||
|
||||
This comprehensive implementation guide provides **production-ready patterns** for building a high-performance, type-safe reverse proxy in Haskell. The architecture balances functional purity with pragmatic performance optimization, leveraging Haskell's concurrency primitives to achieve 100k+ req/s throughput while maintaining composability and correctness guarantees.
|
||||
|
|
@ -0,0 +1,276 @@
|
|||
# TLS Testing Guide for Ᾰenebris
|
||||
|
||||
This document describes how to test all TLS/SSL features in Ᾰenebris.
|
||||
|
||||
## Prerequisites
|
||||
|
||||
1. Generate test certificates:
|
||||
```bash
|
||||
./examples/generate-test-certs.sh
|
||||
```
|
||||
|
||||
2. Start test backend servers:
|
||||
```bash
|
||||
# Terminal 1: Main backend on port 8000
|
||||
python examples/test_backend_multi.py 8000
|
||||
|
||||
# Terminal 2 (for SNI testing): API backend on port 8001
|
||||
python examples/test_backend_multi.py 8001
|
||||
|
||||
# Terminal 3 (for SNI testing): Web backend on port 8002
|
||||
python examples/test_backend_multi.py 8002
|
||||
```
|
||||
|
||||
## Test 1: Single Certificate HTTPS
|
||||
|
||||
**Config:** `examples/config-https.yaml`
|
||||
|
||||
**Start proxy:**
|
||||
```bash
|
||||
./aenebris examples/config-https.yaml
|
||||
```
|
||||
|
||||
**Tests:**
|
||||
|
||||
### Test HTTP → HTTPS Redirect
|
||||
```bash
|
||||
# Should return 301 redirect to HTTPS
|
||||
curl -v http://localhost:8080/
|
||||
|
||||
# Expected: Location: https://localhost:8080/
|
||||
```
|
||||
|
||||
### Test HTTPS Connection
|
||||
```bash
|
||||
# Make HTTPS request (-k ignores self-signed cert)
|
||||
curl -k https://localhost:8443/
|
||||
|
||||
# Expected: Response from backend server
|
||||
```
|
||||
|
||||
### Test TLS 1.3
|
||||
```bash
|
||||
# Verify TLS 1.3 is available
|
||||
openssl s_client -connect localhost:8443 -tls1_3
|
||||
|
||||
# Expected: Should succeed with "Protocol : TLSv1.3"
|
||||
```
|
||||
|
||||
### Test TLS 1.2
|
||||
```bash
|
||||
# Verify TLS 1.2 is also supported
|
||||
openssl s_client -connect localhost:8443 -tls1_2
|
||||
|
||||
# Expected: Should succeed with "Protocol : TLSv1.2"
|
||||
```
|
||||
|
||||
### Test TLS 1.1 Rejected
|
||||
```bash
|
||||
# Verify old TLS is rejected
|
||||
openssl s_client -connect localhost:8443 -tls1_1 2>&1 | grep -i "error\|alert"
|
||||
|
||||
# Expected: Should fail with "no protocols available" or similar
|
||||
```
|
||||
|
||||
### Test Security Headers
|
||||
```bash
|
||||
# Check security headers are present
|
||||
curl -k -I https://localhost:8443/
|
||||
|
||||
# Expected headers:
|
||||
# - Strict-Transport-Security: max-age=2592000; includeSubDomains
|
||||
# - Content-Security-Policy: default-src 'self'; ...
|
||||
# - X-Frame-Options: DENY
|
||||
# - X-Content-Type-Options: nosniff
|
||||
# - Referrer-Policy: strict-origin-when-cross-origin
|
||||
# - Permissions-Policy: geolocation=(), ...
|
||||
# - Expect-CT: max-age=86400, enforce
|
||||
# - Server: Aenebris
|
||||
```
|
||||
|
||||
### Test HTTP/2
|
||||
```bash
|
||||
# Verify HTTP/2 is negotiated via ALPN
|
||||
curl -k --http2 -v https://localhost:8443/ 2>&1 | grep "ALPN"
|
||||
|
||||
# Expected: "ALPN, server accepted to use h2"
|
||||
```
|
||||
|
||||
### Test Cipher Suites
|
||||
```bash
|
||||
# List negotiated cipher suite
|
||||
openssl s_client -connect localhost:8443 -tls1_3 2>&1 | grep "Cipher"
|
||||
|
||||
# Expected: Strong cipher like:
|
||||
# - TLS_AES_128_GCM_SHA256
|
||||
# - TLS_AES_256_GCM_SHA384
|
||||
# - TLS_CHACHA20_POLY1305_SHA256
|
||||
```
|
||||
|
||||
## Test 2: SNI (Server Name Indication)
|
||||
|
||||
**Config:** `examples/config-sni.yaml`
|
||||
|
||||
**Start proxy:**
|
||||
```bash
|
||||
./aenebris examples/config-sni.yaml
|
||||
```
|
||||
|
||||
**Tests:**
|
||||
|
||||
### Test SNI for api.localhost
|
||||
```bash
|
||||
# Request with Host: api.localhost
|
||||
curl -k -H "Host: api.localhost" https://localhost:8443/
|
||||
|
||||
# Verify correct certificate
|
||||
openssl s_client -connect localhost:8443 -servername api.localhost 2>&1 | grep "subject"
|
||||
|
||||
# Expected: subject=CN = api.localhost
|
||||
```
|
||||
|
||||
### Test SNI for web.localhost
|
||||
```bash
|
||||
# Request with Host: web.localhost
|
||||
curl -k -H "Host: web.localhost" https://localhost:8443/
|
||||
|
||||
# Verify correct certificate
|
||||
openssl s_client -connect localhost:8443 -servername web.localhost 2>&1 | grep "subject"
|
||||
|
||||
# Expected: subject=CN = web.localhost
|
||||
```
|
||||
|
||||
### Test Default Certificate
|
||||
```bash
|
||||
# Request with unknown hostname
|
||||
curl -k -H "Host: unknown.localhost" https://localhost:8443/
|
||||
|
||||
# Verify default certificate is used
|
||||
openssl s_client -connect localhost:8443 -servername unknown.localhost 2>&1 | grep "subject"
|
||||
|
||||
# Expected: subject=CN = default.localhost
|
||||
```
|
||||
|
||||
### Test SNI Routing
|
||||
```bash
|
||||
# Verify api.localhost routes to port 8001 backend
|
||||
curl -k -H "Host: api.localhost" https://localhost:8443/
|
||||
|
||||
# Verify web.localhost routes to port 8002 backend
|
||||
curl -k -H "Host: web.localhost" https://localhost:8443/
|
||||
|
||||
# Check backend logs to confirm correct routing
|
||||
```
|
||||
|
||||
## Test 3: Security Validation
|
||||
|
||||
### Test Strong Ciphers Only
|
||||
```bash
|
||||
# Try to connect with weak cipher (should fail)
|
||||
openssl s_client -connect localhost:8443 -cipher DES-CBC3-SHA 2>&1 | grep -i "error\|alert"
|
||||
|
||||
# Expected: Connection should fail, 3DES not allowed
|
||||
```
|
||||
|
||||
### Test HSTS Enforcement
|
||||
```bash
|
||||
# Check HSTS header prevents downgrade
|
||||
curl -k -I https://localhost:8443/ | grep -i "strict-transport"
|
||||
|
||||
# Expected: Strict-Transport-Security: max-age=2592000; includeSubDomains
|
||||
```
|
||||
|
||||
### Test X-Powered-By Removal
|
||||
```bash
|
||||
# Verify X-Powered-By is stripped
|
||||
curl -k -I https://localhost:8443/ | grep -i "powered-by"
|
||||
|
||||
# Expected: No X-Powered-By header present
|
||||
```
|
||||
|
||||
### Test Server Header Customization
|
||||
```bash
|
||||
# Check Server header
|
||||
curl -k -I https://localhost:8443/ | grep -i "server:"
|
||||
|
||||
# Expected: Server: Aenebris (not revealing version)
|
||||
```
|
||||
|
||||
## Test 4: Performance
|
||||
|
||||
### Test Connection Reuse
|
||||
```bash
|
||||
# Make multiple requests with keep-alive
|
||||
for i in {1..10}; do
|
||||
curl -k -s -o /dev/null -w "Time: %{time_total}s\n" https://localhost:8443/
|
||||
done
|
||||
|
||||
# Expected: First request slower (handshake), subsequent faster (reuse)
|
||||
```
|
||||
|
||||
### Test Concurrent Connections
|
||||
```bash
|
||||
# Benchmark with multiple concurrent connections
|
||||
# Using 'hey' tool (install: go install github.com/rakyll/hey@latest)
|
||||
hey -n 1000 -c 10 -disable-keepalive https://localhost:8443/
|
||||
|
||||
# Or using Apache Bench:
|
||||
ab -n 1000 -c 10 -k https://localhost:8443/
|
||||
|
||||
# Expected: Should handle concurrent requests without errors
|
||||
```
|
||||
|
||||
## Test 5: Error Handling
|
||||
|
||||
### Test Invalid Certificate Path
|
||||
Edit config with invalid cert path, should see clear error:
|
||||
```yaml
|
||||
tls:
|
||||
cert: /nonexistent/cert.pem
|
||||
key: /nonexistent/key.pem
|
||||
```
|
||||
|
||||
**Expected:**
|
||||
```
|
||||
ERROR: Failed to load TLS certificate
|
||||
CertFileNotFound "/nonexistent/cert.pem"
|
||||
```
|
||||
|
||||
### Test Mismatched Cert/Key
|
||||
Use wrong key for certificate, should fail gracefully with clear error.
|
||||
|
||||
### Test Missing SNI Default
|
||||
Remove `default_cert` from SNI config, should fail validation:
|
||||
```
|
||||
SNI configuration error: sni, default_cert, and default_key required
|
||||
```
|
||||
|
||||
## Success Criteria
|
||||
|
||||
✅ All tests pass
|
||||
✅ TLS 1.2 and TLS 1.3 work
|
||||
✅ TLS 1.0/1.1 rejected
|
||||
✅ HTTP → HTTPS redirect works
|
||||
✅ SNI correctly routes to different backends
|
||||
✅ Strong ciphers only
|
||||
✅ All security headers present
|
||||
✅ HTTP/2 negotiated via ALPN
|
||||
✅ No X-Powered-By leakage
|
||||
✅ Clear error messages for misconfigurations
|
||||
|
||||
## SSL Labs Testing (Optional)
|
||||
|
||||
For production deployments, test with SSL Labs:
|
||||
|
||||
1. Deploy to public server with real domain
|
||||
2. Visit https://www.ssllabs.com/ssltest/
|
||||
3. Enter your domain
|
||||
4. **Target: A+ rating**
|
||||
|
||||
Key requirements for A+:
|
||||
- TLS 1.2 minimum
|
||||
- Strong cipher suites
|
||||
- HSTS with long max-age
|
||||
- No vulnerabilities (BEAST, POODLE, Heartbleed, etc.)
|
||||
- Perfect Forward Secrecy
|
||||
- HTTP Strict Transport Security
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
version: 1
|
||||
|
||||
# HTTPS with single certificate + HTTP redirect
|
||||
listen:
|
||||
- port: 8080 # HTTP with redirect
|
||||
redirect_https: true
|
||||
|
||||
- port: 8443 # HTTPS
|
||||
tls:
|
||||
cert: examples/certs/localhost.crt
|
||||
key: examples/certs/localhost.key
|
||||
|
||||
upstreams:
|
||||
- name: test-backend
|
||||
servers:
|
||||
- host: "127.0.0.1:8000"
|
||||
weight: 1
|
||||
health_check:
|
||||
path: /health
|
||||
interval: 10s
|
||||
|
||||
routes:
|
||||
- host: "localhost"
|
||||
paths:
|
||||
- path: /
|
||||
upstream: test-backend
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
# Ᾰenebris Load Balancing Test Configuration
|
||||
# This config tests all 3 load balancing algorithms
|
||||
|
||||
version: 1
|
||||
|
||||
# Listen on port 8081
|
||||
listen:
|
||||
- port: 8081
|
||||
|
||||
# Multiple backends for testing load balancing
|
||||
upstreams:
|
||||
- name: round-robin-backend
|
||||
servers:
|
||||
- host: "127.0.0.1:8000"
|
||||
weight: 1
|
||||
- host: "127.0.0.1:8001"
|
||||
weight: 1
|
||||
- host: "127.0.0.1:8002"
|
||||
weight: 1
|
||||
health_check:
|
||||
path: /health
|
||||
interval: 10s
|
||||
|
||||
- name: weighted-backend
|
||||
servers:
|
||||
- host: "127.0.0.1:8000"
|
||||
weight: 5 # 5x more traffic
|
||||
- host: "127.0.0.1:8001"
|
||||
weight: 1
|
||||
- host: "127.0.0.1:8002"
|
||||
weight: 1
|
||||
health_check:
|
||||
path: /health
|
||||
interval: 10s
|
||||
|
||||
# Routes
|
||||
routes:
|
||||
- host: "localhost"
|
||||
paths:
|
||||
- path: /
|
||||
upstream: round-robin-backend
|
||||
|
||||
- path: /weighted
|
||||
upstream: weighted-backend
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
version: 1
|
||||
|
||||
# HTTPS with SNI (multiple certificates for different domains)
|
||||
listen:
|
||||
- port: 8080 # HTTP with redirect
|
||||
redirect_https: true
|
||||
|
||||
- port: 8443 # HTTPS with SNI
|
||||
tls:
|
||||
sni:
|
||||
- domain: "api.localhost"
|
||||
cert: examples/certs/api.localhost.crt
|
||||
key: examples/certs/api.localhost.key
|
||||
- domain: "web.localhost"
|
||||
cert: examples/certs/web.localhost.crt
|
||||
key: examples/certs/web.localhost.key
|
||||
default_cert: examples/certs/default.crt
|
||||
default_key: examples/certs/default.key
|
||||
|
||||
upstreams:
|
||||
- name: api-backend
|
||||
servers:
|
||||
- host: "127.0.0.1:8001"
|
||||
weight: 1
|
||||
|
||||
- name: web-backend
|
||||
servers:
|
||||
- host: "127.0.0.1:8002"
|
||||
weight: 1
|
||||
|
||||
routes:
|
||||
- host: "api.localhost"
|
||||
paths:
|
||||
- path: /
|
||||
upstream: api-backend
|
||||
|
||||
- host: "web.localhost"
|
||||
paths:
|
||||
- path: /
|
||||
upstream: web-backend
|
||||
|
|
@ -5,7 +5,7 @@ version: 1
|
|||
|
||||
# Listen ports
|
||||
listen:
|
||||
- port: 8080
|
||||
- port: 8081
|
||||
# TLS configuration (optional)
|
||||
# tls:
|
||||
# cert: /path/to/cert.pem
|
||||
|
|
|
|||
|
|
@ -0,0 +1,53 @@
|
|||
#!/bin/bash
|
||||
|
||||
# Generate self-signed certificates for testing Ᾰenebris TLS
|
||||
|
||||
set -e
|
||||
|
||||
echo "Generating test certificates for Ᾰenebris..."
|
||||
|
||||
# Create certs directory if it doesn't exist
|
||||
mkdir -p examples/certs
|
||||
|
||||
# Generate single certificate for localhost
|
||||
echo "→ Generating single certificate for localhost..."
|
||||
openssl req -x509 -newkey rsa:2048 -nodes \
|
||||
-keyout examples/certs/localhost.key \
|
||||
-out examples/certs/localhost.crt \
|
||||
-days 365 \
|
||||
-subj "/CN=localhost/O=Aenebris Test/C=US"
|
||||
|
||||
# Generate SNI certificate for api.localhost
|
||||
echo "→ Generating SNI certificate for api.localhost..."
|
||||
openssl req -x509 -newkey rsa:2048 -nodes \
|
||||
-keyout examples/certs/api.localhost.key \
|
||||
-out examples/certs/api.localhost.crt \
|
||||
-days 365 \
|
||||
-subj "/CN=api.localhost/O=Aenebris Test/C=US"
|
||||
|
||||
# Generate SNI certificate for web.localhost
|
||||
echo "→ Generating SNI certificate for web.localhost..."
|
||||
openssl req -x509 -newkey rsa:2048 -nodes \
|
||||
-keyout examples/certs/web.localhost.key \
|
||||
-out examples/certs/web.localhost.crt \
|
||||
-days 365 \
|
||||
-subj "/CN=web.localhost/O=Aenebris Test/C=US"
|
||||
|
||||
# Generate default SNI certificate
|
||||
echo "→ Generating default SNI certificate..."
|
||||
openssl req -x509 -newkey rsa:2048 -nodes \
|
||||
-keyout examples/certs/default.key \
|
||||
-out examples/certs/default.crt \
|
||||
-days 365 \
|
||||
-subj "/CN=default.localhost/O=Aenebris Test/C=US"
|
||||
|
||||
echo "✓ All test certificates generated successfully!"
|
||||
echo ""
|
||||
echo "Files created:"
|
||||
echo " examples/certs/localhost.{crt,key} - Single cert for localhost"
|
||||
echo " examples/certs/api.localhost.{crt,key} - SNI cert for api.localhost"
|
||||
echo " examples/certs/web.localhost.{crt,key} - SNI cert for web.localhost"
|
||||
echo " examples/certs/default.{crt,key} - Default SNI cert"
|
||||
echo ""
|
||||
echo "These are self-signed certificates for testing only!"
|
||||
echo "Use curl -k or --insecure to test HTTPS endpoints."
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
#!/bin/bash
|
||||
# Start multiple test backends for load balancing testing
|
||||
|
||||
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
|
||||
# Kill any existing backends
|
||||
pkill -f "test_backend_multi.py" || true
|
||||
|
||||
echo "Starting 3 test backends..."
|
||||
|
||||
# Start backend on port 8000
|
||||
python3 "$SCRIPT_DIR/test_backend_multi.py" 8000 > /tmp/backend-8000.log 2>&1 &
|
||||
echo "Backend 1 started on port 8000 (PID: $!)"
|
||||
|
||||
# Start backend on port 8001
|
||||
python3 "$SCRIPT_DIR/test_backend_multi.py" 8001 > /tmp/backend-8001.log 2>&1 &
|
||||
echo "Backend 2 started on port 8001 (PID: $!)"
|
||||
|
||||
# Start backend on port 8002
|
||||
python3 "$SCRIPT_DIR/test_backend_multi.py" 8002 > /tmp/backend-8002.log 2>&1 &
|
||||
echo "Backend 3 started on port 8002 (PID: $!)"
|
||||
|
||||
echo ""
|
||||
echo "All backends started! Logs in /tmp/backend-*.log"
|
||||
echo "Test health checks:"
|
||||
echo " curl http://localhost:8000/health"
|
||||
echo " curl http://localhost:8001/health"
|
||||
echo " curl http://localhost:8002/health"
|
||||
|
|
@ -5,12 +5,23 @@ Simple test backend for Aenebris proxy
|
|||
|
||||
import json
|
||||
from http.server import (
|
||||
HTTPServer,
|
||||
HTTPServer,
|
||||
BaseHTTPRequestHandler,
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
class TestHandler(BaseHTTPRequestHandler):
|
||||
def do_GET(self):
|
||||
# Health check endpoint
|
||||
if self.path == '/health':
|
||||
self.send_response(200)
|
||||
self.send_header('Content-Type', 'application/json')
|
||||
self.end_headers()
|
||||
response = {'status': 'healthy'}
|
||||
self.wfile.write(json.dumps(response).encode())
|
||||
return
|
||||
|
||||
# Normal request
|
||||
self.send_response(200)
|
||||
self.send_header('Content-Type', 'application/json')
|
||||
self.end_headers()
|
||||
|
|
@ -20,7 +31,7 @@ class TestHandler(BaseHTTPRequestHandler):
|
|||
'path': self.path,
|
||||
'method': 'GET'
|
||||
}
|
||||
self.wfile.write(json.dumps(response, indent=2).encode())
|
||||
self.wfile.write(json.dumps(response, indent = 2).encode())
|
||||
|
||||
def do_POST(self):
|
||||
content_length = int(self.headers.get('Content-Length', 0))
|
||||
|
|
@ -36,11 +47,12 @@ class TestHandler(BaseHTTPRequestHandler):
|
|||
'method': 'POST',
|
||||
'body_length': content_length
|
||||
}
|
||||
self.wfile.write(json.dumps(response, indent=2).encode())
|
||||
self.wfile.write(json.dumps(response, indent = 2).encode())
|
||||
|
||||
def log_message(self, format, *args):
|
||||
print(f"[BACKEND] {format % args}")
|
||||
|
||||
|
||||
if __name__ == '__main__':
|
||||
server = HTTPServer(('localhost', 8000), TestHandler)
|
||||
print('Test backend running on http://localhost:8000')
|
||||
|
|
|
|||
|
|
@ -0,0 +1,70 @@
|
|||
#!/usr/bin/env python3
|
||||
"""
|
||||
Multi-instance test backend for Aenebris proxy load balancing
|
||||
Accepts port number as command-line argument
|
||||
"""
|
||||
|
||||
import json
|
||||
import sys
|
||||
from http.server import (
|
||||
HTTPServer,
|
||||
BaseHTTPRequestHandler,
|
||||
)
|
||||
|
||||
|
||||
class TestHandler(BaseHTTPRequestHandler):
|
||||
def do_GET(self):
|
||||
if self.path == '/health':
|
||||
self.send_response(200)
|
||||
self.send_header('Content-Type', 'application/json')
|
||||
self.end_headers()
|
||||
response = {
|
||||
'status': 'healthy',
|
||||
'port': self.server.server_port
|
||||
}
|
||||
self.wfile.write(json.dumps(response).encode())
|
||||
return
|
||||
|
||||
self.send_response(200)
|
||||
self.send_header('Content-Type', 'application/json')
|
||||
self.end_headers()
|
||||
|
||||
response = {
|
||||
'message':
|
||||
f'Hello from backend on port {self.server.server_port}!',
|
||||
'port': self.server.server_port,
|
||||
'path': self.path,
|
||||
'method': 'GET'
|
||||
}
|
||||
self.wfile.write(json.dumps(response, indent = 2).encode())
|
||||
|
||||
def do_POST(self):
|
||||
content_length = int(self.headers.get('Content-Length', 0))
|
||||
body = self.rfile.read(content_length)
|
||||
|
||||
self.send_response(200)
|
||||
self.send_header('Content-Type', 'application/json')
|
||||
self.end_headers()
|
||||
|
||||
response = {
|
||||
'message': 'Received POST',
|
||||
'port': self.server.server_port,
|
||||
'path': self.path,
|
||||
'method': 'POST',
|
||||
'body_length': content_length
|
||||
}
|
||||
self.wfile.write(json.dumps(response, indent = 2).encode())
|
||||
|
||||
def log_message(self, format, *args):
|
||||
print(f"[BACKEND:{self.server.server_port}] {format % args}")
|
||||
|
||||
|
||||
if __name__ == '__main__':
|
||||
if len(sys.argv) < 2:
|
||||
print("Usage: test_backend_multi.py <port>")
|
||||
sys.exit(1)
|
||||
|
||||
port = int(sys.argv[1])
|
||||
server = HTTPServer(('localhost', port), TestHandler)
|
||||
print(f'Test backend running on http://localhost:{port}')
|
||||
server.serve_forever()
|
||||
|
|
@ -0,0 +1,149 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Aenebris.Backend
|
||||
( BackendState(..)
|
||||
, RuntimeBackend(..)
|
||||
, createRuntimeBackend
|
||||
, isHealthy
|
||||
, trackConnection
|
||||
, getConnectionCount
|
||||
, getCurrentWeight
|
||||
, transitionToUnhealthy
|
||||
, transitionToRecovering
|
||||
, transitionToHealthy
|
||||
, recordFailure
|
||||
, recordSuccess
|
||||
) where
|
||||
|
||||
import Aenebris.Config (Server(..))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (bracket_)
|
||||
import Control.Monad (when)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
|
||||
data BackendState
|
||||
= Healthy
|
||||
| Unhealthy
|
||||
| Recovering
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Runtime backend state wrapping config Server
|
||||
data RuntimeBackend = RuntimeBackend
|
||||
{ rbServerId :: Int -- Unique identifier
|
||||
, rbHost :: Text
|
||||
, rbWeight :: Int
|
||||
-- Runtime state (STM)
|
||||
, rbActiveConnections :: TVar Int
|
||||
, rbCurrentWeight :: TVar Int
|
||||
, rbHealthState :: TVar BackendState
|
||||
, rbConsecutiveFailures :: TVar Int
|
||||
, rbConsecutiveSuccesses :: TVar Int
|
||||
, rbLastHealthCheck :: TVar (Maybe UTCTime)
|
||||
, rbTotalRequests :: TVar Int -- For metrics
|
||||
, rbTotalFailures :: TVar Int -- For metrics
|
||||
}
|
||||
|
||||
instance Show RuntimeBackend where
|
||||
show rb = "RuntimeBackend {id=" ++ show (rbServerId rb) ++
|
||||
", host=" ++ show (rbHost rb) ++ "}"
|
||||
|
||||
instance Eq RuntimeBackend where
|
||||
rb1 == rb2 = rbServerId rb1 == rbServerId rb2
|
||||
|
||||
-- | Runtime backend from config Server
|
||||
createRuntimeBackend :: Int -> Server -> IO RuntimeBackend
|
||||
createRuntimeBackend serverId Server{..} = do
|
||||
atomically $ RuntimeBackend serverId serverHost serverWeight
|
||||
<$> newTVar 0 -- activeConnections
|
||||
<*> newTVar 0 -- currentWeight (for smooth WRR)
|
||||
<*> newTVar Healthy -- healthState
|
||||
<*> newTVar 0 -- consecutiveFailures
|
||||
<*> newTVar 0 -- consecutiveSuccesses
|
||||
<*> newTVar Nothing -- lastHealthCheck
|
||||
<*> newTVar 0 -- totalRequests
|
||||
<*> newTVar 0 -- totalFailures
|
||||
|
||||
-- | Check if backend is healthy
|
||||
isHealthy :: RuntimeBackend -> STM Bool
|
||||
isHealthy rb = (== Healthy) <$> readTVar (rbHealthState rb)
|
||||
|
||||
-- | Track a connection (increment on start, decrement on end)
|
||||
trackConnection :: RuntimeBackend -> IO a -> IO a
|
||||
trackConnection rb action =
|
||||
bracket_
|
||||
(atomically $ do
|
||||
modifyTVar' (rbActiveConnections rb) (+1)
|
||||
modifyTVar' (rbTotalRequests rb) (+1))
|
||||
(atomically $ modifyTVar' (rbActiveConnections rb) (subtract 1))
|
||||
action
|
||||
|
||||
-- | Get current connection count
|
||||
getConnectionCount :: RuntimeBackend -> STM Int
|
||||
getConnectionCount rb = readTVar (rbActiveConnections rb)
|
||||
|
||||
-- | Get current weight (for smooth weighted RR)
|
||||
getCurrentWeight :: RuntimeBackend -> STM Int
|
||||
getCurrentWeight rb = readTVar (rbCurrentWeight rb)
|
||||
|
||||
-- | State transition: mark as unhealthy
|
||||
transitionToUnhealthy :: RuntimeBackend -> STM ()
|
||||
transitionToUnhealthy rb = do
|
||||
writeTVar (rbHealthState rb) Unhealthy
|
||||
writeTVar (rbConsecutiveFailures rb) 0
|
||||
writeTVar (rbConsecutiveSuccesses rb) 0
|
||||
|
||||
-- | State transition: start recovering
|
||||
transitionToRecovering :: RuntimeBackend -> STM ()
|
||||
transitionToRecovering rb = do
|
||||
writeTVar (rbHealthState rb) Recovering
|
||||
writeTVar (rbConsecutiveSuccesses rb) 1
|
||||
|
||||
-- | State transition: mark as healthy
|
||||
transitionToHealthy :: RuntimeBackend -> STM ()
|
||||
transitionToHealthy rb = do
|
||||
writeTVar (rbHealthState rb) Healthy
|
||||
writeTVar (rbConsecutiveFailures rb) 0
|
||||
writeTVar (rbConsecutiveSuccesses rb) 0
|
||||
|
||||
-- | Record a health check failure
|
||||
recordFailure :: RuntimeBackend -> Int -> STM ()
|
||||
recordFailure rb maxFailures = do
|
||||
state <- readTVar (rbHealthState rb)
|
||||
failures <- readTVar (rbConsecutiveFailures rb)
|
||||
|
||||
case state of
|
||||
Healthy -> do
|
||||
let newFailures = failures + 1
|
||||
writeTVar (rbConsecutiveFailures rb) newFailures
|
||||
when (newFailures >= maxFailures) $
|
||||
transitionToUnhealthy rb
|
||||
|
||||
Recovering -> do
|
||||
-- Failed during recovery, back to unhealthy
|
||||
transitionToUnhealthy rb
|
||||
|
||||
Unhealthy ->
|
||||
-- Already unhealthy, just record it
|
||||
modifyTVar' (rbTotalFailures rb) (+1)
|
||||
|
||||
-- | Record a health check success
|
||||
recordSuccess :: RuntimeBackend -> Int -> STM ()
|
||||
recordSuccess rb recoveryAttempts = do
|
||||
state <- readTVar (rbHealthState rb)
|
||||
successes <- readTVar (rbConsecutiveSuccesses rb)
|
||||
|
||||
case state of
|
||||
Healthy ->
|
||||
-- Reset failure counter
|
||||
writeTVar (rbConsecutiveFailures rb) 0
|
||||
|
||||
Unhealthy ->
|
||||
-- First success, transition to recovering
|
||||
transitionToRecovering rb
|
||||
|
||||
Recovering -> do
|
||||
let newSuccesses = successes + 1
|
||||
writeTVar (rbConsecutiveSuccesses rb) newSuccesses
|
||||
when (newSuccesses >= recoveryAttempts) $
|
||||
transitionToHealthy rb
|
||||
|
|
@ -5,6 +5,7 @@ module Aenebris.Config
|
|||
( Config(..)
|
||||
, ListenConfig(..)
|
||||
, TLSConfig(..)
|
||||
, SNIDomain(..)
|
||||
, Upstream(..)
|
||||
, Server(..)
|
||||
, HealthCheck(..)
|
||||
|
|
@ -21,7 +22,7 @@ import qualified Data.Text as T
|
|||
import Data.Yaml (decodeFileEither)
|
||||
import GHC.Generics
|
||||
|
||||
-- | Main configuration structure
|
||||
-- | Main config structure
|
||||
data Config = Config
|
||||
{ configVersion :: Int
|
||||
, configListen :: [ListenConfig]
|
||||
|
|
@ -40,22 +41,43 @@ instance FromJSON Config where
|
|||
data ListenConfig = ListenConfig
|
||||
{ listenPort :: Int
|
||||
, listenTLS :: Maybe TLSConfig
|
||||
, listenRedirectHTTPS :: Maybe Bool -- Redirect HTTP to HTTPS?
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
instance FromJSON ListenConfig where
|
||||
parseJSON = withObject "ListenConfig" $ \v -> ListenConfig
|
||||
<$> v .: "port"
|
||||
<*> v .:? "tls"
|
||||
<*> v .:? "redirect_https"
|
||||
|
||||
-- | TLS/SSL configuration
|
||||
-- | TLS/SSL configuration (supports both single cert and SNI)
|
||||
data TLSConfig = TLSConfig
|
||||
{ tlsCert :: FilePath
|
||||
, tlsKey :: FilePath
|
||||
{ tlsCert :: Maybe FilePath -- Single cert (if not using SNI)
|
||||
, tlsKey :: Maybe FilePath -- Single key (if not using SNI)
|
||||
, tlsSNI :: Maybe [SNIDomain] -- SNI domains (multiple certs)
|
||||
, tlsDefaultCert :: Maybe FilePath -- Default cert for SNI
|
||||
, tlsDefaultKey :: Maybe FilePath -- Default key for SNI
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
instance FromJSON TLSConfig where
|
||||
parseJSON = withObject "TLSConfig" $ \v -> TLSConfig
|
||||
<$> v .: "cert"
|
||||
<$> v .:? "cert"
|
||||
<*> v .:? "key"
|
||||
<*> v .:? "sni"
|
||||
<*> v .:? "default_cert"
|
||||
<*> v .:? "default_key"
|
||||
|
||||
-- | SNI domain configuration
|
||||
data SNIDomain = SNIDomain
|
||||
{ sniDomain :: Text
|
||||
, sniCert :: FilePath
|
||||
, sniKey :: FilePath
|
||||
} deriving (Show, Eq, Generic)
|
||||
|
||||
instance FromJSON SNIDomain where
|
||||
parseJSON = withObject "SNIDomain" $ \v -> SNIDomain
|
||||
<$> v .: "domain"
|
||||
<*> v .: "cert"
|
||||
<*> v .: "key"
|
||||
|
||||
-- | Upstream backend definition
|
||||
|
|
@ -142,6 +164,11 @@ validateConfig config = do
|
|||
when (port < 1 || port > 65535) $
|
||||
Left $ "Invalid port number: " ++ show port
|
||||
|
||||
-- Validate TLS configuration if present
|
||||
case listenTLS listen of
|
||||
Nothing -> return ()
|
||||
Just tlsConf -> validateTLS tlsConf
|
||||
|
||||
-- Check at least one upstream
|
||||
when (null $ configUpstreams config) $
|
||||
Left "At least one upstream must be specified"
|
||||
|
|
@ -181,3 +208,40 @@ validateConfig config = do
|
|||
nubText :: [Text] -> [Text]
|
||||
nubText [] = []
|
||||
nubText (x:xs) = x : nubText (filter (/= x) xs)
|
||||
|
||||
-- Validate TLS configuration
|
||||
validateTLS :: TLSConfig -> Either String ()
|
||||
validateTLS tlsConf = do
|
||||
let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of
|
||||
(Just _, Just _) -> True
|
||||
(Nothing, Nothing) -> False
|
||||
_ -> False -- One is set but not the other
|
||||
|
||||
hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
|
||||
(Just sniDomains, Just _, Just _) -> not (null sniDomains)
|
||||
_ -> False
|
||||
|
||||
-- Must have either single cert or SNI configuration
|
||||
when (not hasSingleCert && not hasSNI) $
|
||||
Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)"
|
||||
|
||||
-- Can't have both single cert and SNI
|
||||
when (hasSingleCert && hasSNI) $
|
||||
Left "TLS configuration cannot have both single cert and SNI configuration"
|
||||
|
||||
-- If single cert, ensure both cert and key are present
|
||||
when (hasSingleCert) $ do
|
||||
case (tlsCert tlsConf, tlsKey tlsConf) of
|
||||
(Just _, Nothing) -> Left "TLS cert specified but key missing"
|
||||
(Nothing, Just _) -> Left "TLS key specified but cert missing"
|
||||
_ -> return ()
|
||||
|
||||
-- If SNI, ensure default cert/key are present
|
||||
when (hasSNI) $ do
|
||||
case (tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
|
||||
(Just _, Nothing) -> Left "SNI default_cert specified but default_key missing"
|
||||
(Nothing, Just _) -> Left "SNI default_key specified but default_cert missing"
|
||||
(Nothing, Nothing) -> Left "SNI configuration requires default_cert and default_key"
|
||||
_ -> return ()
|
||||
|
||||
return ()
|
||||
|
|
|
|||
|
|
@ -0,0 +1,91 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Aenebris.HealthCheck
|
||||
( HealthCheckConfig(..)
|
||||
, defaultHealthCheckConfig
|
||||
, startHealthChecker
|
||||
, stopHealthChecker
|
||||
, performHealthCheck
|
||||
) where
|
||||
|
||||
import Aenebris.Backend
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (forever)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Network.HTTP.Client
|
||||
import Network.HTTP.Types.Status (statusCode)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
-- | Health check configuration
|
||||
data HealthCheckConfig = HealthCheckConfig
|
||||
{ hcInterval :: Int -- Seconds between checks
|
||||
, hcTimeout :: Int -- Request timeout (seconds)
|
||||
, hcEndpoint :: Text -- Health endpoint path (e.g., "/health")
|
||||
, hcMaxFailures :: Int -- Failures before marking unhealthy
|
||||
, hcRecoveryAttempts :: Int -- Successes before marking healthy
|
||||
}
|
||||
|
||||
-- | Default health check configuration
|
||||
defaultHealthCheckConfig :: HealthCheckConfig
|
||||
defaultHealthCheckConfig = HealthCheckConfig
|
||||
{ hcInterval = 10
|
||||
, hcTimeout = 2
|
||||
, hcEndpoint = "/health"
|
||||
, hcMaxFailures = 3
|
||||
, hcRecoveryAttempts = 2
|
||||
}
|
||||
|
||||
-- | Start health checker (returns Async handle for stopping)
|
||||
startHealthChecker :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ())
|
||||
startHealthChecker manager config backends =
|
||||
async $ healthCheckLoop manager config backends
|
||||
|
||||
-- | Stop health checker
|
||||
stopHealthChecker :: Async () -> IO ()
|
||||
stopHealthChecker = cancel
|
||||
|
||||
-- | Main health check loop
|
||||
healthCheckLoop :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO ()
|
||||
healthCheckLoop manager config backends = forever $ do
|
||||
-- Check all backends concurrently
|
||||
results <- mapConcurrently (performHealthCheck manager config) backends
|
||||
|
||||
-- Update backend states based on results
|
||||
atomically $ zipWithM_ (updateBackendState config) backends results
|
||||
|
||||
threadDelay (hcInterval config * 1000000)
|
||||
|
||||
-- | Perform HTTP health check on a backend
|
||||
performHealthCheck :: Manager -> HealthCheckConfig -> RuntimeBackend -> IO Bool
|
||||
performHealthCheck manager config backend = do
|
||||
let url = "http://" ++ T.unpack (rbHost backend) ++ T.unpack (hcEndpoint config)
|
||||
|
||||
-- Try to make request with timeout
|
||||
result <- timeout (hcTimeout config * 1000000) $ do
|
||||
req <- parseRequest url
|
||||
response <- httpLbs req manager
|
||||
return $ statusCode (responseStatus response) == 200
|
||||
|
||||
-- Update last check time
|
||||
now <- getCurrentTime
|
||||
atomically $ writeTVar (rbLastHealthCheck backend) (Just now)
|
||||
|
||||
return $ case result of
|
||||
Just True -> True
|
||||
_ -> False
|
||||
|
||||
-- | Update backend state based on health check result
|
||||
updateBackendState :: HealthCheckConfig -> RuntimeBackend -> Bool -> STM ()
|
||||
updateBackendState config backend healthy =
|
||||
if healthy
|
||||
then recordSuccess backend (hcRecoveryAttempts config)
|
||||
else recordFailure backend (hcMaxFailures config)
|
||||
|
||||
-- | Helper: zip with monadic action
|
||||
zipWithM_ :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m ()
|
||||
zipWithM_ f xs ys = sequence_ (zipWith f xs ys)
|
||||
|
|
@ -0,0 +1,150 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Aenebris.LoadBalancer
|
||||
( LoadBalancerStrategy(..)
|
||||
, LoadBalancer(..)
|
||||
, createLoadBalancer
|
||||
, selectBackend
|
||||
) where
|
||||
|
||||
import Aenebris.Backend
|
||||
import Control.Concurrent.STM
|
||||
import Data.IORef
|
||||
import Data.List (minimumBy, find)
|
||||
import Data.Ord (comparing)
|
||||
import qualified Data.Vector as V
|
||||
import Data.Vector (Vector, (!))
|
||||
|
||||
-- | Load balancing strategy
|
||||
data LoadBalancerStrategy
|
||||
= RoundRobin
|
||||
| LeastConnections
|
||||
| WeightedRoundRobin
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Load balancer state
|
||||
data LoadBalancer = LoadBalancer
|
||||
{ lbBackends :: Vector RuntimeBackend
|
||||
, lbStrategy :: LoadBalancerStrategy
|
||||
, lbRRCounter :: IORef Int -- For round robin
|
||||
}
|
||||
|
||||
-- | Create a load balancer for given backends
|
||||
createLoadBalancer :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer
|
||||
createLoadBalancer strategy backends = do
|
||||
counter <- newIORef 0
|
||||
return LoadBalancer
|
||||
{ lbBackends = V.fromList backends
|
||||
, lbStrategy = strategy
|
||||
, lbRRCounter = counter
|
||||
}
|
||||
|
||||
-- | Select a backend using the configured strategy
|
||||
selectBackend :: LoadBalancer -> IO (Maybe RuntimeBackend)
|
||||
selectBackend lb =
|
||||
case lbStrategy lb of
|
||||
RoundRobin -> selectRoundRobin lb
|
||||
LeastConnections -> selectLeastConnections lb
|
||||
WeightedRoundRobin -> selectWeightedRR lb
|
||||
|
||||
-- Round-Robin Implementation (IORef-based, fastest)
|
||||
selectRoundRobin :: LoadBalancer -> IO (Maybe RuntimeBackend)
|
||||
selectRoundRobin LoadBalancer{..} = do
|
||||
let backends = lbBackends
|
||||
len = V.length backends
|
||||
|
||||
if len == 0
|
||||
then return Nothing
|
||||
else do
|
||||
-- Get next index
|
||||
idx <- atomicModifyIORef' lbRRCounter $ \i ->
|
||||
let next = (i + 1) `mod` len
|
||||
in (next, i)
|
||||
|
||||
-- Find next healthy backend (try all, wrapping around)
|
||||
findHealthyBackend backends idx len
|
||||
|
||||
-- | Find next healthy backend starting from index
|
||||
findHealthyBackend :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend)
|
||||
findHealthyBackend backends startIdx totalBackends =
|
||||
go startIdx totalBackends
|
||||
where
|
||||
len = V.length backends
|
||||
|
||||
go currentIdx remaining
|
||||
| remaining <= 0 = return Nothing -- Tried all, none healthy
|
||||
| otherwise = do
|
||||
let backend = backends ! currentIdx
|
||||
healthy <- atomically $ isHealthy backend
|
||||
|
||||
if healthy
|
||||
then return (Just backend)
|
||||
else go ((currentIdx + 1) `mod` len) (remaining - 1)
|
||||
|
||||
|
||||
-- Least Connections Implementation (STM-based)
|
||||
selectLeastConnections :: LoadBalancer -> IO (Maybe RuntimeBackend)
|
||||
selectLeastConnections LoadBalancer{..} = atomically $ do
|
||||
let backends = V.toList lbBackends
|
||||
|
||||
-- Filter to only healthy backends
|
||||
healthy <- filterM isHealthy backends
|
||||
|
||||
case healthy of
|
||||
[] -> return Nothing
|
||||
backends' -> do
|
||||
-- Get connection counts for all healthy backends
|
||||
counts <- mapM getConnectionCount backends'
|
||||
|
||||
-- Find backend with minimum connections
|
||||
let (_, minBackend) = minimumBy (comparing fst) (zip counts backends')
|
||||
|
||||
return (Just minBackend)
|
||||
|
||||
|
||||
-- Smooth Weighted Round-Robin (nginx algorithm, STM-based)
|
||||
selectWeightedRR :: LoadBalancer -> IO (Maybe RuntimeBackend)
|
||||
selectWeightedRR LoadBalancer{..} = atomically $ do
|
||||
let backends = V.toList lbBackends
|
||||
|
||||
-- Filter to only healthy backends
|
||||
healthy <- filterM isHealthy backends
|
||||
|
||||
case healthy of
|
||||
[] -> return Nothing
|
||||
backends' -> do
|
||||
-- Step 1: Increase each backend's current weight by its base weight
|
||||
forM_ backends' $ \rb -> do
|
||||
currentW <- readTVar (rbCurrentWeight rb)
|
||||
let newWeight = currentW + rbWeight rb
|
||||
writeTVar (rbCurrentWeight rb) newWeight
|
||||
|
||||
-- Step 2: Select backend with maximum current weight
|
||||
weights <- mapM getCurrentWeight backends'
|
||||
let maxWeight = maximum weights
|
||||
selectedIdx = find (\i -> weights !! i == maxWeight) [0..length weights - 1]
|
||||
selected = backends' !! (fromMaybe 0 selectedIdx)
|
||||
|
||||
-- Step 3: Reduce selected backend's current weight by total weight
|
||||
let totalWeight = sum (map rbWeight backends')
|
||||
currentW <- readTVar (rbCurrentWeight selected)
|
||||
writeTVar (rbCurrentWeight selected) (currentW - totalWeight)
|
||||
|
||||
return (Just selected)
|
||||
|
||||
-- Helper: STM filter
|
||||
filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
|
||||
filterM _ [] = return []
|
||||
filterM p (x:xs) = do
|
||||
b <- p x
|
||||
rest <- filterM p xs
|
||||
return $ if b then x : rest else rest
|
||||
|
||||
-- Helper: fromMaybe
|
||||
fromMaybe :: a -> Maybe a -> a
|
||||
fromMaybe def Nothing = def
|
||||
fromMaybe _ (Just x) = x
|
||||
|
||||
-- Helper: forM_
|
||||
forM_ :: Monad m => [a] -> (a -> m b) -> m ()
|
||||
forM_ xs f = sequence_ (map f xs)
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Aenebris.Middleware.Redirect
|
||||
( httpsRedirect
|
||||
, httpsRedirectWithPort
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Network.HTTP.Types (status301, hLocation)
|
||||
import Network.Wai (Middleware, responseLBS, requestHeaderHost, rawPathInfo, rawQueryString, isSecure)
|
||||
|
||||
-- | Redirect HTTP requests to HTTPS (assumes HTTPS is on port 443)
|
||||
httpsRedirect :: Middleware
|
||||
httpsRedirect = httpsRedirectWithPort Nothing
|
||||
|
||||
-- | Redirect HTTP requests to HTTPS with optional custom port
|
||||
-- If port is Nothing, assumes 443 (standard HTTPS port, no port in URL)
|
||||
-- If port is Just n, includes :n in the redirect URL
|
||||
httpsRedirectWithPort :: Maybe Int -> Middleware
|
||||
httpsRedirectWithPort httpsPort app req respond
|
||||
| isSecure req = app req respond -- Already HTTPS, pass through
|
||||
| otherwise = do
|
||||
-- Get host from Host header
|
||||
let hostHeader = fromMaybe "localhost" $ requestHeaderHost req
|
||||
|
||||
-- Build HTTPS URL with optional port
|
||||
host = case httpsPort of
|
||||
Nothing -> hostHeader -- Standard 443, don't include port
|
||||
Just 443 -> hostHeader -- Standard 443, don't include port
|
||||
Just port -> hostHeader <> ":" <> BS.pack (show port)
|
||||
|
||||
-- Get path and query string (already encoded in rawPathInfo)
|
||||
path = rawPathInfo req
|
||||
query = rawQueryString req
|
||||
|
||||
-- Build full redirect URL
|
||||
redirectUrl = "https://" <> host <> path <> query
|
||||
|
||||
-- Send 301 permanent redirect
|
||||
respond $ responseLBS
|
||||
status301
|
||||
[(hLocation, redirectUrl)]
|
||||
"Redirecting to HTTPS"
|
||||
|
|
@ -0,0 +1,135 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Aenebris.Middleware.Security
|
||||
( addSecurityHeaders
|
||||
, SecurityLevel(..)
|
||||
, SecurityConfig(..)
|
||||
, defaultSecurityConfig
|
||||
, strictSecurityConfig
|
||||
, testingSecurityConfig
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.HTTP.Types (Header, ResponseHeaders)
|
||||
import Network.Wai (Middleware, mapResponseHeaders)
|
||||
|
||||
-- | Security level presets
|
||||
data SecurityLevel
|
||||
= Testing -- Short HSTS, permissive CSP, for development
|
||||
| Production -- Balanced security for production
|
||||
| Strict -- Maximum security, strict CSP, HSTS preload
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Security configuration
|
||||
data SecurityConfig = SecurityConfig
|
||||
{ scHSTS :: Maybe ByteString -- Strict-Transport-Security header
|
||||
, scCSP :: Maybe ByteString -- Content-Security-Policy header
|
||||
, scFrameOptions :: Maybe ByteString -- X-Frame-Options header
|
||||
, scContentTypeOptions :: Bool -- X-Content-Type-Options: nosniff
|
||||
, scReferrerPolicy :: Maybe ByteString -- Referrer-Policy header
|
||||
, scPermissionsPolicy :: Maybe ByteString -- Permissions-Policy header
|
||||
, scXSSProtection :: Maybe ByteString -- X-XSS-Protection (legacy, but some crawlers check)
|
||||
, scExpectCT :: Maybe ByteString -- Expect-CT (transitional)
|
||||
, scServerHeader :: Maybe ByteString -- Server header (hide or customize)
|
||||
, scRemovePoweredBy :: Bool -- Remove X-Powered-By headers
|
||||
} deriving (Show, Eq)
|
||||
|
||||
-- | Testing/development security configuration
|
||||
-- Use short HSTS for easy testing, permissive CSP
|
||||
testingSecurityConfig :: SecurityConfig
|
||||
testingSecurityConfig = SecurityConfig
|
||||
{ scHSTS = Just "max-age=300" -- 5 minutes for testing
|
||||
, scCSP = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'"
|
||||
, scFrameOptions = Just "SAMEORIGIN"
|
||||
, scContentTypeOptions = True
|
||||
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
|
||||
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()"
|
||||
, scXSSProtection = Just "1; mode=block"
|
||||
, scExpectCT = Nothing
|
||||
, scServerHeader = Just "Aenebris/0.1.0"
|
||||
, scRemovePoweredBy = True
|
||||
}
|
||||
|
||||
-- | Production security configuration
|
||||
-- Balanced security, 1-month HSTS
|
||||
defaultSecurityConfig :: SecurityConfig
|
||||
defaultSecurityConfig = SecurityConfig
|
||||
{ scHSTS = Just "max-age=2592000; includeSubDomains" -- 30 days
|
||||
, scCSP = Just "default-src 'self'; script-src 'self'; style-src 'self' 'unsafe-inline'; img-src 'self' data: https:; font-src 'self' data:; connect-src 'self'; frame-ancestors 'none'"
|
||||
, scFrameOptions = Just "DENY"
|
||||
, scContentTypeOptions = True
|
||||
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
|
||||
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()"
|
||||
, scXSSProtection = Just "1; mode=block"
|
||||
, scExpectCT = Just "max-age=86400, enforce"
|
||||
, scServerHeader = Just "Aenebris" -- Don't reveal version in production
|
||||
, scRemovePoweredBy = True
|
||||
}
|
||||
|
||||
-- | Strict security configuration for maximum protection
|
||||
-- 2-year HSTS with preload, very restrictive CSP
|
||||
strictSecurityConfig :: SecurityConfig
|
||||
strictSecurityConfig = SecurityConfig
|
||||
{ scHSTS = Just "max-age=63072000; includeSubDomains; preload" -- 2 years + preload
|
||||
, scCSP = Just "default-src 'none'; script-src 'self'; style-src 'self'; img-src 'self' data:; font-src 'self'; connect-src 'self'; frame-ancestors 'none'; base-uri 'self'; form-action 'self'; upgrade-insecure-requests"
|
||||
, scFrameOptions = Just "DENY"
|
||||
, scContentTypeOptions = True
|
||||
, scReferrerPolicy = Just "no-referrer" -- Strictest, no referrer leakage
|
||||
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()"
|
||||
, scXSSProtection = Just "1; mode=block"
|
||||
, scExpectCT = Just "max-age=86400, enforce"
|
||||
, scServerHeader = Nothing -- Hide completely
|
||||
, scRemovePoweredBy = True
|
||||
}
|
||||
|
||||
-- | Middleware that adds security headers to all responses
|
||||
addSecurityHeaders :: SecurityConfig -> Middleware
|
||||
addSecurityHeaders config app req respond =
|
||||
app req $ \res ->
|
||||
respond $ mapResponseHeaders (addHeaders config) res
|
||||
|
||||
-- | Add security headers to response headers
|
||||
addHeaders :: SecurityConfig -> ResponseHeaders -> ResponseHeaders
|
||||
addHeaders config headers =
|
||||
let
|
||||
-- Remove headers we want to control
|
||||
cleaned = if scRemovePoweredBy config
|
||||
then filter (not . isPoweredBy) headers
|
||||
else headers
|
||||
|
||||
-- Build new security headers
|
||||
newHeaders = catMaybes
|
||||
[ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config)
|
||||
, fmap (\v -> ("Content-Security-Policy", v)) (scCSP config)
|
||||
, fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config)
|
||||
, if scContentTypeOptions config
|
||||
then Just ("X-Content-Type-Options", "nosniff")
|
||||
else Nothing
|
||||
, fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config)
|
||||
, fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config)
|
||||
, fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config)
|
||||
, fmap (\v -> ("Expect-CT", v)) (scExpectCT config)
|
||||
]
|
||||
|
||||
-- Handle Server header specially
|
||||
serverHeader = case scServerHeader config of
|
||||
Just v -> [("Server", v)]
|
||||
Nothing -> [] -- Remove Server header completely
|
||||
|
||||
-- Remove existing Server header if we're replacing it
|
||||
withoutServer = filter (not . isServerHeader) cleaned
|
||||
|
||||
in withoutServer ++ newHeaders ++ serverHeader
|
||||
|
||||
-- | Check if header is X-Powered-By
|
||||
isPoweredBy :: Header -> Bool
|
||||
isPoweredBy (name, _) = CI.mk name == CI.mk "X-Powered-By"
|
||||
|
||||
-- | Check if header is Server
|
||||
isServerHeader :: Header -> Bool
|
||||
isServerHeader (name, _) = CI.mk name == CI.mk "Server"
|
||||
|
||||
-- | catMaybes implementation (since we're not importing Data.Maybe)
|
||||
catMaybes :: [Maybe a] -> [a]
|
||||
catMaybes = foldr (\mx xs -> case mx of Just x -> x:xs; Nothing -> xs) []
|
||||
|
|
@ -1,15 +1,30 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Aenebris.Proxy
|
||||
( startProxy
|
||||
( ProxyState(..)
|
||||
, initProxyState
|
||||
, startProxy
|
||||
, proxyApp
|
||||
, selectUpstream
|
||||
) where
|
||||
|
||||
import Aenebris.Backend
|
||||
import Aenebris.Config
|
||||
import Aenebris.HealthCheck
|
||||
import Aenebris.LoadBalancer
|
||||
import Aenebris.TLS
|
||||
import Aenebris.Middleware.Security
|
||||
import Aenebris.Middleware.Redirect
|
||||
import Control.Concurrent.Async (Async, async, waitAnyCancel, mapConcurrently_)
|
||||
import Control.Exception (try, SomeException)
|
||||
import Data.Function ((&))
|
||||
import Data.List (sortBy)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
|
@ -17,29 +32,181 @@ import Network.HTTP.Client (Manager, httpLbs, parseRequest, RequestBody(..))
|
|||
import qualified Network.HTTP.Client as HTTP
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Network.Wai.Handler.Warp (run, defaultSettings, setPort)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
-- | Proxy runtime state
|
||||
data ProxyState = ProxyState
|
||||
{ psConfig :: Config
|
||||
, psLoadBalancers :: Map Text LoadBalancer -- upstream name -> load balancer
|
||||
, psHealthCheckers :: [Async ()]
|
||||
, psManager :: Manager
|
||||
}
|
||||
|
||||
-- | Initialize proxy state from config
|
||||
initProxyState :: Config -> Manager -> IO ProxyState
|
||||
initProxyState config manager = do
|
||||
-- Create load balancers for each upstream
|
||||
lbs <- mapM createUpstreamLoadBalancer (configUpstreams config)
|
||||
let lbMap = Map.fromList (zip (map upstreamName $ configUpstreams config) lbs)
|
||||
|
||||
-- Start health checkers for all upstreams
|
||||
checkers <- mapM startUpstreamHealthChecker (configUpstreams config)
|
||||
|
||||
return ProxyState
|
||||
{ psConfig = config
|
||||
, psLoadBalancers = lbMap
|
||||
, psHealthCheckers = checkers
|
||||
, psManager = manager
|
||||
}
|
||||
where
|
||||
-- Create load balancer for an upstream
|
||||
createUpstreamLoadBalancer :: Upstream -> IO LoadBalancer
|
||||
createUpstreamLoadBalancer upstream = do
|
||||
-- Convert Config Servers to RuntimeBackends
|
||||
backends <- zipWithM createRuntimeBackend [0..] (upstreamServers upstream)
|
||||
|
||||
-- Determine strategy (for now, use weighted if weights differ, else round-robin)
|
||||
let weights = map serverWeight (upstreamServers upstream)
|
||||
strategy = case weights of
|
||||
[] -> RoundRobin -- No backends, shouldn't happen but be safe
|
||||
(w:ws) -> if all (== w) ws
|
||||
then RoundRobin
|
||||
else WeightedRoundRobin
|
||||
|
||||
createLoadBalancer strategy backends
|
||||
|
||||
-- Start health checker for an upstream
|
||||
startUpstreamHealthChecker :: Upstream -> IO (Async ())
|
||||
startUpstreamHealthChecker upstream = do
|
||||
backends <- zipWithM createRuntimeBackend [0..] (upstreamServers upstream)
|
||||
|
||||
-- Use health check config from upstream, or defaults
|
||||
let hcConfig = case upstreamHealthCheck upstream of
|
||||
Just hc -> defaultHealthCheckConfig
|
||||
{ hcInterval = 10 -- TODO: parse interval from config
|
||||
, hcEndpoint = healthCheckPath hc
|
||||
}
|
||||
Nothing -> defaultHealthCheckConfig
|
||||
|
||||
startHealthChecker manager hcConfig backends
|
||||
|
||||
-- | Start the proxy server with given configuration
|
||||
startProxy :: Config -> Manager -> IO ()
|
||||
startProxy config manager = do
|
||||
-- For now, just use the first listen port
|
||||
-- TODO: Support multiple ports with different settings
|
||||
case configListen config of
|
||||
-- Supports multiple ports with HTTP and HTTPS (including SNI)
|
||||
startProxy :: ProxyState -> IO ()
|
||||
startProxy ProxyState{..} = do
|
||||
putStrLn $ "Starting Ᾰenebris reverse proxy"
|
||||
putStrLn $ "Loaded " ++ show (length $ configUpstreams psConfig) ++ " upstream(s)"
|
||||
putStrLn $ "Loaded " ++ show (length $ configRoutes psConfig) ++ " route(s)"
|
||||
putStrLn $ "Health checking enabled for all upstreams"
|
||||
|
||||
case configListen psConfig of
|
||||
[] -> error "No listen ports configured"
|
||||
(firstPort:_) -> do
|
||||
let port = listenPort firstPort
|
||||
putStrLn $ "Starting Ᾰenebris reverse proxy on port " ++ show port
|
||||
putStrLn $ "Loaded " ++ show (length $ configUpstreams config) ++ " upstream(s)"
|
||||
putStrLn $ "Loaded " ++ show (length $ configRoutes config) ++ " route(s)"
|
||||
run port (proxyApp config manager)
|
||||
listenConfigs -> do
|
||||
-- Launch a server for each listen port concurrently
|
||||
servers <- mapM (launchServer psConfig psLoadBalancers psManager) listenConfigs
|
||||
|
||||
-- Wait for any server to fail (shouldn't happen in normal operation)
|
||||
waitAnyCancel servers
|
||||
|
||||
putStrLn "All servers stopped"
|
||||
|
||||
-- | Launch a single server instance (HTTP or HTTPS)
|
||||
launchServer :: Config -> Map Text LoadBalancer -> Manager -> ListenConfig -> IO (Async ())
|
||||
launchServer config loadBalancers manager listenConfig = async $ do
|
||||
let port = listenPort listenConfig
|
||||
shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig)
|
||||
|
||||
-- Build the base application
|
||||
baseApp = proxyApp config loadBalancers manager
|
||||
|
||||
-- Add security headers (production level by default)
|
||||
securedApp = addSecurityHeaders defaultSecurityConfig baseApp
|
||||
|
||||
case listenTLS listenConfig of
|
||||
Nothing -> do
|
||||
-- Plain HTTP server
|
||||
let app = if shouldRedirect
|
||||
then httpsRedirect securedApp -- Redirect all HTTP to HTTPS
|
||||
else securedApp
|
||||
|
||||
putStrLn $ "✓ HTTP server listening on :" ++ show port
|
||||
if shouldRedirect
|
||||
then putStrLn $ " └─ Redirecting all traffic to HTTPS"
|
||||
else return ()
|
||||
|
||||
run port app
|
||||
|
||||
Just tlsConfig -> do
|
||||
-- HTTPS server - check if single cert or SNI
|
||||
let isSNI = case tlsSNI tlsConfig of
|
||||
Just domains -> not (null domains)
|
||||
Nothing -> False
|
||||
|
||||
if isSNI
|
||||
then launchHTTPSWithSNI port tlsConfig securedApp
|
||||
else launchHTTPS port tlsConfig securedApp
|
||||
|
||||
-- | Launch HTTPS server with single certificate
|
||||
launchHTTPS :: Int -> TLSConfig -> Application -> IO ()
|
||||
launchHTTPS port tlsConfig app = do
|
||||
case (tlsCert tlsConfig, tlsKey tlsConfig) of
|
||||
(Just certFile, Just keyFile) -> do
|
||||
-- Load TLS settings
|
||||
tlsResult <- createTLSSettings certFile keyFile
|
||||
case tlsResult of
|
||||
Left err -> do
|
||||
hPutStrLn stderr $ "ERROR: Failed to load TLS certificate"
|
||||
hPutStrLn stderr $ " " ++ show err
|
||||
error "TLS configuration error"
|
||||
|
||||
Right tlsSettings -> do
|
||||
let warpSettings = defaultSettings & setPort port
|
||||
putStrLn $ "✓ HTTPS server listening on :" ++ show port
|
||||
putStrLn $ " ├─ Certificate: " ++ certFile
|
||||
putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled"
|
||||
putStrLn $ " ├─ HTTP/2 enabled (ALPN)"
|
||||
putStrLn $ " └─ Strong cipher suites enforced"
|
||||
runTLS tlsSettings warpSettings app
|
||||
|
||||
_ -> error "TLS configuration error: cert and key required"
|
||||
|
||||
-- | Launch HTTPS server with SNI support (multiple certificates)
|
||||
launchHTTPSWithSNI :: Int -> TLSConfig -> Application -> IO ()
|
||||
launchHTTPSWithSNI port tlsConfig app = do
|
||||
case (tlsSNI tlsConfig, tlsDefaultCert tlsConfig, tlsDefaultKey tlsConfig) of
|
||||
(Just sniDomains, Just defaultCert, Just defaultKey) -> do
|
||||
-- Convert SNIDomain list to the format expected by createSNISettings
|
||||
let domainList = [(sniDomain d, sniCert d, sniKey d) | d <- sniDomains]
|
||||
|
||||
-- Load SNI TLS settings
|
||||
tlsResult <- createSNISettings domainList defaultCert defaultKey
|
||||
case tlsResult of
|
||||
Left err -> do
|
||||
hPutStrLn stderr $ "ERROR: Failed to load SNI certificates"
|
||||
hPutStrLn stderr $ " " ++ show err
|
||||
error "SNI configuration error"
|
||||
|
||||
Right tlsSettings -> do
|
||||
let warpSettings = defaultSettings & setPort port
|
||||
putStrLn $ "✓ HTTPS server with SNI listening on :" ++ show port
|
||||
putStrLn $ " ├─ SNI domains: " ++ show (length sniDomains) ++ " configured"
|
||||
mapM_ (\d -> putStrLn $ " │ • " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d) sniDomains
|
||||
putStrLn $ " ├─ Default certificate: " ++ defaultCert
|
||||
putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled"
|
||||
putStrLn $ " ├─ HTTP/2 enabled (ALPN)"
|
||||
putStrLn $ " └─ Strong cipher suites enforced"
|
||||
runTLS tlsSettings warpSettings app
|
||||
|
||||
_ -> error "SNI configuration error: sni, default_cert, and default_key required"
|
||||
|
||||
-- | Main proxy application (WAI)
|
||||
proxyApp :: Config -> Manager -> Application
|
||||
proxyApp config manager req respond = do
|
||||
proxyApp :: Config -> Map Text LoadBalancer -> Manager -> Application
|
||||
proxyApp config loadBalancers manager req respond = do
|
||||
-- Log incoming request
|
||||
logRequest req
|
||||
|
||||
|
|
@ -56,30 +223,32 @@ proxyApp config manager req respond = do
|
|||
[("Content-Type", "text/plain")]
|
||||
"Not Found: No route configured for this host/path"
|
||||
|
||||
Just (selectedUpstream, _pathRoute) -> do
|
||||
-- Find the upstream by name
|
||||
case findUpstream config selectedUpstream of
|
||||
Just (upstreamName, _pathRoute) -> do
|
||||
-- Find the load balancer for this upstream
|
||||
case Map.lookup upstreamName loadBalancers of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr $ "ERROR: Upstream not found: " ++ T.unpack selectedUpstream
|
||||
hPutStrLn stderr $ "ERROR: Load balancer not found: " ++ T.unpack upstreamName
|
||||
respond $ responseLBS
|
||||
status500
|
||||
[("Content-Type", "text/plain")]
|
||||
"Internal Server Error: Upstream configuration error"
|
||||
|
||||
Just upstream -> do
|
||||
-- Select a backend server (for now, just use the first one)
|
||||
-- TODO: Implement load balancing algorithms
|
||||
case selectBackend upstream of
|
||||
Just loadBalancer -> do
|
||||
-- Select a backend using load balancing
|
||||
mBackend <- selectBackend loadBalancer
|
||||
|
||||
case mBackend of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr $ "ERROR: No backend servers available"
|
||||
hPutStrLn stderr $ "ERROR: No healthy backends available"
|
||||
respond $ responseLBS
|
||||
status503
|
||||
[("Content-Type", "text/plain")]
|
||||
"Service Unavailable: No backend servers available"
|
||||
"Service Unavailable: No healthy backends available"
|
||||
|
||||
Just server -> do
|
||||
-- Try to forward request to backend
|
||||
result <- try $ forwardRequest manager req (serverHost server)
|
||||
Just backend -> do
|
||||
-- Track this connection and forward request
|
||||
result <- try $ trackConnection backend $
|
||||
forwardRequest manager req (rbHost backend)
|
||||
|
||||
case result of
|
||||
Left (err :: SomeException) -> do
|
||||
|
|
@ -108,29 +277,18 @@ selectRoute config hostHeader requestPath =
|
|||
-- Find first matching path within the route
|
||||
route <- listToMaybe matchingRoutes
|
||||
let requestPathText = TE.decodeUtf8 requestPath
|
||||
matchingPaths = filter (\p -> pathMatches (pathRoutePath p) requestPathText) (routePaths route)
|
||||
-- Sort paths by length (longest first) so more specific paths match first
|
||||
sortedPaths = sortBy (comparing (negate . T.length . pathRoutePath)) (routePaths route)
|
||||
matchingPaths = filter (\p -> pathMatches (pathRoutePath p) requestPathText) sortedPaths
|
||||
|
||||
pathRoute <- listToMaybe matchingPaths
|
||||
return (pathRouteUpstream pathRoute, pathRoute)
|
||||
|
||||
-- | Check if a path pattern matches a request path
|
||||
-- For now, just simple prefix matching
|
||||
-- TODO: Implement more sophisticated path matching (regex, wildcards)
|
||||
pathMatches :: Text -> Text -> Bool
|
||||
pathMatches pattern requestPath =
|
||||
pattern == "/" || T.isPrefixOf pattern requestPath
|
||||
|
||||
-- | Find an upstream by name
|
||||
findUpstream :: Config -> Text -> Maybe Upstream
|
||||
findUpstream config name =
|
||||
listToMaybe $ filter (\u -> upstreamName u == name) (configUpstreams config)
|
||||
|
||||
-- | Select a backend server from an upstream
|
||||
-- For now, just returns the first server
|
||||
-- TODO: Implement load balancing (round-robin, weighted, least-connections)
|
||||
selectBackend :: Upstream -> Maybe Server
|
||||
selectBackend upstream = listToMaybe (upstreamServers upstream)
|
||||
|
||||
-- | Select an upstream for a request (exported for testing)
|
||||
selectUpstream :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text
|
||||
selectUpstream config hostHeader requestPath =
|
||||
|
|
@ -138,9 +296,9 @@ selectUpstream config hostHeader requestPath =
|
|||
|
||||
-- | Forward request to backend server
|
||||
forwardRequest :: Manager -> Request -> Text -> IO Response
|
||||
forwardRequest manager clientReq backendHostPort = do
|
||||
forwardRequest manager clientReq backendHost = do
|
||||
-- Parse backend host:port
|
||||
let backendUrl = "http://" ++ T.unpack backendHostPort ++
|
||||
let backendUrl = "http://" ++ T.unpack backendHost ++
|
||||
BS8.unpack (rawPathInfo clientReq) ++
|
||||
BS8.unpack (rawQueryString clientReq)
|
||||
|
||||
|
|
@ -193,3 +351,7 @@ logResponse :: Response -> IO ()
|
|||
logResponse res = do
|
||||
let (Status code msg) = responseStatus res
|
||||
putStrLn $ "[←] " ++ show code ++ " " ++ BS8.unpack msg
|
||||
|
||||
-- Helper: zipWithM
|
||||
zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
|
||||
zipWithM f xs ys = sequence (zipWith f xs ys)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,164 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Aenebris.TLS
|
||||
( TLSSettings
|
||||
, createTLSSettings
|
||||
, createSNISettings
|
||||
, validateCertificate
|
||||
, CertificateError(..)
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Network.Wai.Handler.WarpTLS
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.TLS.Extra.Cipher as Cipher
|
||||
import Data.Default.Class (def)
|
||||
import Data.X509 (SignedCertificate)
|
||||
import Data.X509.File (readSignedObject)
|
||||
import System.Directory (doesFileExist)
|
||||
import Control.Exception (try, SomeException)
|
||||
|
||||
-- | Certificate loading errors
|
||||
data CertificateError
|
||||
= CertFileNotFound FilePath
|
||||
| KeyFileNotFound FilePath
|
||||
| InvalidCertificate FilePath String
|
||||
| InvalidKey FilePath String
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Create TLS settings for a single certificate (non-SNI)
|
||||
createTLSSettings :: FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
|
||||
createTLSSettings certFile keyFile = do
|
||||
-- Validate files exist
|
||||
certExists <- doesFileExist certFile
|
||||
keyExists <- doesFileExist keyFile
|
||||
|
||||
if not certExists
|
||||
then return $ Left (CertFileNotFound certFile)
|
||||
else if not keyExists
|
||||
then return $ Left (KeyFileNotFound keyFile)
|
||||
else do
|
||||
-- Try to load the credential to validate it
|
||||
result <- try $ TLS.credentialLoadX509 certFile keyFile
|
||||
case result of
|
||||
Left (err :: SomeException) ->
|
||||
return $ Left (InvalidCertificate certFile (show err))
|
||||
|
||||
Right (Left err) ->
|
||||
return $ Left (InvalidCertificate certFile err)
|
||||
|
||||
Right (Right _credential) -> do
|
||||
-- Create TLS settings with strong security
|
||||
let tlsConfig = (tlsSettings certFile keyFile)
|
||||
{ tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
|
||||
, tlsCiphers = strongCipherSuites
|
||||
, onInsecure = DenyInsecure "This server requires HTTPS"
|
||||
}
|
||||
|
||||
return $ Right tlsConfig
|
||||
|
||||
-- | Create TLS settings with SNI support for multiple domains
|
||||
createSNISettings :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
|
||||
createSNISettings domains defaultCert defaultKey = do
|
||||
-- Validate default certificate
|
||||
defaultExists <- doesFileExist defaultCert
|
||||
defaultKeyExists <- doesFileExist defaultKey
|
||||
|
||||
if not defaultExists
|
||||
then return $ Left (CertFileNotFound defaultCert)
|
||||
else if not defaultKeyExists
|
||||
then return $ Left (KeyFileNotFound defaultKey)
|
||||
else do
|
||||
-- Validate all domain certificates exist
|
||||
validationResults <- mapM validateDomainCert domains
|
||||
case sequence validationResults of
|
||||
Left err -> return $ Left err
|
||||
Right _ -> do
|
||||
-- Create SNI-enabled TLS settings using the default cert first
|
||||
let baseTLS = tlsSettings defaultCert defaultKey
|
||||
tlsConfig = baseTLS
|
||||
{ tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
|
||||
, tlsCiphers = strongCipherSuites
|
||||
, onInsecure = DenyInsecure "This server requires HTTPS"
|
||||
, tlsServerHooks = def
|
||||
{ TLS.onServerNameIndication = \mHostname -> case mHostname of
|
||||
Nothing -> loadCredentials defaultCert defaultKey
|
||||
Just hostname -> sniCallback domains defaultCert defaultKey hostname
|
||||
}
|
||||
}
|
||||
|
||||
return $ Right tlsConfig
|
||||
where
|
||||
validateDomainCert :: (Text, FilePath, FilePath) -> IO (Either CertificateError ())
|
||||
validateDomainCert (domain, certFile, keyFile) = do
|
||||
certExists <- doesFileExist certFile
|
||||
keyExists <- doesFileExist keyFile
|
||||
|
||||
if not certExists
|
||||
then return $ Left (CertFileNotFound certFile)
|
||||
else if not keyExists
|
||||
then return $ Left (KeyFileNotFound keyFile)
|
||||
else return $ Right ()
|
||||
|
||||
-- | SNI callback function - returns credentials based on hostname
|
||||
sniCallback :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> String -> IO TLS.Credentials
|
||||
sniCallback domains defaultCert defaultKey hostname = do
|
||||
let hostnameText = T.pack hostname
|
||||
-- Look up domain in map
|
||||
domainMap = Map.fromList [(d, (c, k)) | (d, c, k) <- domains]
|
||||
|
||||
case Map.lookup hostnameText domainMap of
|
||||
Nothing -> do
|
||||
-- No match, use default certificate
|
||||
loadCredentials defaultCert defaultKey
|
||||
|
||||
Just (certFile, keyFile) -> do
|
||||
-- Found matching domain, load its certificate
|
||||
loadCredentials certFile keyFile
|
||||
|
||||
-- | Load TLS credentials from certificate and key files
|
||||
loadCredentials :: FilePath -> FilePath -> IO TLS.Credentials
|
||||
loadCredentials certFile keyFile = do
|
||||
result <- TLS.credentialLoadX509 certFile keyFile
|
||||
case result of
|
||||
Left err ->
|
||||
error $ "Failed to load certificate: " ++ err
|
||||
Right credential ->
|
||||
return $ TLS.Credentials [credential]
|
||||
|
||||
-- | Validate a certificate file (check if it's readable and valid)
|
||||
validateCertificate :: FilePath -> IO (Either CertificateError [SignedCertificate])
|
||||
validateCertificate certFile = do
|
||||
exists <- doesFileExist certFile
|
||||
if not exists
|
||||
then return $ Left (CertFileNotFound certFile)
|
||||
else do
|
||||
result <- try $ readSignedObject certFile
|
||||
case result of
|
||||
Left (err :: SomeException) ->
|
||||
return $ Left (InvalidCertificate certFile (show err))
|
||||
Right certs ->
|
||||
return $ Right certs
|
||||
|
||||
-- | Strong cipher suites for production (TLS 1.2 + TLS 1.3)
|
||||
strongCipherSuites :: [TLS.Cipher]
|
||||
strongCipherSuites =
|
||||
-- TLS 1.3 cipher suites (preferred)
|
||||
[ Cipher.cipher_TLS13_AES128GCM_SHA256
|
||||
, Cipher.cipher_TLS13_AES256GCM_SHA384
|
||||
, Cipher.cipher_TLS13_CHACHA20POLY1305_SHA256
|
||||
] ++
|
||||
-- TLS 1.2 cipher suites (fallback, only ECDHE + AEAD)
|
||||
[ Cipher.cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256
|
||||
, Cipher.cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384
|
||||
, Cipher.cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256
|
||||
, Cipher.cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256
|
||||
, Cipher.cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384
|
||||
, Cipher.cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256
|
||||
]
|
||||
|
|
@ -1,111 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Network.HTTP.Types
|
||||
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings, httpLbs, parseRequest, method, requestBody, RequestBody(..))
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Control.Exception (try, SomeException)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
|
||||
-- Configuration
|
||||
backendHost :: String
|
||||
backendHost = "localhost"
|
||||
|
||||
backendPort :: Int
|
||||
backendPort = 8000
|
||||
|
||||
proxyPort :: Int
|
||||
proxyPort = 8080
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn $ "Starting Ᾰenebris reverse proxy on port " ++ show proxyPort
|
||||
putStrLn $ "Forwarding to backend: http://" ++ backendHost ++ ":" ++ show backendPort
|
||||
manager <- newManager defaultManagerSettings
|
||||
run proxyPort (proxyApp manager)
|
||||
|
||||
proxyApp :: Manager -> Application
|
||||
proxyApp manager req respond = do
|
||||
-- Log incoming request
|
||||
logRequest req
|
||||
|
||||
-- Try to forward request to backend
|
||||
result <- try $ forwardRequest manager req
|
||||
|
||||
case result of
|
||||
Left (err :: SomeException) -> do
|
||||
-- Handle errors gracefully
|
||||
hPutStrLn stderr $ "ERROR: " ++ show err
|
||||
respond $ responseLBS
|
||||
status502
|
||||
[("Content-Type", "text/plain")]
|
||||
"Bad Gateway: Could not connect to backend server"
|
||||
|
||||
Right response -> do
|
||||
-- Log response status
|
||||
logResponse response
|
||||
respond response
|
||||
|
||||
-- Forward request to backend server
|
||||
forwardRequest :: Manager -> Request -> IO Response
|
||||
forwardRequest manager clientReq = do
|
||||
-- Build backend URL
|
||||
let backendUrl = "http://" ++ backendHost ++ ":" ++ show backendPort ++ BS8.unpack (rawPathInfo clientReq) ++ BS8.unpack (rawQueryString clientReq)
|
||||
|
||||
-- Parse and build backend request
|
||||
initReq <- parseRequest backendUrl
|
||||
|
||||
let backendReq = initReq
|
||||
{ HTTP.method = requestMethod clientReq
|
||||
, HTTP.requestHeaders = filterHeaders (requestHeaders clientReq)
|
||||
, HTTP.requestBody = RequestBodyLBS LBS.empty -- For now, empty body
|
||||
}
|
||||
|
||||
-- Make request to backend
|
||||
backendResponse <- httpLbs backendReq manager
|
||||
|
||||
-- Convert backend response to WAI response
|
||||
let statusCode = HTTP.responseStatus backendResponse
|
||||
headers = HTTP.responseHeaders backendResponse
|
||||
body = HTTP.responseBody backendResponse
|
||||
|
||||
return $ responseLBS statusCode headers body
|
||||
|
||||
-- Filter headers (remove hop-by-hop headers)
|
||||
filterHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
|
||||
filterHeaders = filter (\(name, _) -> name `notElem` hopByHopHeaders)
|
||||
where
|
||||
hopByHopHeaders =
|
||||
[ "Connection"
|
||||
, "Keep-Alive"
|
||||
, "Proxy-Authenticate"
|
||||
, "Proxy-Authorization"
|
||||
, "TE"
|
||||
, "Trailers"
|
||||
, "Transfer-Encoding"
|
||||
, "Upgrade"
|
||||
]
|
||||
|
||||
-- Log incoming request
|
||||
logRequest :: Request -> IO ()
|
||||
logRequest req = do
|
||||
let method' = BS8.unpack (requestMethod req)
|
||||
path = BS8.unpack (rawPathInfo req)
|
||||
query = BS8.unpack (rawQueryString req)
|
||||
host = fromMaybe "unknown" $ lookup "Host" (requestHeaders req)
|
||||
|
||||
putStrLn $ "[→] " ++ method' ++ " " ++ path ++ query ++ " (Host: " ++ BS8.unpack host ++ ")"
|
||||
|
||||
-- Log response
|
||||
logResponse :: Response -> IO ()
|
||||
logResponse res = do
|
||||
let (Status code msg) = responseStatus res
|
||||
putStrLn $ "[←] " ++ show code ++ " " ++ BS8.unpack msg
|
||||
Loading…
Reference in New Issue