Merge pull request #199 from CarterPerez-dev/chore/haskell-reverse-proxy-finish

Chore/haskell reverse proxy finish

PROJECTS/advanced/encrypted-p2p-chat/backend/app/core/surreal_manager.py

@@ -59,8 +59,22 @@ class SurrealDBManager:
             settings.SURREAL_DATABASE,
         )
 
+        await self._init_schema()
+
         self._connected = True
 
+    async def _init_schema(self) -> None:
+        """
+        Define tables used by the application so empty SELECTs do not error
+        """
+        schema = """
+            DEFINE TABLE IF NOT EXISTS rooms SCHEMALESS;
+            DEFINE TABLE IF NOT EXISTS room_participants SCHEMALESS;
+            DEFINE TABLE IF NOT EXISTS messages SCHEMALESS;
+            DEFINE TABLE IF NOT EXISTS presence SCHEMALESS;
+        """
+        await self.db.query(schema)
+
     async def disconnect(self) -> None:
         """
         Close SurrealDB connection

PROJECTS/advanced/encrypted-p2p-chat/compose.yml

@@ -22,9 +22,9 @@ services:
     restart: always
 
   surrealdb:
-    image: surrealdb/surrealdb:latest
+    image: surrealdb/surrealdb:v3.0.5
     container_name: chat-surrealdb
-    command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} file:/data/database.db
+    command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} rocksdb:/data/database.db
     environment:
       - SURREAL_USER=root
       - SURREAL_PASS=${SURREAL_PASSWORD}

PROJECTS/advanced/encrypted-p2p-chat/conf/docker/dev/vite.docker

@@ -1,17 +1,18 @@
-# ©AngelaMos | 2025
+# ©AngelaMos | 2026
-# Development Vite Dockerfile
+# vite.docker
-# HMR dev server, volume mounts for code
 
 FROM node:22-alpine
 
+RUN corepack enable
+
 WORKDIR /app
 
-COPY frontend/package*.json ./
+COPY frontend/package.json frontend/pnpm-lock.yaml ./
 
-RUN npm ci
+RUN pnpm install --frozen-lockfile
 
 COPY frontend/ .
 
 EXPOSE 5173
 
-CMD ["npm", "run", "dev", "--", "--host", "0.0.0.0"]
+CMD ["pnpm", "run", "dev", "--", "--host", "0.0.0.0"]

PROJECTS/advanced/encrypted-p2p-chat/conf/docker/prod/vite.docker

@@ -1,18 +1,19 @@
-# ©AngelaMos | 2025
+# ©AngelaMos | 2026
-# Production Vite Dockerfile
+# vite.docker
-# Multi-stage: build with node, serve with nginx
 
 FROM node:22-alpine AS builder
 
+RUN corepack enable
+
 WORKDIR /app
 
-COPY frontend/package*.json ./
+COPY frontend/package.json frontend/pnpm-lock.yaml ./
 
-RUN npm ci
+RUN pnpm install --frozen-lockfile
 
 COPY frontend/ .
 
-RUN npm run build
+RUN pnpm run build
 
 FROM nginx:alpine
 

PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml

@@ -13,7 +13,7 @@ services:
     volumes:
       - postgres_dev_data:/var/lib/postgresql/data
     ports:
-      - "${POSTGRES_HOST_PORT:-5432}:5432"
+      - "${POSTGRES_HOST_PORT:-54332}:5432"
     networks:
       - chat_network_dev
     healthcheck:
@@ -23,17 +23,17 @@ services:
       retries: 5
 
   surrealdb:
-    image: surrealdb/surrealdb:latest
+    image: surrealdb/surrealdb:v3.0.5
     container_name: chat-surrealdb-dev
     user: "0:0"
-    command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} file:/data/database.db
+    command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} rocksdb:/data/database.db
     environment:
       - SURREAL_USER=root
       - SURREAL_PASS=${SURREAL_PASSWORD}
     volumes:
       - surreal_dev_data:/data
     ports:
-      - "${SURREAL_HOST_PORT:-8001}:8000"
+      - "${SURREAL_HOST_PORT:-7781}:8000"
     networks:
       - chat_network_dev
     healthcheck:
@@ -55,7 +55,7 @@ services:
     volumes:
       - redis_dev_data:/data
     ports:
-      - "${REDIS_HOST_PORT:-6379}:6379"
+      - "${REDIS_HOST_PORT:-43434}:6379"
     networks:
       - chat_network_dev
     healthcheck:
@@ -82,7 +82,7 @@ services:
       REDIS_URL: ${REDIS_URL:-redis://redis:6379}
       RP_ID: ${RP_ID:-localhost}
       RP_NAME: ${RP_NAME:-Encrypted P2P Chat}
-      RP_ORIGIN: ${RP_ORIGIN:-http://localhost:82}
+      RP_ORIGIN: ${RP_ORIGIN:-http://localhost:32342}
       CORS_ORIGINS: ${CORS_ORIGINS}
     volumes:
       - ./backend:/app
@@ -98,7 +98,7 @@ services:
     networks:
       - chat_network_dev
     ports:
-      - "${BACKEND_HOST_PORT:-8000}:8000"
+      - "${BACKEND_HOST_PORT:-30200}:8000"
     restart: unless-stopped
 
   frontend:
@@ -118,14 +118,14 @@ services:
     networks:
       - chat_network_dev
     ports:
-      - "${FRONTEND_DEV_PORT:-5173}:5173"
+      - "${FRONTEND_DEV_PORT:-34343}:5173"
     restart: unless-stopped
 
   nginx:
     image: nginx:alpine
     container_name: chat-nginx-dev
     ports:
-      - "${NGINX_HTTP_PORT:-80}:80"
+      - "${NGINX_HTTP_PORT:-3234}:80"
     volumes:
       - ./conf/nginx/dev.nginx:/etc/nginx/nginx.conf:ro
       - ./conf/nginx/http.conf:/etc/nginx/http.conf:ro

PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal

@@ -9,7 +9,7 @@ license:             MIT
 license-file:        LICENSE
 author:              Carter Perez
 maintainer:          support@certgames.com
-copyright:           2025 Carter Perez
+copyright:           2026 AngelaMos
 category:            Network, Security, Web
 build-type:          Simple
 extra-source-files:  README.md
@@ -38,6 +38,7 @@ library
                      , Aenebris.WAF.Engine
                      , Aenebris.Honeypot
                      , Aenebris.Geo
+                     , Aenebris.Net.IP
                      , Aenebris.ML.Features
                      , Aenebris.ML.Model
                      , Aenebris.ML.Loader

PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs

@@ -1,47 +1,60 @@
+{-
+©AngelaMos | 2026
+Main.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main (main) where
 
 import Aenebris.Config
+import Aenebris.Connection
+  ( defaultTimeoutConfig
+  , microsPerSecond
+  , tcUpstreamReadSeconds
+  )
 import Aenebris.Proxy
-import Network.HTTP.Client (newManager, defaultManagerSettings)
+import Network.HTTP.Client
+  ( ManagerSettings(..)
+  , defaultManagerSettings
+  , newManager
+  , responseTimeoutMicro
+  )
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
 import System.IO (hPutStrLn, stderr)
 
+defaultConfigPath :: FilePath
+defaultConfigPath = "config.yaml"
+
 main :: IO ()
 main = do
   args <- getArgs
-
-  -- Get config file path from args or use default
   let configPath = case args of
         (path:_) -> path
-        [] -> "config.yaml"
+        []       -> defaultConfigPath
 
   putStrLn $ "Loading configuration from: " ++ configPath
 
   result <- loadConfig configPath
   case result of
     Left err -> do
-      hPutStrLn stderr $ "ERROR: Failed to load configuration"
+      hPutStrLn stderr "ERROR: Failed to load configuration"
       hPutStrLn stderr err
       exitFailure
 
-    Right config -> do
+    Right config -> case validateConfig config of
-      case validateConfig config of
+      Left err -> do
-        Left err -> do
+        hPutStrLn stderr "ERROR: Invalid configuration"
-          hPutStrLn stderr $ "ERROR: Invalid configuration"
+        hPutStrLn stderr err
-          hPutStrLn stderr err
+        exitFailure
-          exitFailure
 
-        Right () -> do
+      Right () -> do
-          putStrLn "Configuration loaded and validated successfully"
+        putStrLn "Configuration loaded and validated successfully"
-
+        let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
-          -- Create HTTP client manager with connection pooling
+                           * microsPerSecond
-          manager <- newManager defaultManagerSettings
+            managerSettings = defaultManagerSettings
-
+              { managerResponseTimeout = responseTimeoutMicro upstreamMicros
-          -- Initialize proxy state (load balancers + health checkers)
+              }
-          proxyState <- initProxyState config manager
+        manager    <- newManager managerSettings
-
+        proxyState <- initProxyState config manager
-          -- Start the proxy
+        startProxy proxyState
-          startProxy proxyState

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Backend.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+Backend.hs
+-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Aenebris.Backend
@@ -22,126 +26,125 @@ import Control.Monad (when)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 
+initialActiveConnections :: Int
+initialActiveConnections = 0
+
+initialCurrentWeight :: Int
+initialCurrentWeight = 0
+
+initialFailureCount :: Int
+initialFailureCount = 0
+
+initialSuccessCount :: Int
+initialSuccessCount = 0
+
+initialMetricCount :: Int
+initialMetricCount = 0
+
 data BackendState
   = Healthy
   | Unhealthy
   | Recovering
   deriving (Eq, Show)
 
--- | Runtime backend state wrapping config Server
 data RuntimeBackend = RuntimeBackend
-  { rbServerId :: Int  -- Unique identifier
+  { rbServerId             :: !Int
-  , rbHost :: Text
+  , rbHost                 :: !Text
-  , rbWeight :: Int
+  , rbWeight               :: !Int
-  -- Runtime state (STM)
+  , rbActiveConnections    :: !(TVar Int)
-  , rbActiveConnections :: TVar Int
+  , rbCurrentWeight        :: !(TVar Int)
-  , rbCurrentWeight :: TVar Int
+  , rbHealthState          :: !(TVar BackendState)
-  , rbHealthState :: TVar BackendState
+  , rbConsecutiveFailures  :: !(TVar Int)
-  , rbConsecutiveFailures :: TVar Int
+  , rbConsecutiveSuccesses :: !(TVar Int)
-  , rbConsecutiveSuccesses :: TVar Int
+  , rbLastHealthCheck      :: !(TVar (Maybe UTCTime))
-  , rbLastHealthCheck :: TVar (Maybe UTCTime)
+  , rbTotalRequests        :: !(TVar Int)
-  , rbTotalRequests :: TVar Int      -- For metrics
+  , rbTotalFailures        :: !(TVar Int)
-  , rbTotalFailures :: TVar Int      -- For metrics
   }
 
 instance Show RuntimeBackend where
-  show rb = "RuntimeBackend {id=" ++ show (rbServerId rb) ++
+  show rb = "RuntimeBackend {id="
-            ", host=" ++ show (rbHost rb) ++ "}"
+              ++ show (rbServerId rb)
+              ++ ", host="
+              ++ show (rbHost rb)
+              ++ ", weight="
+              ++ show (rbWeight 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
+createRuntimeBackend serverId Server{..} = atomically $
-  atomically $ RuntimeBackend serverId serverHost serverWeight
+  RuntimeBackend serverId serverHost serverWeight
-    <$> newTVar 0                    -- activeConnections
+    <$> newTVar initialActiveConnections
-    <*> newTVar 0                    -- currentWeight (for smooth WRR)
+    <*> newTVar initialCurrentWeight
-    <*> newTVar Healthy              -- healthState
+    <*> newTVar Healthy
-    <*> newTVar 0                    -- consecutiveFailures
+    <*> newTVar initialFailureCount
-    <*> newTVar 0                    -- consecutiveSuccesses
+    <*> newTVar initialSuccessCount
-    <*> newTVar Nothing              -- lastHealthCheck
+    <*> newTVar Nothing
-    <*> newTVar 0                    -- totalRequests
+    <*> newTVar initialMetricCount
-    <*> newTVar 0                    -- totalFailures
+    <*> newTVar initialMetricCount
 
--- | 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' (rbActiveConnections rb) (+ 1)
-      modifyTVar' (rbTotalRequests 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 (rbConsecutiveFailures rb) initialFailureCount
-  writeTVar (rbConsecutiveSuccesses rb) 0
+  writeTVar (rbConsecutiveSuccesses rb) initialSuccessCount
 
--- | 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 (rbConsecutiveFailures rb) initialFailureCount
-  writeTVar (rbConsecutiveSuccesses rb) 0
+  writeTVar (rbConsecutiveSuccesses rb) initialSuccessCount
 
--- | Record a health check failure
 recordFailure :: RuntimeBackend -> Int -> STM ()
 recordFailure rb maxFailures = do
+  modifyTVar' (rbTotalFailures rb) (+ 1)
   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 ->
-    Recovering -> do
-      -- Failed during recovery, back to unhealthy
       transitionToUnhealthy rb
-
     Unhealthy ->
-      -- Already unhealthy, just record it
+      pure ()
-      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) initialFailureCount
-      writeTVar (rbConsecutiveFailures rb) 0
-
     Unhealthy ->
-      -- First success, transition to recovering
       transitionToRecovering rb
-
     Recovering -> do
       let newSuccesses = successes + 1
       writeTVar (rbConsecutiveSuccesses rb) newSuccesses

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Config.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+Config.hs
+-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -20,51 +24,63 @@ module Aenebris.Config
 import Aenebris.Honeypot (HoneypotConfigYaml)
 import Aenebris.Geo (GeoConfigYaml)
 
-import Control.Monad (when, forM_)
+import Control.Monad (forM_, when)
 import Data.Aeson
+import Data.List (nub)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Yaml (decodeFileEither)
 import GHC.Generics
 
--- | Main config structure
+supportedConfigVersion :: Int
+supportedConfigVersion = 1
+
+minPort :: Int
+minPort = 1
+
+maxPort :: Int
+maxPort = 65535
+
+minServerWeight :: Int
+minServerWeight = 1
+
 data Config = Config
-  { configVersion :: Int
+  { configVersion   :: !Int
-  , configListen :: [ListenConfig]
+  , configListen    :: ![ListenConfig]
-  , configUpstreams :: [Upstream]
+  , configUpstreams :: ![Upstream]
-  , configRoutes :: [Route]
+  , configRoutes    :: ![Route]
-  , configRateLimit :: Maybe Text
+  , configRateLimit :: !(Maybe Text)
-  , configDDoS :: Maybe DDoSConfig
+  , configDDoS      :: !(Maybe DDoSConfig)
-  , configHoneypot :: Maybe HoneypotConfigYaml
+  , configHoneypot  :: !(Maybe HoneypotConfigYaml)
-  , configGeo :: Maybe GeoConfigYaml
+  , configGeo       :: !(Maybe GeoConfigYaml)
   } deriving (Show, Eq, Generic)
 
 instance FromJSON Config where
   parseJSON = withObject "Config" $ \v -> Config
-    <$> v .: "version"
+    <$> v .:  "version"
-    <*> v .: "listen"
+    <*> v .:  "listen"
-    <*> v .: "upstreams"
+    <*> v .:  "upstreams"
-    <*> v .: "routes"
+    <*> v .:  "routes"
     <*> v .:? "rate_limit"
     <*> v .:? "ddos"
     <*> v .:? "honeypot"
     <*> v .:? "geo"
 
 data DDoSConfig = DDoSConfig
-  { ddosEarlyDataReject :: Bool
+  { ddosEarlyDataReject      :: !Bool
-  , ddosPerIPConnections :: Maybe Int
+  , ddosPerIPConnections     :: !(Maybe Int)
-  , ddosMemoryShedBytes :: Maybe Integer
+  , ddosMemoryShedBytes      :: !(Maybe Integer)
-  , ddosMemoryShedHighWater :: Maybe Double
+  , ddosMemoryShedHighWater  :: !(Maybe Double)
-  , ddosMaxConcurrentStreams :: Maybe Int
+  , ddosMaxConcurrentStreams :: !(Maybe Int)
-  , ddosMaxHeaderBytes :: Maybe Int
+  , ddosMaxHeaderBytes       :: !(Maybe Int)
-  , ddosSlowlorisSeconds :: Maybe Int
+  , ddosSlowlorisSeconds     :: !(Maybe Int)
-  , ddosJailCooldownSeconds :: Maybe Int
+  , ddosJailCooldownSeconds  :: !(Maybe Int)
-  , ddosReusePort :: Bool
+  , ddosReusePort            :: !Bool
   } deriving (Show, Eq, Generic)
 
 instance FromJSON DDoSConfig where
   parseJSON = withObject "DDoSConfig" $ \v -> DDoSConfig
-    <$> v .:? "early_data_reject" .!= True
+    <$> v .:? "early_data_reject"      .!= True
     <*> v .:? "per_ip_connections"
     <*> v .:? "memory_shed_bytes"
     <*> v .:? "memory_shed_high_water"
@@ -72,41 +88,39 @@ instance FromJSON DDoSConfig where
     <*> v .:? "max_header_bytes"
     <*> v .:? "slowloris_seconds"
     <*> v .:? "jail_cooldown_seconds"
-    <*> v .:? "reuse_port" .!= False
+    <*> v .:? "reuse_port"             .!= False
 
 defaultDDoSConfig :: DDoSConfig
 defaultDDoSConfig = DDoSConfig
-  { ddosEarlyDataReject = True
+  { ddosEarlyDataReject      = True
-  , ddosPerIPConnections = Nothing
+  , ddosPerIPConnections     = Nothing
-  , ddosMemoryShedBytes = Nothing
+  , ddosMemoryShedBytes      = Nothing
-  , ddosMemoryShedHighWater = Nothing
+  , ddosMemoryShedHighWater  = Nothing
   , ddosMaxConcurrentStreams = Nothing
-  , ddosMaxHeaderBytes = Nothing
+  , ddosMaxHeaderBytes       = Nothing
-  , ddosSlowlorisSeconds = Nothing
+  , ddosSlowlorisSeconds     = Nothing
-  , ddosJailCooldownSeconds = Nothing
+  , ddosJailCooldownSeconds  = Nothing
-  , ddosReusePort = False
+  , ddosReusePort            = False
   }
 
--- | Listen port configuration
 data ListenConfig = ListenConfig
-  { listenPort :: Int
+  { listenPort          :: !Int
-  , listenTLS :: Maybe TLSConfig
+  , listenTLS           :: !(Maybe TLSConfig)
-  , listenRedirectHTTPS :: Maybe Bool  -- Redirect HTTP to HTTPS?
+  , listenRedirectHTTPS :: !(Maybe Bool)
   } deriving (Show, Eq, Generic)
 
 instance FromJSON ListenConfig where
   parseJSON = withObject "ListenConfig" $ \v -> ListenConfig
-    <$> v .: "port"
+    <$> v .:  "port"
     <*> v .:? "tls"
     <*> v .:? "redirect_https"
 
--- | TLS/SSL configuration (supports both single cert and SNI)
 data TLSConfig = TLSConfig
-  { tlsCert :: Maybe FilePath           -- Single cert (if not using SNI)
+  { tlsCert        :: !(Maybe FilePath)
-  , tlsKey :: Maybe FilePath            -- Single key (if not using SNI)
+  , tlsKey         :: !(Maybe FilePath)
-  , tlsSNI :: Maybe [SNIDomain]         -- SNI domains (multiple certs)
+  , tlsSNI         :: !(Maybe [SNIDomain])
-  , tlsDefaultCert :: Maybe FilePath    -- Default cert for SNI
+  , tlsDefaultCert :: !(Maybe FilePath)
-  , tlsDefaultKey :: Maybe FilePath     -- Default key for SNI
+  , tlsDefaultKey  :: !(Maybe FilePath)
   } deriving (Show, Eq, Generic)
 
 instance FromJSON TLSConfig where
@@ -117,11 +131,10 @@ instance FromJSON TLSConfig where
     <*> v .:? "default_cert"
     <*> v .:? "default_key"
 
--- | SNI domain configuration
 data SNIDomain = SNIDomain
-  { sniDomain :: Text
+  { sniDomain :: !Text
-  , sniCert :: FilePath
+  , sniCert   :: !FilePath
-  , sniKey :: FilePath
+  , sniKey    :: !FilePath
   } deriving (Show, Eq, Generic)
 
 instance FromJSON SNIDomain where
@@ -130,23 +143,21 @@ instance FromJSON SNIDomain where
     <*> v .: "cert"
     <*> v .: "key"
 
--- | Upstream backend definition
 data Upstream = Upstream
-  { upstreamName :: Text
+  { upstreamName        :: !Text
-  , upstreamServers :: [Server]
+  , upstreamServers     :: ![Server]
-  , upstreamHealthCheck :: Maybe HealthCheck
+  , upstreamHealthCheck :: !(Maybe HealthCheck)
   } deriving (Show, Eq, Generic)
 
 instance FromJSON Upstream where
   parseJSON = withObject "Upstream" $ \v -> Upstream
-    <$> v .: "name"
+    <$> v .:  "name"
-    <*> v .: "servers"
+    <*> v .:  "servers"
     <*> v .:? "health_check"
 
--- | Backend server with weight for load balancing
 data Server = Server
-  { serverHost :: Text
+  { serverHost   :: !Text
-  , serverWeight :: Int
+  , serverWeight :: !Int
   } deriving (Show, Eq, Generic)
 
 instance FromJSON Server where
@@ -154,10 +165,9 @@ instance FromJSON Server where
     <$> v .: "host"
     <*> v .: "weight"
 
--- | Health check configuration
 data HealthCheck = HealthCheck
-  { healthCheckPath :: Text
+  { healthCheckPath     :: !Text
-  , healthCheckInterval :: Text  -- e.g., "10s"
+  , healthCheckInterval :: !Text
   } deriving (Show, Eq, Generic)
 
 instance FromJSON HealthCheck where
@@ -165,10 +175,9 @@ instance FromJSON HealthCheck where
     <$> v .: "path"
     <*> v .: "interval"
 
--- | Route definition (virtual host + paths)
 data Route = Route
-  { routeHost :: Text
+  { routeHost  :: !Text
-  , routePaths :: [PathRoute]
+  , routePaths :: ![PathRoute]
   } deriving (Show, Eq, Generic)
 
 instance FromJSON Route where
@@ -176,122 +185,99 @@ instance FromJSON Route where
     <$> v .: "host"
     <*> v .: "paths"
 
--- | Path-based routing rule
 data PathRoute = PathRoute
-  { pathRoutePath :: Text
+  { pathRoutePath      :: !Text
-  , pathRouteUpstream :: Text
+  , pathRouteUpstream  :: !Text
-  , pathRouteRateLimit :: Maybe Text  -- e.g., "100/minute"
+  , pathRouteRateLimit :: !(Maybe Text)
   } deriving (Show, Eq, Generic)
 
 instance FromJSON PathRoute where
   parseJSON = withObject "PathRoute" $ \v -> PathRoute
-    <$> v .: "path"
+    <$> v .:  "path"
-    <*> v .: "upstream"
+    <*> v .:  "upstream"
     <*> v .:? "rate_limit"
 
--- | Load configuration from YAML file
 loadConfig :: FilePath -> IO (Either String Config)
 loadConfig path = do
   result <- decodeFileEither path
-  return $ case result of
+  pure $ case result of
-    Left err -> Left (show err)
+    Left err     -> Left (show err)
     Right config -> Right config
 
--- | Validate configuration for correctness
 validateConfig :: Config -> Either String ()
 validateConfig config = do
-  -- Check version
+  when (configVersion config /= supportedConfigVersion) $
-  when (configVersion config /= 1) $
+    Left ("Unsupported config version (expected: "
-    Left "Unsupported config version (expected: 1)"
+            ++ show supportedConfigVersion ++ ")")
 
-  -- Check at least one listen port
+  when (null (configListen config)) $
-  when (null $ configListen config) $
     Left "At least one listen port must be specified"
 
-  -- Check port numbers are valid
   forM_ (configListen config) $ \listen -> do
     let port = listenPort listen
-    when (port < 1 || port > 65535) $
+    when (port < minPort || port > maxPort) $
-      Left $ "Invalid port number: " ++ show port
+      Left ("Invalid port number: " ++ show port)
-
-    -- Validate TLS configuration if present
     case listenTLS listen of
-      Nothing -> return ()
+      Nothing       -> pure ()
-      Just tlsConf -> validateTLS tlsConf
+      Just tlsConf  -> validateTLS tlsConf
 
-  -- Check at least one upstream
+  when (null (configUpstreams config)) $
-  when (null $ configUpstreams config) $
     Left "At least one upstream must be specified"
 
-  -- Check upstream names are unique
   let upstreamNames = map upstreamName (configUpstreams config)
-  when (length upstreamNames /= length (nubText upstreamNames)) $
+  when (length upstreamNames /= length (nub upstreamNames)) $
     Left "Upstream names must be unique"
 
-  -- Check each upstream has at least one server
   forM_ (configUpstreams config) $ \upstream -> do
-    when (null $ upstreamServers upstream) $
+    when (null (upstreamServers upstream)) $
-      Left $ "Upstream '" ++ T.unpack (upstreamName upstream) ++ "' has no servers"
+      Left ("Upstream '" ++ T.unpack (upstreamName upstream)
+              ++ "' has no servers")
+    forM_ (upstreamServers upstream) $ \server ->
+      when (serverWeight server < minServerWeight) $
+        Left ("Server weight must be positive: "
+                ++ T.unpack (serverHost server))
 
-    -- Check server weights are positive
+  when (null (configRoutes config)) $
-    forM_ (upstreamServers upstream) $ \server -> do
-      when (serverWeight server < 1) $
-        Left $ "Server weight must be positive: " ++ T.unpack (serverHost server)
-
-  -- Check at least one route
-  when (null $ configRoutes config) $
     Left "At least one route must be specified"
 
-  -- Validate upstream references in routes
   forM_ (configRoutes config) $ \route -> do
-    when (null $ routePaths route) $
+    when (null (routePaths route)) $
-      Left $ "Route for host '" ++ T.unpack (routeHost route) ++ "' has no paths"
+      Left ("Route for host '" ++ T.unpack (routeHost route)
-
+              ++ "' has no paths")
     forM_ (routePaths route) $ \pathRoute -> do
       let upstreamRef = pathRouteUpstream pathRoute
       when (upstreamRef `notElem` upstreamNames) $
-        Left $ "Unknown upstream referenced: '" ++ T.unpack upstreamRef ++ "'"
+        Left ("Unknown upstream referenced: '"
+                ++ T.unpack upstreamRef ++ "'")
 
-  return ()
+  pure ()
-  where
-    -- Helper to remove duplicates from Text list
-    nubText :: [Text] -> [Text]
-    nubText [] = []
-    nubText (x:xs) = x : nubText (filter (/= x) xs)
 
-    -- Validate TLS configuration
+validateTLS :: TLSConfig -> Either String ()
-    validateTLS :: TLSConfig -> Either String ()
+validateTLS tlsConf = do
-    validateTLS tlsConf = do
+  let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of
-      let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of
+        (Just _, Just _) -> True
-            (Just _, Just _) -> True
+        _                -> False
-            (Nothing, Nothing) -> False
+      hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
-            _ -> False  -- One is set but not the other
+        (Just sniDomains, Just _, Just _) -> not (null sniDomains)
+        _                                  -> False
 
-          hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
+  when (not hasSingleCert && not hasSNI) $
-            (Just sniDomains, Just _, Just _) -> not (null sniDomains)
+    Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)"
-            _ -> False
 
-      -- Must have either single cert or SNI configuration
+  when (hasSingleCert && hasSNI) $
-      when (not hasSingleCert && not hasSNI) $
+    Left "TLS configuration cannot have both single cert and SNI configuration"
-        Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)"
 
-      -- Can't have both single cert and SNI
+  when hasSingleCert $
-      when (hasSingleCert && hasSNI) $
+    case (tlsCert tlsConf, tlsKey tlsConf) of
-        Left "TLS configuration cannot have both single cert and SNI configuration"
+      (Just _, Nothing) -> Left "TLS cert specified but key missing"
+      (Nothing, Just _) -> Left "TLS key specified but cert missing"
+      _                 -> pure ()
 
-      -- If single cert, ensure both cert and key are present
+  when hasSNI $
-      when (hasSingleCert) $ do
+    case (tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
-        case (tlsCert tlsConf, tlsKey tlsConf) of
+      (Just _, Nothing)     -> Left "SNI default_cert specified but default_key missing"
-          (Just _, Nothing) -> Left "TLS cert specified but key missing"
+      (Nothing, Just _)     -> Left "SNI default_key specified but default_cert missing"
-          (Nothing, Just _) -> Left "TLS key specified but cert missing"
+      (Nothing, Nothing)    -> Left "SNI configuration requires default_cert and default_key"
-          _ -> return ()
+      _                     -> pure ()
 
-      -- If SNI, ensure default cert/key are present
+  pure ()
-      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 ()

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Connection.hs

@@ -1,3 +1,8 @@
+{-
+©AngelaMos | 2026
+Connection.hs
+-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -10,14 +15,14 @@ module Aenebris.Connection
   , isWebSocketUpgrade
   , isStreamingResponse
   , getTimeout
+  , microsPerSecond
+  , httpOkStatusCode
   ) where
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-import Data.Maybe (isJust, fromMaybe)
+import Data.Maybe (isJust)
 import Network.HTTP.Types (HeaderName, Status, statusCode)
 
 data ConnectionState
@@ -35,23 +40,31 @@ data ConnectionType
   | ChunkedStream
   deriving (Eq, Show)
 
+microsPerSecond :: Int
+microsPerSecond = 1_000_000
+
+httpOkStatusCode :: Int
+httpOkStatusCode = 200
+
 data TimeoutConfig = TimeoutConfig
-  { tcHttpIdle :: Int
+  { tcHttpIdle           :: !Int
-  , tcWebSocketTunnel :: Int
+  , tcWebSocketTunnel    :: !Int
-  , tcStreamingResponse :: Int
+  , tcStreamingResponse  :: !Int
-  , tcProxyPingInterval :: Int
+  , tcProxyPingInterval  :: !Int
-  , tcPongTimeout :: Int
+  , tcPongTimeout        :: !Int
-  , tcConnectTimeout :: Int
+  , tcConnectTimeout     :: !Int
+  , tcUpstreamReadSeconds :: !Int
   }
 
 defaultTimeoutConfig :: TimeoutConfig
 defaultTimeoutConfig = TimeoutConfig
-  { tcHttpIdle = 60
+  { tcHttpIdle            = 60
-  , tcWebSocketTunnel = 3600
+  , tcWebSocketTunnel     = 3600
-  , tcStreamingResponse = 3600
+  , tcStreamingResponse   = 3600
-  , tcProxyPingInterval = 30
+  , tcProxyPingInterval   = 30
-  , tcPongTimeout = 10
+  , tcPongTimeout         = 10
-  , tcConnectTimeout = 5
+  , tcConnectTimeout      = 5
+  , tcUpstreamReadSeconds = 30
   }
 
 getTimeout :: TimeoutConfig -> ConnectionState -> Int
@@ -96,4 +109,7 @@ isStreamingResponse status headers =
 
     hasContentLength = isJust (lookup "Content-Length" headers)
 
-    isUnknownLength = statusCode status == 200 && not hasContentLength && not hasTransferEncodingChunked
+    isUnknownLength =
+      statusCode status == httpOkStatusCode
+        && not hasContentLength
+        && not hasTransferEncodingChunked

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs

@@ -28,18 +28,11 @@ import Control.Concurrent.STM
   , readTVar
   , writeTVar
   )
+import Aenebris.Net.IP (sockAddrToIPBytes)
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as BS8
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Network.Socket
+import Network.Socket (SockAddr)
-  ( HostAddress6
-  , SockAddr(..)
-  , hostAddress6ToTuple
-  , hostAddressToTuple
-  )
-import Numeric (showHex)
-import Text.Printf (printf)
 
 defaultPerIPLimit :: Int
 defaultPerIPLimit = 16
@@ -86,24 +79,10 @@ currentCount ConnLimiter{..} ip = do
   pure (Map.findWithDefault 0 ip m)
 
 connLimitOnOpen :: ConnLimiter -> SockAddr -> IO Bool
-connLimitOnOpen cl sa = atomically (tryAcquire cl (ipBytesFromSockAddr sa))
+connLimitOnOpen cl sa = atomically (tryAcquire cl (sockAddrToIPBytes sa))
 
 connLimitOnClose :: ConnLimiter -> SockAddr -> IO ()
-connLimitOnClose cl sa = atomically (release cl (ipBytesFromSockAddr sa))
+connLimitOnClose cl sa = atomically (release cl (sockAddrToIPBytes sa))
 
 ipBytesFromSockAddr :: SockAddr -> ByteString
-ipBytesFromSockAddr (SockAddrInet _ ha) =
+ipBytesFromSockAddr = sockAddrToIPBytes
-  let (a, b, c, d) = hostAddressToTuple ha
-  in BS8.pack (printf "%d.%d.%d.%d" a b c d)
-ipBytesFromSockAddr (SockAddrInet6 _ _ ha6 _) = v6Bytes ha6
-ipBytesFromSockAddr (SockAddrUnix p) = BS8.pack ("unix:" <> p)
-
-v6Bytes :: HostAddress6 -> ByteString
-v6Bytes ha =
-  let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha
-  in BS8.pack (joinColons (map (`showHex` "") [a, b, c, d, e, f, g, h]))
-
-joinColons :: [String] -> String
-joinColons [] = ""
-joinColons [x] = x
-joinColons (x : xs) = x <> ":" <> joinColons xs

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Fingerprint/JA4H.hs

@@ -88,11 +88,6 @@ refererHeaderName = "referer"
 acceptLanguageHeaderName :: CI ByteString
 acceptLanguageHeaderName = "accept-language"
 
-lookupCI :: CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
-lookupCI k hs = case filter ((== k) . fst) hs of
-  ((_, v) : _) -> Just v
-  _ -> Nothing
-
 acceptLanguagePrefix :: ByteString -> ByteString
 acceptLanguagePrefix bs =
   let firstTag = BS.takeWhile (\c -> c /= 0x2c && c /= 0x3b && c /= 0x20) bs
@@ -136,7 +131,7 @@ computeJA4H req =
         filter (\(k, _) -> k /= cookieHeaderName && k /= refererHeaderName) rawHeaders
       headerCount = padTwo (length filteredHeaders)
       langPrefix = maybe "0000" acceptLanguagePrefix
-                 $ lookupCI acceptLanguageHeaderName rawHeaders
+                 $ lookup acceptLanguageHeaderName rawHeaders
       partA = BS.concat [method, version, cookieFlag, refererFlag, headerCount, langPrefix]
       headerNameList = BS.intercalate "," (map (CI.original . fst) filteredHeaders)
       headerHash = hashTruncated headerNameList

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Geo.hs

@@ -60,9 +60,11 @@ import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as LBS
 import Data.GeoIP2 (GeoDB, GeoResult(..), AS(..), findGeoData, openGeoDB)
 import Data.IP (IP(..), fromHostAddress, fromHostAddress6)
+import Data.List (minimumBy)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe, isJust)
+import Data.Ord (comparing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@@ -95,6 +97,9 @@ defaultGeoSweepIntervalMicros = 60_000_000
 defaultGeoFlaggedAsns :: [Int]
 defaultGeoFlaggedAsns = []
 
+defaultGeoAsnCountCap :: Int
+defaultGeoAsnCountCap = 200_000
+
 geoResponseHeaderName :: HeaderName
 geoResponseHeaderName = "x-aenebris-geo"
 
@@ -262,9 +267,20 @@ bumpAsnCounter Geo{..} n now = do
           | now - awWindowStart w < window ->
               w { awCount = awCount w + 1 }
         _ -> AsnWindow { awCount = 1, awWindowStart = now }
-  writeTVar geoAsnCounts $! Map.insert n entry m
+      inserted = Map.insert n entry m
+      bounded = capAsnCounts inserted
+  writeTVar geoAsnCounts $! bounded
   pure (awCount entry)
 
+capAsnCounts :: Map Int AsnWindow -> Map Int AsnWindow
+capAsnCounts m
+  | Map.size m <= defaultGeoAsnCountCap = m
+  | otherwise =
+      let oldestKey = fst $ minimumBy
+            (comparing (awWindowStart . snd))
+            (Map.toList m)
+      in Map.delete oldestKey m
+
 asnConcentrationScore :: Geo -> Int -> Double
 asnConcentrationScore Geo{..} count =
   let threshold = max 1 (gcConcentrationThreshold geoConfig)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/HealthCheck.hs

@@ -1,5 +1,9 @@
-{-# LANGUAGE RecordWildCards #-}
+{-
+©AngelaMos | 2026
+HealthCheck.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Aenebris.HealthCheck
   ( HealthCheckConfig(..)
@@ -10,10 +14,11 @@ module Aenebris.HealthCheck
   ) where
 
 import Aenebris.Backend
+import Aenebris.Connection (httpOkStatusCode, microsPerSecond)
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
-import Control.Monad (forever)
+import Control.Monad (forever, zipWithM_)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
@@ -21,71 +26,67 @@ import Network.HTTP.Client
 import Network.HTTP.Types.Status (statusCode)
 import System.Timeout (timeout)
 
--- | Health check configuration
+defaultHealthCheckIntervalSeconds :: Int
+defaultHealthCheckIntervalSeconds = 10
+
+defaultHealthCheckTimeoutSeconds :: Int
+defaultHealthCheckTimeoutSeconds = 2
+
+defaultHealthCheckMaxFailures :: Int
+defaultHealthCheckMaxFailures = 3
+
+defaultHealthCheckRecoveryAttempts :: Int
+defaultHealthCheckRecoveryAttempts = 2
+
+defaultHealthCheckEndpoint :: Text
+defaultHealthCheckEndpoint = "/health"
+
 data HealthCheckConfig = HealthCheckConfig
-  { hcInterval :: Int           -- Seconds between checks
+  { hcInterval         :: !Int
-  , hcTimeout :: Int            -- Request timeout (seconds)
+  , hcTimeout          :: !Int
-  , hcEndpoint :: Text          -- Health endpoint path (e.g., "/health")
+  , hcEndpoint         :: !Text
-  , hcMaxFailures :: Int        -- Failures before marking unhealthy
+  , hcMaxFailures      :: !Int
-  , hcRecoveryAttempts :: Int   -- Successes before marking healthy
+  , hcRecoveryAttempts :: !Int
   }
 
--- | Default health check configuration
 defaultHealthCheckConfig :: HealthCheckConfig
 defaultHealthCheckConfig = HealthCheckConfig
-  { hcInterval = 10
+  { hcInterval         = defaultHealthCheckIntervalSeconds
-  , hcTimeout = 2
+  , hcTimeout          = defaultHealthCheckTimeoutSeconds
-  , hcEndpoint = "/health"
+  , hcEndpoint         = defaultHealthCheckEndpoint
-  , hcMaxFailures = 3
+  , hcMaxFailures      = defaultHealthCheckMaxFailures
-  , hcRecoveryAttempts = 2
+  , hcRecoveryAttempts = defaultHealthCheckRecoveryAttempts
   }
 
--- | Start health checker (returns Async handle for stopping)
+startHealthChecker
-startHealthChecker :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ())
+  :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ())
 startHealthChecker manager config backends =
-  async $ healthCheckLoop 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 * microsPerSecond)
 
-  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)
-
+  result <- timeout (hcTimeout config * microsPerSecond) $ do
-  -- Try to make request with timeout
-  result <- timeout (hcTimeout config * 1000000) $ do
     req <- parseRequest url
     response <- httpLbs req manager
-    return $ statusCode (responseStatus response) == 200
+    pure (statusCode (responseStatus response) == httpOkStatusCode)
-
-  -- Update last check time
   now <- getCurrentTime
   atomically $ writeTVar (rbLastHealthCheck backend) (Just now)
-
+  pure $ case result of
-  return $ case result of
     Just True -> True
-    _ -> False
+    _         -> 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)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs

@@ -47,7 +47,7 @@ import qualified Data.Text.Encoding as TE
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
-import Network.HTTP.Types (Status, mkStatus)
+import Network.HTTP.Types (status200, status404)
 import Network.Wai
   ( Middleware
   , Response
@@ -219,12 +219,6 @@ trapLabel :: TrapPattern -> ByteString
 trapLabel (TrapExact e) = e
 trapLabel (TrapPrefix p) = p <> "*"
 
-status404 :: Status
-status404 = mkStatus 404 "Not Found"
-
-status200 :: Status
-status200 = mkStatus 200 "OK"
-
 honeypotMiddleware :: HoneypotConfig -> Maybe IPJail -> Middleware
 honeypotMiddleware cfg@HoneypotConfig{..} mJail app req respond
   | hpServeRobotsTxt && requestMethod req == "GET"
@@ -280,7 +274,7 @@ robotsResponse cfg =
 robotsTxtBody :: HoneypotConfig -> ByteString
 robotsTxtBody HoneypotConfig{..} = BS.concat $
   [ "User-agent: *\n"
-  , "# Honeypot trap paths — Disallow per RFC 9309. Visiting these\n"
+  , "# Honeypot trap paths. Disallow per RFC 9309. Visiting these\n"
   , "# paths is treated as a violation signal regardless of declared UA.\n"
   ] <> map disallowLine hpPatterns
   where

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/LoadBalancer.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+LoadBalancer.hs
+-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Aenebris.LoadBalancer
@@ -9,142 +13,94 @@ module Aenebris.LoadBalancer
 
 import Aenebris.Backend
 import Control.Concurrent.STM
+import Control.Monad (filterM, forM_)
 import Data.IORef
-import Data.List (minimumBy, find)
+import Data.List (maximumBy, minimumBy)
 import Data.Ord (comparing)
 import qualified Data.Vector as V
 import Data.Vector (Vector, (!))
 
--- | Load balancing strategy
+initialRoundRobinIndex :: Int
+initialRoundRobinIndex = 0
+
 data LoadBalancerStrategy
   = RoundRobin
   | LeastConnections
   | WeightedRoundRobin
   deriving (Eq, Show)
 
--- | Load balancer state
 data LoadBalancer = LoadBalancer
-  { lbBackends :: Vector RuntimeBackend
+  { lbBackends  :: !(Vector RuntimeBackend)
-  , lbStrategy :: LoadBalancerStrategy
+  , lbStrategy  :: !LoadBalancerStrategy
-  , lbRRCounter :: IORef Int  -- For round robin
+  , lbRRCounter :: !(IORef Int)
   }
 
--- | Create a load balancer for given backends
+createLoadBalancer
-createLoadBalancer :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer
+  :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer
 createLoadBalancer strategy backends = do
-  counter <- newIORef 0
+  counter <- newIORef initialRoundRobinIndex
-  return LoadBalancer
+  pure LoadBalancer
-    { lbBackends = V.fromList backends
+    { lbBackends  = V.fromList backends
-    , lbStrategy = strategy
+    , lbStrategy  = strategy
     , lbRRCounter = counter
     }
 
--- | Select a backend using the configured strategy
 selectBackend :: LoadBalancer -> IO (Maybe RuntimeBackend)
-selectBackend lb =
+selectBackend lb = case lbStrategy lb of
-  case lbStrategy lb of
+  RoundRobin         -> selectRoundRobin lb
-    RoundRobin -> selectRoundRobin lb
+  LeastConnections   -> selectLeastConnections lb
-    LeastConnections -> selectLeastConnections lb
+  WeightedRoundRobin -> selectWeightedRR 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
+      len      = V.length backends
-
   if len == 0
-    then return Nothing
+    then pure 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
-findHealthyBackend :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend)
+  :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend)
-findHealthyBackend backends startIdx totalBackends =
+findHealthyBackend backends startIdx totalBackends = go startIdx totalBackends
-  go startIdx totalBackends
   where
     len = V.length backends
-
     go currentIdx remaining
-      | remaining <= 0 = return Nothing  -- Tried all, none healthy
+      | remaining <= 0 = pure Nothing
       | otherwise = do
           let backend = backends ! currentIdx
-          healthy <- atomically $ isHealthy backend
+          healthy <- atomically (isHealthy backend)
-
           if healthy
-            then return (Just backend)
+            then pure (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
+    [] -> pure Nothing
-    backends' -> do
+    chosen -> do
-      -- Get connection counts for all healthy backends
+      counts <- mapM getConnectionCount chosen
-      counts <- mapM getConnectionCount backends'
+      let (_, minBackend) = minimumBy (comparing fst) (zip counts chosen)
+      pure (Just minBackend)
 
-      -- 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
+    [] -> pure Nothing
-    backends' -> do
+    chosen -> do
-      -- Step 1: Increase each backend's current weight by its base weight
+      forM_ chosen $ \rb ->
-      forM_ backends' $ \rb -> do
+        modifyTVar' (rbCurrentWeight rb) (+ rbWeight rb)
-        currentW <- readTVar (rbCurrentWeight rb)
+      tagged <- mapM
-        let newWeight = currentW + rbWeight rb
+        (\rb -> (\w -> (w, rb)) <$> readTVar (rbCurrentWeight rb))
-        writeTVar (rbCurrentWeight rb) newWeight
+        chosen
-
+      let (_, picked) = maximumBy (comparing fst) tagged
-      -- Step 2: Select backend with maximum current weight
+          totalWeight = sum (map rbWeight chosen)
-      weights <- mapM getCurrentWeight backends'
+      modifyTVar' (rbCurrentWeight picked) (subtract totalWeight)
-      let maxWeight = maximum weights
+      pure (Just picked)
-          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)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Features.hs

@@ -494,17 +494,17 @@ extractFeatures FeatureContext{..} req =
   let !headers       = requestHeaders req
       !path          = rawPathInfo req
       !method        = requestMethod req
-      !mAcceptLang   = lookupCI acceptLanguageHeader headers
+      !mAcceptLang   = lookup acceptLanguageHeader headers
-      !mUserAgent    = lookupCI userAgentHeader headers
+      !mUserAgent    = lookup userAgentHeader headers
-      !mAcceptEnc    = lookupCI acceptEncodingHeader headers
+      !mAcceptEnc    = lookup acceptEncodingHeader headers
-      !mReferer      = lookupCI refererHeader headers
+      !mReferer      = lookup refererHeader headers
-      !mCookie       = lookupCI cookieHeader headers
+      !mCookie       = lookup cookieHeader headers
-      !mSecChUa      = lookupCI secChUaHeader headers
+      !mSecChUa      = lookup secChUaHeader headers
-      !mSecChPlat    = lookupCI secChUaPlatformHeader headers
+      !mSecChPlat    = lookup secChUaPlatformHeader headers
-      !mSecFetchSite = lookupCI secFetchSiteHeader headers
+      !mSecFetchSite = lookup secFetchSiteHeader headers
-      !mSecFetchMode = lookupCI secFetchModeHeader headers
+      !mSecFetchMode = lookup secFetchModeHeader headers
-      !mSecFetchDest = lookupCI secFetchDestHeader headers
+      !mSecFetchDest = lookup secFetchDestHeader headers
-      !mAccept       = lookupCI acceptHeader headers
+      !mAccept       = lookup acceptHeader headers
       !uaBytes       = fromMaybe BS.empty mUserAgent
       !uaLen         = BS.length uaBytes
       !depth         = pathDepth path
@@ -552,8 +552,3 @@ extractFeatures FeatureContext{..} req =
        , fHeaderOrderCanonical    = boolToDouble
                                       (headerOrderIsCanonicalBrowser headers)
        }
-
-lookupCI :: CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
-lookupCI k hs = case filter ((== k) . fst) hs of
-  ((_, v) : _) -> Just v
-  _            -> Nothing

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/IForest.hs

@@ -16,6 +16,7 @@ module Aenebris.ML.IForest
   , minSubsampleForNormalization
   , defaultIForestNumTrees
   , defaultIForestSubsampleSize
+  , maxIForestDepth
   ) where
 
 import Data.Vector (Vector)
@@ -44,6 +45,12 @@ defaultIForestNumTrees = 100
 defaultIForestSubsampleSize :: Int
 defaultIForestSubsampleSize = 256
 
+maxIForestDepth :: Int
+maxIForestDepth = 64
+
+depthBoundLeafSize :: Int
+depthBoundLeafSize = 1
+
 data ITree
   = ITreeLeaf !Int
   | ITreeSplit !Int !Double !ITree !ITree
@@ -77,14 +84,17 @@ averagePathLength !trees !fv =
     addPath !acc !tree = acc + pathLength tree fv initialDepth
 
 pathLength :: ITree -> VU.Vector Double -> Int -> Double
-pathLength !tree !fv !currentDepth = case tree of
+pathLength !tree !fv !currentDepth
-  ITreeLeaf !size ->
+  | currentDepth >= maxIForestDepth =
-    fromIntegral currentDepth + normalizationConstant size
+      fromIntegral currentDepth + normalizationConstant depthBoundLeafSize
-  ITreeSplit !featIdx !thr !left !right ->
+  | otherwise = case tree of
-    let !fval = fv VU.! featIdx
+      ITreeLeaf !size ->
-    in if fval <= thr
+        fromIntegral currentDepth + normalizationConstant size
-         then pathLength left  fv (currentDepth + 1)
+      ITreeSplit !featIdx !thr !left !right ->
-         else pathLength right fv (currentDepth + 1)
+        let !fval = fv VU.! featIdx
+        in if fval <= thr
+             then pathLength left  fv (currentDepth + 1)
+             else pathLength right fv (currentDepth + 1)
 
 normalizationConstant :: Int -> Double
 normalizationConstant n

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Loader.hs

@@ -44,6 +44,12 @@ requiredNumClass = 1
 requiredNumTreePerIteration :: Int
 requiredNumTreePerIteration = 1
 
+maxNumLeaves :: Int
+maxNumLeaves = 4096
+
+maxNumTrees :: Int
+maxNumTrees = 10000
+
 postParseLineSentinel :: Int
 postParseLineSentinel = -1
 
@@ -355,18 +361,26 @@ requireField key mv = case mv of
       ("Missing required header key: " <> key))
 
 runTrees :: [(Int, Text)] -> Either ParseError [Tree]
-runTrees lns = case dropWhile (lineIsBlank . snd) lns of
+runTrees = goTrees 0
-  [] -> Right []
+  where
-  ((n, ln):rest)
+    goTrees :: Int -> [(Int, Text)] -> Either ParseError [Tree]
-    | T.strip ln == endOfTreesMarker -> Right []
+    goTrees treeCount lns
-    | T.isPrefixOf baseTreeKeyPrefix (T.strip ln) -> do
+      | treeCount > maxNumTrees = Left
-        let (block, after) = break (lineIsBlank . snd) rest
+          (ParseError postParseLineSentinel treeKey
-        tree <- parseTreeBlock block
+            ("Tree count exceeds maxNumTrees "
-        more <- runTrees after
+             <> T.pack (show maxNumTrees)))
-        Right (tree : more)
+      | otherwise = case dropWhile (lineIsBlank . snd) lns of
-    | otherwise -> Left
+          [] -> Right []
-        (ParseError n treeKey
+          ((n, ln):rest)
-          ("Expected 'Tree=N' or 'end of trees', got: " <> ln))
+            | T.strip ln == endOfTreesMarker -> Right []
+            | T.isPrefixOf baseTreeKeyPrefix (T.strip ln) -> do
+                let (block, after) = break (lineIsBlank . snd) rest
+                tree <- parseTreeBlock block
+                more <- goTrees (treeCount + 1) after
+                Right (tree : more)
+            | otherwise -> Left
+                (ParseError n treeKey
+                  ("Expected 'Tree=N' or 'end of trees', got: " <> ln))
 
 parseTreeBlock :: [(Int, Text)] -> Either ParseError Tree
 parseTreeBlock block = do
@@ -428,6 +442,14 @@ assignTreeField acc n key val
 finalizeTree :: TreeAcc -> Either ParseError Tree
 finalizeTree acc = do
   nL <- requireField keyNumLeaves (taNumLeaves acc)
+  unless (nL > 0)
+    (Left (ParseError postParseLineSentinel keyNumLeaves
+            ("num_leaves must be positive: " <> T.pack (show nL))))
+  unless (nL <= maxNumLeaves)
+    (Left (ParseError postParseLineSentinel keyNumLeaves
+            ("num_leaves " <> T.pack (show nL)
+             <> " exceeds maxNumLeaves "
+             <> T.pack (show maxNumLeaves))))
   nC <- requireField keyNumCat (taNumCat acc)
   leafValues <- requireField keyLeafValue (taLeafValue acc)
   unless (length leafValues == nL)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Middleware.hs

@@ -54,7 +54,7 @@ challengeWireText :: ByteString
 challengeWireText = "challenge"
 
 botBlockBody :: LBS.ByteString
-botBlockBody = "403 Forbidden \x2014 request blocked by Aenebris ML"
+botBlockBody = "403 Forbidden - request blocked by Aenebris ML"
 
 challengePageBody :: LBS.ByteString
 challengePageBody =

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Model.hs

@@ -329,15 +329,19 @@ validateCategoricalNode
   :: Int -> Int -> Tree -> Int -> Int -> Int -> Int -> Either String ()
 validateCategoricalNode featureCount nodeCount t i fIdx lIdx rIdx = do
   validateSplitNode featureCount nodeCount i fIdx lIdx rIdx
-  let catIdx = floor (treeThreshold t VU.! i) :: Int
+  let rawThreshold = treeThreshold t VU.! i
-      nBound = VU.length (treeCatBoundaries t)
+      catIdx       = floor rawThreshold :: Int
-  if nBound < 2
+      nBound       = VU.length (treeCatBoundaries t)
+  if fromIntegral catIdx /= rawThreshold
     then Left ("Categorical node " <> show i
-               <> " requires non-empty cat_boundaries")
+               <> " has non-integer threshold " <> show rawThreshold)
-    else if catIdx < 0 || catIdx >= nBound - 1
+    else if nBound < 2
       then Left ("Categorical node " <> show i
-                 <> " has out-of-range bitmap slice index " <> show catIdx)
+                 <> " requires non-empty cat_boundaries")
-      else Right ()
+      else if catIdx < 0 || catIdx >= nBound - 1
+        then Left ("Categorical node " <> show i
+                   <> " has out-of-range bitmap slice index " <> show catIdx)
+        else Right ()
 
 validateEnsemble :: Int -> Ensemble -> Either String ()
 validateEnsemble expectedFeatures ens = do

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Redirect.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+Redirect.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Aenebris.Middleware.Redirect
@@ -7,38 +11,44 @@ module Aenebris.Middleware.Redirect
 
 import qualified Data.ByteString.Char8 as BS
 import Data.Maybe (fromMaybe)
-import Network.HTTP.Types (status301, hLocation)
+import Network.HTTP.Types (hLocation, status301)
-import Network.Wai (Middleware, responseLBS, requestHeaderHost, rawPathInfo, rawQueryString, isSecure)
+import Network.Wai
+  ( Middleware
+  , isSecure
+  , rawPathInfo
+  , rawQueryString
+  , requestHeaderHost
+  , responseLBS
+  )
+
+defaultHostFallback :: BS.ByteString
+defaultHostFallback = "localhost"
+
+httpsScheme :: BS.ByteString
+httpsScheme = "https://"
+
+standardHttpsPort :: Int
+standardHttpsPort = 443
+
+redirectBody :: BS.ByteString
+redirectBody = "Redirecting to HTTPS"
 
--- | 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
+  | isSecure req = app req respond
   | otherwise = do
-      -- Get host from Host header
+      let hostHeader = fromMaybe defaultHostFallback (requestHeaderHost req)
-      let hostHeader = fromMaybe "localhost" $ requestHeaderHost req
-
-          -- Build HTTPS URL with optional port
           host = case httpsPort of
-            Nothing -> hostHeader  -- Standard 443, don't include port
+            Nothing                          -> hostHeader
-            Just 443 -> hostHeader  -- Standard 443, don't include port
+            Just port | port == standardHttpsPort -> hostHeader
             Just port -> hostHeader <> ":" <> BS.pack (show port)
-
+          path        = rawPathInfo req
-          -- Get path and query string (already encoded in rawPathInfo)
+          query       = rawQueryString req
-          path = rawPathInfo req
+          redirectUrl = httpsScheme <> host <> path <> query
-          query = rawQueryString req
-
-          -- Build full redirect URL
-          redirectUrl = "https://" <> host <> path <> query
-
-      -- Send 301 permanent redirect
       respond $ responseLBS
         status301
         [(hLocation, redirectUrl)]
-        "Redirecting to HTTPS"
+        (BS.fromStrict redirectBody)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Security.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+Security.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Aenebris.Middleware.Security
@@ -11,125 +15,101 @@ module Aenebris.Middleware.Security
 
 import Data.ByteString (ByteString)
 import qualified Data.CaseInsensitive as CI
+import Data.Maybe (catMaybes)
 import Network.HTTP.Types (Header, ResponseHeaders)
 import Network.Wai (Middleware, mapResponseHeaders)
 
--- | Security level presets
 data SecurityLevel
-  = Testing      -- Short HSTS, permissive CSP, for development
+  = Testing
-  | Production   -- Balanced security for production
+  | Production
-  | Strict       -- Maximum security, strict CSP, HSTS preload
+  | Strict
   deriving (Show, Eq)
 
--- | Security configuration
 data SecurityConfig = SecurityConfig
-  { scHSTS :: Maybe ByteString                  -- Strict-Transport-Security header
+  { scHSTS                :: !(Maybe ByteString)
-  , scCSP :: Maybe ByteString                   -- Content-Security-Policy header
+  , scCSP                 :: !(Maybe ByteString)
-  , scFrameOptions :: Maybe ByteString          -- X-Frame-Options header
+  , scFrameOptions        :: !(Maybe ByteString)
-  , scContentTypeOptions :: Bool                -- X-Content-Type-Options: nosniff
+  , scContentTypeOptions  :: !Bool
-  , scReferrerPolicy :: Maybe ByteString        -- Referrer-Policy header
+  , scReferrerPolicy      :: !(Maybe ByteString)
-  , scPermissionsPolicy :: Maybe ByteString     -- Permissions-Policy header
+  , scPermissionsPolicy   :: !(Maybe ByteString)
-  , scXSSProtection :: Maybe ByteString         -- X-XSS-Protection (legacy, but some crawlers check)
+  , scXSSProtection       :: !(Maybe ByteString)
-  , scExpectCT :: Maybe ByteString              -- Expect-CT (transitional)
+  , scExpectCT            :: !(Maybe ByteString)
-  , scServerHeader :: Maybe ByteString          -- Server header (hide or customize)
+  , scServerHeader        :: !(Maybe ByteString)
-  , scRemovePoweredBy :: Bool                   -- Remove X-Powered-By headers
+  , scRemovePoweredBy     :: !Bool
   } 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
+  { scHSTS                = Just "max-age=300"
-  , scCSP = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'"
+  , scCSP                 = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'"
-  , scFrameOptions = Just "SAMEORIGIN"
+  , scFrameOptions        = Just "SAMEORIGIN"
-  , scContentTypeOptions = True
+  , scContentTypeOptions  = True
-  , scReferrerPolicy = Just "strict-origin-when-cross-origin"
+  , scReferrerPolicy      = Just "strict-origin-when-cross-origin"
-  , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()"
+  , scPermissionsPolicy   = Just "geolocation=(), microphone=(), camera=()"
-  , scXSSProtection = Just "1; mode=block"
+  , scXSSProtection       = Just "1; mode=block"
-  , scExpectCT = Nothing
+  , scExpectCT            = Nothing
-  , scServerHeader = Just "Aenebris/0.1.0"
+  , scServerHeader        = Just "Aenebris/0.1.0"
-  , scRemovePoweredBy = True
+  , scRemovePoweredBy     = True
   }
 
--- | Production security configuration
--- Balanced security, 1-month HSTS
 defaultSecurityConfig :: SecurityConfig
 defaultSecurityConfig = SecurityConfig
-  { scHSTS = Just "max-age=2592000; includeSubDomains"  -- 30 days
+  { scHSTS                = Just "max-age=2592000; includeSubDomains"
-  , 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'"
+  , 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"
+  , scFrameOptions        = Just "DENY"
-  , scContentTypeOptions = True
+  , scContentTypeOptions  = True
-  , scReferrerPolicy = Just "strict-origin-when-cross-origin"
+  , scReferrerPolicy      = Just "strict-origin-when-cross-origin"
-  , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()"
+  , scPermissionsPolicy   = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()"
-  , scXSSProtection = Just "1; mode=block"
+  , scXSSProtection       = Just "1; mode=block"
-  , scExpectCT = Just "max-age=86400, enforce"
+  , scExpectCT            = Just "max-age=86400, enforce"
-  , scServerHeader = Just "Aenebris"  -- Don't reveal version in production
+  , scServerHeader        = Just "Aenebris"
-  , scRemovePoweredBy = True
+  , 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
+  { scHSTS                = Just "max-age=63072000; includeSubDomains; 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"
+  , 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"
+  , scFrameOptions        = Just "DENY"
-  , scContentTypeOptions = True
+  , scContentTypeOptions  = True
-  , scReferrerPolicy = Just "no-referrer"  -- Strictest, no referrer leakage
+  , scReferrerPolicy      = Just "no-referrer"
-  , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()"
+  , scPermissionsPolicy   = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()"
-  , scXSSProtection = Just "1; mode=block"
+  , scXSSProtection       = Just "1; mode=block"
-  , scExpectCT = Just "max-age=86400, enforce"
+  , scExpectCT            = Just "max-age=86400, enforce"
-  , scServerHeader = Nothing  -- Hide completely
+  , scServerHeader        = Nothing
-  , scRemovePoweredBy = True
+  , 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
+  let cleaned = if scRemovePoweredBy config
-    -- Remove headers we want to control
+                  then filter (not . isPoweredBy) headers
-    cleaned = if scRemovePoweredBy config
+                  else headers
-              then filter (not . isPoweredBy) headers
+      newHeaders = catMaybes
-              else headers
+        [ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config)
-
+        , fmap (\v -> ("Content-Security-Policy", v)) (scCSP config)
-    -- Build new security headers
+        , fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config)
-    newHeaders = catMaybes
+        , if scContentTypeOptions config
-      [ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config)
+            then Just ("X-Content-Type-Options", "nosniff")
-      , fmap (\v -> ("Content-Security-Policy", v)) (scCSP config)
+            else Nothing
-      , fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config)
+        , fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config)
-      , if scContentTypeOptions config
+        , fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config)
-        then Just ("X-Content-Type-Options", "nosniff")
+        , fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config)
-        else Nothing
+        , fmap (\v -> ("Expect-CT", v)) (scExpectCT config)
-      , fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config)
+        ]
-      , fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config)
+      serverHeader = case scServerHeader config of
-      , fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config)
+        Just v  -> [("Server", v)]
-      , fmap (\v -> ("Expect-CT", v)) (scExpectCT config)
+        Nothing -> []
-      ]
+      withoutServer = filter (not . isServerHeader) cleaned
-
-    -- 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) []

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs

@@ -0,0 +1,43 @@
+{-
+©AngelaMos | 2026
+IP.hs
+-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Aenebris.Net.IP
+  ( sockAddrToIPBytes
+  ) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import Data.List (intercalate)
+import Network.Socket
+  ( HostAddress6
+  , SockAddr(..)
+  , hostAddress6ToTuple
+  , hostAddressToTuple
+  )
+import Numeric (showHex)
+import Text.Printf (printf)
+
+ipv4Format :: String
+ipv4Format = "%d.%d.%d.%d"
+
+ipv6Separator :: String
+ipv6Separator = ":"
+
+unixSocketPrefix :: String
+unixSocketPrefix = "unix:"
+
+sockAddrToIPBytes :: SockAddr -> ByteString
+sockAddrToIPBytes (SockAddrInet _ ha) =
+  let (a, b, c, d) = hostAddressToTuple ha
+  in BS8.pack (printf ipv4Format a b c d)
+sockAddrToIPBytes (SockAddrInet6 _ _ ha6 _) = renderIPv6 ha6
+sockAddrToIPBytes (SockAddrUnix p) = BS8.pack (unixSocketPrefix <> p)
+
+renderIPv6 :: HostAddress6 -> ByteString
+renderIPv6 ha =
+  let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha
+      parts = [a, b, c, d, e, f, g, h]
+  in BS8.pack (intercalate ipv6Separator (map (`showHex` "") parts))

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs

@@ -1,6 +1,10 @@
+{-
+©AngelaMos | 2026
+Proxy.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Aenebris.Proxy
   ( ProxyState(..)
@@ -13,13 +17,24 @@ module Aenebris.Proxy
 import Aenebris.Backend
 import Aenebris.Config
 import Aenebris.Connection
+  ( ConnectionType(..)
+  , defaultTimeoutConfig
+  , detectConnectionType
+  , microsPerSecond
+  , tcUpstreamReadSeconds
+  )
 import Aenebris.HealthCheck
 import Aenebris.LoadBalancer
 import Aenebris.TLS
 import Aenebris.Tunnel
 import Aenebris.Middleware.Security
 import Aenebris.Middleware.Redirect
-import Aenebris.RateLimit (RateLimiter, createRateLimiter, parseRateSpec, rateLimitMiddleware)
+import Aenebris.RateLimit
+  ( RateLimiter
+  , createRateLimiter
+  , parseRateSpec
+  , rateLimitMiddleware
+  )
 import Aenebris.DDoS.EarlyData (earlyDataGuard)
 import Aenebris.DDoS.MemoryShed
   ( MemoryShed
@@ -66,7 +81,13 @@ import Aenebris.Geo
   )
 import Control.Concurrent.STM (TVar, newTVarIO)
 import Control.Concurrent.Async (Async, async, waitAnyCancel)
-import Control.Exception (try, SomeException)
+import Control.Exception (SomeException, try)
+import Control.Monad (unless, zipWithM)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Builder (byteString)
+import qualified Data.ByteString.Lazy as LBS
 import Data.Function ((&))
 import Data.List (sortBy)
 import Data.Map.Strict (Map)
@@ -76,12 +97,16 @@ import Data.Ord (comparing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
-import Network.HTTP.Client (Manager, withResponse, parseRequest, RequestBody(..), brRead)
+import Network.HTTP.Client
+  ( Manager
+  , RequestBody(..)
+  , brRead
+  , parseRequest
+  , withResponse
+  )
 import qualified Network.HTTP.Client as HTTP
 import Network.HTTP.Types
 import Network.Wai
-import Data.ByteString.Builder (byteString)
-import Control.Monad (unless)
 import Network.Wai.Handler.Warp
   ( Settings
   , defaultSettings
@@ -93,34 +118,80 @@ import Network.Wai.Handler.Warp
   , setTimeout
   )
 import Network.Wai.Handler.WarpTLS (runTLS)
+import System.Exit (exitFailure)
 import System.IO (hPutStrLn, stderr)
-import Data.ByteString (ByteString)
+import System.Timeout (timeout)
-import qualified Data.ByteString as BS
+
-import qualified Data.ByteString.Char8 as BS8
+memoryShedPollIntervalMicros :: Int
-import qualified Data.ByteString.Lazy as LBS
+memoryShedPollIntervalMicros = microsPerSecond
+
+contentTypePlain :: ByteString
+contentTypePlain = "text/plain"
+
+bodyNotFound :: LBS.ByteString
+bodyNotFound = "Not Found: No route configured for this host/path"
+
+bodyUpstreamMisconfigured :: LBS.ByteString
+bodyUpstreamMisconfigured = "Internal Server Error: Upstream configuration error"
+
+bodyNoHealthyBackends :: LBS.ByteString
+bodyNoHealthyBackends = "Service Unavailable: No healthy backends available"
+
+bodyBadGateway :: LBS.ByteString
+bodyBadGateway = "Bad Gateway: Could not connect to backend server"
+
+bodyGatewayTimeout :: LBS.ByteString
+bodyGatewayTimeout = "504 Gateway Timeout: upstream did not respond in time"
+
+bodyWebSocketUpgradeFailed :: LBS.ByteString
+bodyWebSocketUpgradeFailed = "WebSocket upgrade failed"
+
+hopByHopRequestHeaders :: [HeaderName]
+hopByHopRequestHeaders =
+  [ "Connection"
+  , "Keep-Alive"
+  , "Proxy-Authenticate"
+  , "Proxy-Authorization"
+  , "TE"
+  , "Trailers"
+  , "Transfer-Encoding"
+  , "Upgrade"
+  ]
+
+hopByHopResponseHeaders :: [HeaderName]
+hopByHopResponseHeaders =
+  [ "Transfer-Encoding"
+  , "Connection"
+  , "Keep-Alive"
+  ]
+
+eventStreamContentType :: ByteString
+eventStreamContentType = "text/event-stream"
+
+chunkedEncoding :: ByteString
+chunkedEncoding = "chunked"
+
+httpScheme :: String
+httpScheme = "http://"
 
--- | Proxy runtime state
 data ProxyState = ProxyState
-  { psConfig :: Config
+  { psConfig         :: !Config
-  , psLoadBalancers :: Map Text LoadBalancer  -- upstream name -> load balancer
+  , psLoadBalancers  :: !(Map Text LoadBalancer)
-  , psHealthCheckers :: [Async ()]
+  , psHealthCheckers :: ![Async ()]
-  , psManager :: Manager
+  , psManager        :: !Manager
-  , psRateLimiter :: Maybe RateLimiter
+  , psRateLimiter    :: !(Maybe RateLimiter)
-  , psMemoryShed :: Maybe MemoryShed
+  , psMemoryShed     :: !(Maybe MemoryShed)
-  , psIPJail :: Maybe IPJail
+  , psIPJail         :: !(Maybe IPJail)
-  , psConnLimiter :: Maybe ConnLimiter
+  , psConnLimiter    :: !(Maybe ConnLimiter)
-  , psWafRuleSet :: TVar RuleSet
+  , psWafRuleSet     :: !(TVar RuleSet)
-  , psGeo :: Maybe Geo
+  , psGeo            :: !(Maybe Geo)
   }
 
--- | 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)
+  let lbMap = Map.fromList (zip (map upstreamName (configUpstreams config)) lbs)
 
-  -- Start health checkers for all upstreams
   checkers <- mapM startUpstreamHealthChecker (configUpstreams config)
 
   rateLimiter <- case configRateLimit config >>= parseRateSpec of
@@ -134,8 +205,9 @@ initProxyState config manager = do
       ms <- newMemoryShed
       let cfg = MemoryShedConfig
             { mscHeapBudgetBytes = fromInteger budgetBytes
-            , mscHighWaterFraction = fromMaybe defaultHighWaterFraction (ddos >>= ddosMemoryShedHighWater)
+            , mscHighWaterFraction = fromMaybe defaultHighWaterFraction
-            , mscPollIntervalMicros = 1000000
+                (ddos >>= ddosMemoryShedHighWater)
+            , mscPollIntervalMicros = memoryShedPollIntervalMicros
             }
       _ <- startMemoryShedPoller cfg ms
       pure (Just ms)
@@ -162,84 +234,83 @@ initProxyState config manager = do
     Nothing -> pure Nothing
 
   return ProxyState
-    { psConfig = config
+    { psConfig         = config
-    , psLoadBalancers = lbMap
+    , psLoadBalancers  = lbMap
     , psHealthCheckers = checkers
-    , psManager = manager
+    , psManager        = manager
-    , psRateLimiter = rateLimiter
+    , psRateLimiter    = rateLimiter
-    , psMemoryShed = memShed
+    , psMemoryShed     = memShed
-    , psIPJail = ipJail
+    , psIPJail         = ipJail
-    , psConnLimiter = connLimiter
+    , psConnLimiter    = connLimiter
-    , psWafRuleSet = wafVar
+    , psWafRuleSet     = wafVar
-    , psGeo = geoHandle
+    , psGeo            = geoHandle
     }
   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
+            [] -> RoundRobin
-            (w:ws) -> if all (== w) ws
+            (w:ws)
-                        then RoundRobin
+              | all (== w) ws -> RoundRobin
-                        else WeightedRoundRobin
+              | otherwise     -> 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
-              , hcEndpoint = healthCheckPath hc
               }
             Nothing -> defaultHealthCheckConfig
-
       startHealthChecker manager hcConfig backends
 
--- | Start the proxy server with given configuration
--- Supports multiple ports with HTTP and HTTPS (including SNI)
 startProxy :: ProxyState -> IO ()
 startProxy ProxyState{..} = do
-  putStrLn $ "Starting Ᾰenebris reverse proxy"
+  putStrLn "Starting Aenebris reverse proxy"
-  putStrLn $ "Loaded " ++ show (length $ configUpstreams psConfig) ++ " upstream(s)"
+  putStrLn $ "Loaded " ++ show (length (configUpstreams psConfig)) ++ " upstream(s)"
-  putStrLn $ "Loaded " ++ show (length $ configRoutes psConfig) ++ " route(s)"
+  putStrLn $ "Loaded " ++ show (length (configRoutes psConfig)) ++ " route(s)"
-  putStrLn $ "Health checking enabled for all upstreams"
+  putStrLn "Health checking enabled for all upstreams"
 
   case configListen psConfig of
-    [] -> error "No listen ports configured"
+    [] -> do
+      hPutStrLn stderr "ERROR: No listen ports configured"
+      exitFailure
     listenConfigs -> do
       case psRateLimiter of
-        Just _ -> putStrLn "Rate limiting enabled"
+        Just _  -> putStrLn "Rate limiting enabled"
         Nothing -> pure ()
 
       putStrLn "WAF enabled (Phase 1: paranoia level 2, default rule pack)"
       case buildHoneypotConfig (configHoneypot psConfig) of
-        Just hp -> putStrLn $ "Honeypot enabled (" ++ show (length (hpPatterns hp))
+        Just hp -> putStrLn $
-                              ++ " trap patterns, action=" ++ show (hpAction hp) ++ ")"
+          "Honeypot enabled ("
+            ++ show (length (hpPatterns hp))
+            ++ " trap patterns, action="
+            ++ show (hpAction hp)
+            ++ ")"
         Nothing -> pure ()
       case psGeo of
         Just g ->
           let gc = geoConfig g
-              parts = [ "country_db=" ++ maybe "off" (const "on") (gcCountryDb gc)
+              parts =
-                      , "asn_db=" ++ maybe "off" (const "on") (gcAsnDb gc)
+                [ "country_db=" ++ maybe "off" (const "on") (gcCountryDb gc)
-                      , "blocked=" ++ show (length (gcBlockedCountries gc))
+                , "asn_db=" ++ maybe "off" (const "on") (gcAsnDb gc)
-                      , "flagged_asns=" ++ show (length (gcFlaggedAsns gc))
+                , "blocked=" ++ show (length (gcBlockedCountries gc))
-                      ]
+                , "flagged_asns=" ++ show (length (gcFlaggedAsns gc))
+                ]
           in putStrLn $ "Geo/ASN enabled (" ++ unwords parts ++ ")"
         Nothing -> pure ()
-      servers <- mapM (launchServer psConfig psLoadBalancers psManager psRateLimiter psMemoryShed psIPJail psConnLimiter psWafRuleSet psGeo) listenConfigs
+
+      servers <- mapM
+        (launchServer psConfig psLoadBalancers psManager
+                      psRateLimiter psMemoryShed psIPJail
+                      psConnLimiter psWafRuleSet psGeo)
+        listenConfigs
 
       _ <- waitAnyCancel servers
-
       putStrLn "All servers stopped"
 
 launchServer
@@ -254,260 +325,253 @@ launchServer
   -> Maybe Geo
   -> ListenConfig
   -> IO (Async ())
-launchServer config loadBalancers manager mRateLimiter mMemShed mIPJail mConnLim wafVar mGeo listenConfig = async $ do
+launchServer config loadBalancers manager mRateLimiter mMemShed mIPJail mConnLim wafVar mGeo listenConfig =
-  let port = listenPort listenConfig
+  async $ do
-      shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig)
+    let port = listenPort listenConfig
-      ddosCfg = fromMaybe defaultDDoSConfig (configDDoS config)
+        shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig)
+        ddosCfg = fromMaybe defaultDDoSConfig (configDDoS config)
 
-      baseApp = proxyApp config loadBalancers manager
+        baseApp          = proxyApp config loadBalancers manager
+        fingerprintedApp = ja4hMiddleware baseApp
+        wafApp           = wafMiddleware wafVar fingerprintedApp
+        securedApp       = addSecurityHeaders defaultSecurityConfig wafApp
 
-      fingerprintedApp = ja4hMiddleware baseApp
+        earlyDataApp     = if ddosEarlyDataReject ddosCfg
+                             then earlyDataGuard securedApp
+                             else securedApp
 
-      wafApp = wafMiddleware wafVar fingerprintedApp
+        mHoneypotCfg     = buildHoneypotConfig (configHoneypot config)
+        honeypotApp      = case mHoneypotCfg of
+          Just hp -> honeypotMiddleware hp mIPJail earlyDataApp
+          Nothing -> earlyDataApp
 
-      securedApp = addSecurityHeaders defaultSecurityConfig wafApp
+        geoApp = case mGeo of
+          Just g  -> geoMiddleware g mIPJail honeypotApp
+          Nothing -> honeypotApp
 
-      earlyDataApp = if ddosEarlyDataReject ddosCfg
+        jailedApp = case mIPJail of
-        then earlyDataGuard securedApp
+          Just j  -> ipJailMiddleware j geoApp
-        else securedApp
+          Nothing -> geoApp
 
-      mHoneypotCfg = buildHoneypotConfig (configHoneypot config)
+        shedApp = case mMemShed of
+          Just ms -> memoryShedMiddleware ms jailedApp
+          Nothing -> jailedApp
 
-      honeypotApp = case mHoneypotCfg of
+        limitedApp = case mRateLimiter of
-        Just hp -> honeypotMiddleware hp mIPJail earlyDataApp
+          Just rl -> rateLimitMiddleware rl shedApp
-        Nothing -> earlyDataApp
+          Nothing -> shedApp
 
-      geoApp = case mGeo of
+        warpSettings = applyDDoSSettings ddosCfg mConnLim
-        Just g -> geoMiddleware g mIPJail honeypotApp
+                                        (defaultSettings & setPort port)
-        Nothing -> honeypotApp
 
-      jailedApp = case mIPJail of
+    case listenTLS listenConfig of
-        Just j -> ipJailMiddleware j geoApp
+      Nothing -> do
-        Nothing -> geoApp
+        let app = if shouldRedirect
+                    then httpsRedirect limitedApp
+                    else limitedApp
+        putStrLn $ "* HTTP server listening on :" ++ show port
+        if shouldRedirect
+          then putStrLn "  Redirecting all traffic to HTTPS"
+          else pure ()
+        runSettings warpSettings app
 
-      shedApp = case mMemShed of
+      Just tlsConfig -> do
-        Just ms -> memoryShedMiddleware ms jailedApp
+        let isSNI = case tlsSNI tlsConfig of
-        Nothing -> jailedApp
+              Just domains -> not (null domains)
-
+              Nothing      -> False
-      limitedApp = case mRateLimiter of
+        if isSNI
-        Just rl -> rateLimitMiddleware rl shedApp
+          then launchHTTPSWithSNI port tlsConfig limitedApp
-        Nothing -> shedApp
+          else launchHTTPS port tlsConfig limitedApp
-
-      warpSettings = applyDDoSSettings ddosCfg mConnLim (defaultSettings & setPort port)
-
-  case listenTLS listenConfig of
-    Nothing -> do
-      let app = if shouldRedirect
-                then httpsRedirect limitedApp
-                else limitedApp
-
-      putStrLn $ "✓ HTTP server listening on :" ++ show port
-      if shouldRedirect
-        then putStrLn $ "  └─ Redirecting all traffic to HTTPS"
-        else return ()
-
-      runSettings warpSettings app
-
-    Just tlsConfig -> do
-      let isSNI = case tlsSNI tlsConfig of
-            Just domains -> not (null domains)
-            Nothing -> False
-
-      if isSNI
-        then launchHTTPSWithSNI port tlsConfig limitedApp
-        else launchHTTPS port tlsConfig limitedApp
 
 applyDDoSSettings :: DDoSConfig -> Maybe ConnLimiter -> Settings -> Settings
 applyDDoSSettings ddos mConnLim s0 =
-  let s1 = case ddosMaxHeaderBytes ddos of
+  let s1Inner = case ddosSlowlorisSeconds ddos of
-        Just n -> setMaxTotalHeaderLength n s1Inner
+        Just n  -> setTimeout n s0
-        Nothing -> s1Inner
-      s1Inner = case ddosSlowlorisSeconds ddos of
-        Just n -> setTimeout n s0
         Nothing -> s0
+      s1 = case ddosMaxHeaderBytes ddos of
+        Just n  -> setMaxTotalHeaderLength n s1Inner
+        Nothing -> s1Inner
       s2 = case mConnLim of
-        Just cl -> setOnClose (connLimitOnClose cl) (setOnOpen (connLimitOnOpen cl) s1)
+        Just cl -> setOnClose (connLimitOnClose cl)
+                     (setOnOpen (connLimitOnOpen cl) s1)
         Nothing -> s1
   in s2
 
--- | Launch HTTPS server with single certificate
 launchHTTPS :: Int -> TLSConfig -> Application -> IO ()
-launchHTTPS port tlsConfig app = do
+launchHTTPS port tlsConfig app =
   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 "ERROR: Failed to load TLS certificate"
           hPutStrLn stderr $ "  " ++ show err
-          error "TLS configuration error"
+          exitFailure
-
         Right tlsSettings -> do
           let warpSettings = defaultSettings & setPort port
-          putStrLn $ "✓ HTTPS server listening on :" ++ show port
+          putStrLn $ "* HTTPS server listening on :" ++ show port
-          putStrLn $ "  ├─ Certificate: " ++ certFile
+          putStrLn $ "  Certificate: " ++ certFile
-          putStrLn $ "  ├─ TLS 1.2 + TLS 1.3 enabled"
+          putStrLn   "  TLS 1.2 + TLS 1.3 enabled"
-          putStrLn $ "  ├─ HTTP/2 enabled (ALPN)"
+          putStrLn   "  HTTP/2 enabled (ALPN)"
-          putStrLn $ "  └─ Strong cipher suites enforced"
+          putStrLn   "  Strong cipher suites enforced"
           runTLS tlsSettings warpSettings app
+    _ -> do
+      hPutStrLn stderr "ERROR: TLS configuration requires both cert and key"
+      exitFailure
 
-    _ -> 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
+launchHTTPSWithSNI port tlsConfig app =
   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 "ERROR: Failed to load SNI certificates"
           hPutStrLn stderr $ "  " ++ show err
-          error "SNI configuration error"
+          exitFailure
-
         Right tlsSettings -> do
           let warpSettings = defaultSettings & setPort port
-          putStrLn $ "✓ HTTPS server with SNI listening on :" ++ show port
+          putStrLn $ "* HTTPS server with SNI listening on :" ++ show port
-          putStrLn $ "  ├─ SNI domains: " ++ show (length sniDomains) ++ " configured"
+          putStrLn $ "  SNI domains: " ++ show (length sniDomains) ++ " configured"
-          mapM_ (\d -> putStrLn $ "  │  • " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d) sniDomains
+          mapM_
-          putStrLn $ "  ├─ Default certificate: " ++ defaultCert
+            (\d -> putStrLn $
-          putStrLn $ "  ├─ TLS 1.2 + TLS 1.3 enabled"
+              "    " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d)
-          putStrLn $ "  ├─ HTTP/2 enabled (ALPN)"
+            sniDomains
-          putStrLn $ "  └─ Strong cipher suites enforced"
+          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
+    _ -> do
+      hPutStrLn stderr "ERROR: SNI requires sni, default_cert, and default_key"
+      exitFailure
 
-    _ -> error "SNI configuration error: sni, default_cert, and default_key required"
-
--- | Main proxy application (WAI)
 proxyApp :: Config -> Map Text LoadBalancer -> Manager -> Application
 proxyApp config loadBalancers manager req respond = do
-  logRequest req
+  let hostHeader  = lookup "Host" (requestHeaders req)
-
-  let hostHeader = lookup "Host" (requestHeaders req)
       requestPath = rawPathInfo req
-      headers = requestHeaders req
+      headers     = requestHeaders req
-      connType = detectConnectionType headers
+      connType    = detectConnectionType headers
 
   case selectRoute config hostHeader requestPath of
     Nothing -> do
-      hPutStrLn stderr $ "ERROR: No route found for request"
+      hPutStrLn stderr "ERROR: No route found for request"
       respond $ responseLBS
         status404
-        [("Content-Type", "text/plain")]
+        [(hContentType, contentTypePlain)]
-        "Not Found: No route configured for this host/path"
+        bodyNotFound
 
-    Just (upstreamName, _pathRoute) -> do
+    Just (upstreamName, _pathRoute) ->
       case Map.lookup upstreamName loadBalancers of
         Nothing -> do
-          hPutStrLn stderr $ "ERROR: Load balancer not found: " ++ T.unpack upstreamName
+          hPutStrLn stderr $
+            "ERROR: Load balancer not found: " ++ T.unpack upstreamName
           respond $ responseLBS
             status500
-            [("Content-Type", "text/plain")]
+            [(hContentType, contentTypePlain)]
-            "Internal Server Error: Upstream configuration error"
+            bodyUpstreamMisconfigured
 
         Just loadBalancer -> do
           mBackend <- selectBackend loadBalancer
-
           case mBackend of
             Nothing -> do
-              hPutStrLn stderr $ "ERROR: No healthy backends available"
+              hPutStrLn stderr "ERROR: No healthy backends available"
               respond $ responseLBS
                 status503
-                [("Content-Type", "text/plain")]
+                [(hContentType, contentTypePlain)]
-                "Service Unavailable: No healthy backends available"
+                bodyNoHealthyBackends
 
-            Just backend -> do
+            Just backend -> case connType of
-              case connType of
+              WebSocket -> do
-                WebSocket -> do
+                hPutStrLn stderr "[WS] WebSocket upgrade detected"
-                  hPutStrLn stderr $ "[WS] WebSocket upgrade detected"
+                handleWebSocketUpgrade req respond backend
-                  handleWebSocketUpgrade req respond backend
+              _ ->
+                forwardRegular manager backend req respond
 
-                RegularHttp -> do
+forwardRegular
-                  result <- try $ trackConnection backend $
+  :: Manager
-                    forwardRequest manager req (rbHost backend) respond
+  -> RuntimeBackend
+  -> Request
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
+forwardRegular manager backend req respond = do
+  result <- try $ trackConnection backend $
+    forwardRequest manager req (rbHost backend) respond
+  case result of
+    Left (err :: SomeException) -> do
+      hPutStrLn stderr $ "ERROR: " ++ show err
+      respond $ responseLBS
+        status502
+        [(hContentType, contentTypePlain)]
+        bodyBadGateway
+    Right responseReceived ->
+      pure responseReceived
 
-                  case result of
+handleWebSocketUpgrade
-                    Left (err :: SomeException) -> do
+  :: Request
-                      hPutStrLn stderr $ "ERROR: " ++ show err
+  -> (Response -> IO ResponseReceived)
-                      respond $ responseLBS
+  -> RuntimeBackend
-                        status502
+  -> IO ResponseReceived
-                        [("Content-Type", "text/plain")]
-                        "Bad Gateway: Could not connect to backend server"
-
-                    Right responseReceived ->
-                      return responseReceived
-
-                _ -> do
-                  result <- try $ trackConnection backend $
-                    forwardRequest manager req (rbHost backend) respond
-
-                  case result of
-                    Left (err :: SomeException) -> do
-                      hPutStrLn stderr $ "ERROR: " ++ show err
-                      respond $ responseLBS
-                        status502
-                        [("Content-Type", "text/plain")]
-                        "Bad Gateway: Could not connect to backend server"
-
-                    Right responseReceived ->
-                      return responseReceived
-
-handleWebSocketUpgrade :: Request -> (Response -> IO ResponseReceived) -> RuntimeBackend -> IO ResponseReceived
 handleWebSocketUpgrade req respond backend = do
   let backendHost = rbHost backend
       backupResponse = responseLBS
         status502
-        [("Content-Type", "text/plain")]
+        [(hContentType, contentTypePlain)]
-        "WebSocket upgrade failed"
+        bodyWebSocketUpgradeFailed
-
   respond $ responseRaw (wsHandler req backendHost) backupResponse
 
-wsHandler :: Request -> Text -> IO ByteString -> (ByteString -> IO ()) -> IO ()
+wsHandler
+  :: Request
+  -> Text
+  -> IO ByteString
+  -> (ByteString -> IO ())
+  -> IO ()
 wsHandler req backendHost recv send = do
   hPutStrLn stderr $ "[WS] Starting WebSocket tunnel to " ++ T.unpack backendHost
   tunnelWebSocket req backendHost send recv
 
--- | Select a route based on Host header and path
+selectRoute
-selectRoute :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe (Text, PathRoute)
+  :: Config
-selectRoute config hostHeader requestPath =
+  -> Maybe BS.ByteString
-  case hostHeader of
+  -> BS.ByteString
-    Nothing -> Nothing  -- No Host header, can't route
+  -> Maybe (Text, PathRoute)
-    Just host -> do
+selectRoute config hostHeader requestPath = case hostHeader of
-      -- Find route matching this host
+  Nothing   -> Nothing
-      let hostText = TE.decodeUtf8 host
+  Just host -> do
-          matchingRoutes = filter (\r -> routeHost r == hostText) (configRoutes config)
+    let hostText        = TE.decodeUtf8 host
+        matchingRoutes  = filter (\r -> routeHost r == hostText)
+                                 (configRoutes config)
+    route <- listToMaybe matchingRoutes
+    let requestPathText = TE.decodeUtf8 requestPath
+        sortedPaths     = sortBy
+                            (comparing (negate . T.length . pathRoutePath))
+                            (routePaths route)
+        matchingPaths   = filter
+                            (\p -> pathMatches (pathRoutePath p) requestPathText)
+                            sortedPaths
+    pathRoute <- listToMaybe matchingPaths
+    return (pathRouteUpstream pathRoute, pathRoute)
 
-      -- Find first matching path within the route
-      route <- listToMaybe matchingRoutes
-      let requestPathText = TE.decodeUtf8 requestPath
-          -- 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
 pathMatches :: Text -> Text -> Bool
 pathMatches pattern requestPath =
   pattern == "/" || T.isPrefixOf pattern requestPath
 
--- | Select an upstream for a request (exported for testing)
+selectUpstream
-selectUpstream :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text
+  :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text
 selectUpstream config hostHeader requestPath =
-  fmap fst $ selectRoute config hostHeader requestPath
+  fst <$> selectRoute config hostHeader requestPath
 
--- | Forward request to backend server with streaming support
+forwardRequest
-forwardRequest :: Manager -> Request -> Text -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+  :: Manager
+  -> Request
+  -> Text
+  -> (Response -> IO ResponseReceived)
+  -> IO ResponseReceived
 forwardRequest manager clientReq backendHost respond = do
-  let backendUrl = "http://" ++ T.unpack backendHost ++
+  let backendUrl = httpScheme ++ T.unpack backendHost
-                   BS8.unpack (rawPathInfo clientReq) ++
+                ++ BS8.unpack (rawPathInfo clientReq)
-                   BS8.unpack (rawQueryString clientReq)
+                ++ BS8.unpack (rawQueryString clientReq)
 
   initReq <- parseRequest backendUrl
 
@@ -521,47 +585,53 @@ forwardRequest manager clientReq backendHost respond = do
 
       backendReq = initReq
         { HTTP.method = requestMethod clientReq
-        , HTTP.requestHeaders = filterHeaders (requestHeaders clientReq)
+        , HTTP.requestHeaders = filterRequestHeaders (requestHeaders clientReq)
         , HTTP.requestBody = streamingBody
         }
 
-  withResponse backendReq manager $ \backendResponse -> do
+      upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
-    let status = HTTP.responseStatus backendResponse
+                     * microsPerSecond
-        headers = HTTP.responseHeaders backendResponse
-        bodyReader = HTTP.responseBody backendResponse
 
-    if shouldStreamResponse headers
+  mResult <- timeout upstreamMicros $
-      then do
+    withResponse backendReq manager $ \backendResponse -> do
-        hPutStrLn stderr "[STREAM] Streaming response detected"
+      let status     = HTTP.responseStatus backendResponse
-        respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do
+          headers    = HTTP.responseHeaders backendResponse
-          let loop = do
+          bodyReader = HTTP.responseBody backendResponse
-                chunk <- brRead bodyReader
+      if shouldStreamResponse headers
-                unless (BS.null chunk) $ do
+        then do
-                  write (byteString chunk)
+          hPutStrLn stderr "[STREAM] Streaming response detected"
-                  flush
+          respond $ responseStream status (filterResponseHeaders headers) $
-                  loop
+            \write flush -> do
-          loop
+              let loop = do
-      else do
+                    chunk <- brRead bodyReader
-        body <- readFullBody bodyReader
+                    unless (BS.null chunk) $ do
-        respond $ responseLBS status (filterResponseHeaders headers) body
+                      write (byteString chunk)
+                      flush
+                      loop
+              loop
+        else do
+          body <- readFullBody bodyReader
+          respond $ responseLBS status (filterResponseHeaders headers) body
+
+  case mResult of
+    Just rr -> pure rr
+    Nothing -> respond $ responseLBS
+      status504
+      [(hContentType, contentTypePlain)]
+      bodyGatewayTimeout
 
 shouldStreamResponse :: [(HeaderName, BS.ByteString)] -> Bool
-shouldStreamResponse headers =
+shouldStreamResponse headers = isSSE || isChunkedWithoutLength
-  isSSE || isChunkedWithoutLength
   where
     isSSE = case lookup "Content-Type" headers of
-      Just ct -> "text/event-stream" `BS.isInfixOf` ct
+      Just ct -> eventStreamContentType `BS.isInfixOf` ct
       Nothing -> False
-
+    isChunkedWithoutLength = hasChunkedEncoding && not hasContentLength
-    isChunkedWithoutLength =
-      hasChunkedEncoding && not hasContentLength
-
     hasChunkedEncoding = case lookup "Transfer-Encoding" headers of
-      Just te -> "chunked" `BS.isInfixOf` te
+      Just te -> chunkedEncoding `BS.isInfixOf` te
       Nothing -> False
-
     hasContentLength = case lookup "Content-Length" headers of
-      Just _ -> True
+      Just _  -> True
       Nothing -> False
 
 readFullBody :: HTTP.BodyReader -> IO LBS.ByteString
@@ -570,45 +640,17 @@ readFullBody bodyReader = LBS.fromChunks <$> go
     go = do
       chunk <- brRead bodyReader
       if BS.null chunk
-        then return []
+        then pure []
         else do
           rest <- go
-          return (chunk : rest)
+          pure (chunk : rest)
 
-filterResponseHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
+filterResponseHeaders
-filterResponseHeaders = filter (\(name, _) -> name `notElem` hopByHopHeaders)
+  :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
-  where
+filterResponseHeaders =
-    hopByHopHeaders =
+  filter (\(name, _) -> name `notElem` hopByHopResponseHeaders)
-      [ "Transfer-Encoding"
-      , "Connection"
-      , "Keep-Alive"
-      ]
 
--- | Filter headers for regular HTTP (remove hop-by-hop headers)
+filterRequestHeaders
-filterHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
+  :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
-filterHeaders headers = filter (\(name, _) -> name `notElem` hopByHopHeaders) headers
+filterRequestHeaders =
-  where
+  filter (\(name, _) -> name `notElem` hopByHopRequestHeaders)
-    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 ++ ")"
-
--- Helper: zipWithM
-zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
-zipWithM f xs ys = sequence (zipWith f xs ys)

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs

@@ -29,6 +29,7 @@ import Control.Concurrent.STM
   , readTVar
   , writeTVar
   )
+import Aenebris.Net.IP (sockAddrToIPBytes)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS8
 import Data.Map.Strict (Map)
@@ -38,12 +39,6 @@ import qualified Data.Text as T
 import qualified Data.Text.Read as TR
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
 import Network.HTTP.Types (status429)
-import Network.Socket
-  ( HostAddress6
-  , SockAddr(..)
-  , hostAddress6ToTuple
-  , hostAddressToTuple
-  )
 import Network.Wai
   ( Middleware
   , Request
@@ -51,8 +46,6 @@ import Network.Wai
   , remoteHost
   , responseLBS
   )
-import Numeric (showHex)
-import Text.Printf (printf)
 
 secondsPerMinute :: Double
 secondsPerMinute = 60
@@ -164,23 +157,7 @@ rateLimitMiddleware rl app req respond = do
     intBS n = BS8.pack (show n)
 
 clientIPKey :: Request -> ByteString
-clientIPKey req = case remoteHost req of
+clientIPKey = sockAddrToIPBytes . remoteHost
-  SockAddrInet _ ha ->
-    let (a, b, c, d) = hostAddressToTuple ha
-    in BS8.pack (printf "%d.%d.%d.%d" a b c d)
-  SockAddrInet6 _ _ ha6 _ -> v6Bytes ha6
-  SockAddrUnix p -> BS8.pack ("unix:" <> p)
-  where
-    v6Bytes :: HostAddress6 -> ByteString
-    v6Bytes ha =
-      let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha
-          parts = [a, b, c, d, e, f, g, h]
-      in BS8.pack (joinColons (map (`showHex` "") parts))
-
-    joinColons :: [String] -> String
-    joinColons [] = ""
-    joinColons [x] = x
-    joinColons (x : xs) = x <> ":" <> joinColons xs
 
 pathClassKey :: Request -> ByteString
 pathClassKey req =

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/TLS.hs

@@ -1,3 +1,7 @@
+{-
+©AngelaMos | 2026
+TLS.hs
+-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -8,23 +12,27 @@ module Aenebris.TLS
   , createSNISettings
   , validateCertificate
   , CertificateError(..)
+  , strongCipherSuites
   ) where
 
-import qualified Data.ByteString as BS
+import Control.Exception (SomeException, try)
+import qualified Data.ByteString.Lazy as LBS
+import Data.Default.Class (def)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 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 qualified Network.TLS as TLS
+import qualified Network.TLS.Extra.Cipher as Cipher
+import Network.Wai.Handler.WarpTLS
 import System.Directory (doesFileExist)
-import Control.Exception (try, SomeException)
+import System.IO (hPutStrLn, stderr)
+
+httpsRequiredMessage :: LBS.ByteString
+httpsRequiredMessage = "This server requires HTTPS"
 
--- | Certificate loading errors
 data CertificateError
   = CertFileNotFound FilePath
   | KeyFileNotFound FilePath
@@ -32,130 +40,128 @@ data CertificateError
   | InvalidKey FilePath String
   deriving (Show, Eq)
 
--- | Create TLS settings for a single certificate (non-SNI)
+createTLSSettings
-createTLSSettings :: FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
+  :: FilePath
+  -> FilePath
+  -> IO (Either CertificateError TLSSettings)
 createTLSSettings certFile keyFile = do
-  -- Validate files exist
   certExists <- doesFileExist certFile
-  keyExists <- doesFileExist keyFile
+  keyExists  <- doesFileExist keyFile
-
   if not certExists
-    then return $ Left (CertFileNotFound certFile)
+    then pure (Left (CertFileNotFound certFile))
     else if not keyExists
-      then return $ Left (KeyFileNotFound keyFile)
+      then pure (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))
+            pure (Left (InvalidCertificate certFile (show err)))
-
           Right (Left err) ->
-            return $ Left (InvalidCertificate certFile err)
+            pure (Left (InvalidCertificate certFile err))
+          Right (Right _) ->
+            pure (Right (configureTLS certFile keyFile))
 
-          Right (Right _credential) -> do
+configureTLS :: FilePath -> FilePath -> TLSSettings
-            -- Create TLS settings with strong security
+configureTLS certFile keyFile = (tlsSettings certFile keyFile)
-            let tlsConfig = (tlsSettings certFile keyFile)
+  { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
-                  { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
+  , tlsCiphers = strongCipherSuites
-                  , tlsCiphers = strongCipherSuites
+  , onInsecure = DenyInsecure httpsRequiredMessage
-                  , onInsecure = DenyInsecure "This server requires HTTPS"
+  }
-                  }
 
-            return $ Right tlsConfig
+createSNISettings
-
+  :: [(Text, FilePath, FilePath)]
--- | Create TLS settings with SNI support for multiple domains
+  -> FilePath
-createSNISettings :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
+  -> FilePath
+  -> IO (Either CertificateError TLSSettings)
 createSNISettings domains defaultCert defaultKey = do
-  -- Validate default certificate
+  defaultCertOk <- doesFileExist defaultCert
-  defaultExists <- doesFileExist defaultCert
+  defaultKeyOk  <- doesFileExist defaultKey
-  defaultKeyExists <- doesFileExist defaultKey
+  if not defaultCertOk
-
+    then pure (Left (CertFileNotFound defaultCert))
-  if not defaultExists
+    else if not defaultKeyOk
-    then return $ Left (CertFileNotFound defaultCert)
+      then pure (Left (KeyFileNotFound defaultKey))
-    else if not defaultKeyExists
-      then return $ Left (KeyFileNotFound defaultKey)
       else do
-        -- Validate all domain certificates exist
+        validations <- mapM validateDomainCert domains
-        validationResults <- mapM validateDomainCert domains
+        case sequence validations of
-        case sequence validationResults of
+          Left err -> pure (Left err)
-          Left err -> return $ Left err
+          Right _ -> pure (Right (configureSNI domains defaultCert defaultKey))
-          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
+configureSNI
-  where
+  :: [(Text, FilePath, FilePath)]
-    validateDomainCert :: (Text, FilePath, FilePath) -> IO (Either CertificateError ())
+  -> FilePath
-    validateDomainCert (domain, certFile, keyFile) = do
+  -> FilePath
-      certExists <- doesFileExist certFile
+  -> TLSSettings
-      keyExists <- doesFileExist keyFile
+configureSNI domains defaultCert defaultKey =
+  let baseTLS = tlsSettings defaultCert defaultKey
+  in baseTLS
+       { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
+       , tlsCiphers = strongCipherSuites
+       , onInsecure = DenyInsecure httpsRequiredMessage
+       , tlsServerHooks = def
+           { TLS.onServerNameIndication = \mHostname -> case mHostname of
+               Nothing -> credentialsOrDefault defaultCert defaultKey
+               Just hostname ->
+                 sniCallback domains defaultCert defaultKey hostname
+           }
+       }
 
-      if not certExists
+validateDomainCert
-        then return $ Left (CertFileNotFound certFile)
+  :: (Text, FilePath, FilePath) -> IO (Either CertificateError ())
-        else if not keyExists
+validateDomainCert (_domain, certFile, keyFile) = do
-          then return $ Left (KeyFileNotFound keyFile)
+  certExists <- doesFileExist certFile
-          else return $ Right ()
+  keyExists  <- doesFileExist keyFile
+  if not certExists
+    then pure (Left (CertFileNotFound certFile))
+    else if not keyExists
+      then pure (Left (KeyFileNotFound keyFile))
+      else pure (Right ())
 
--- | SNI callback function - returns credentials based on hostname
+sniCallback
-sniCallback :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> String -> IO TLS.Credentials
+  :: [(Text, FilePath, FilePath)]
-sniCallback domains defaultCert defaultKey hostname = do
+  -> FilePath
-  let hostnameText = T.pack hostname
+  -> FilePath
-      -- Look up domain in map
+  -> String
+  -> IO TLS.Credentials
+sniCallback domains defaultCert defaultKey hostname =
+  let domainMap :: Map Text (FilePath, FilePath)
       domainMap = Map.fromList [(d, (c, k)) | (d, c, k) <- domains]
+  in case Map.lookup (T.pack hostname) domainMap of
+       Nothing -> credentialsOrDefault defaultCert defaultKey
+       Just (certFile, keyFile) ->
+         credentialsOrDefault certFile keyFile
 
-  case Map.lookup hostnameText domainMap of
+credentialsOrDefault :: FilePath -> FilePath -> IO TLS.Credentials
-    Nothing -> do
+credentialsOrDefault certFile keyFile = 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 ->
+    Left err -> do
-      error $ "Failed to load certificate: " ++ err
+      hPutStrLn stderr $
+        "TLS: failed to load credential at "
+        <> certFile <> " (" <> err <> "); SNI handler returns empty credentials"
+      pure (TLS.Credentials [])
     Right credential ->
-      return $ TLS.Credentials [credential]
+      pure (TLS.Credentials [credential])
 
--- | Validate a certificate file (check if it's readable and valid)
+validateCertificate
-validateCertificate :: FilePath -> IO (Either CertificateError [SignedCertificate])
+  :: FilePath -> IO (Either CertificateError [SignedCertificate])
 validateCertificate certFile = do
   exists <- doesFileExist certFile
   if not exists
-    then return $ Left (CertFileNotFound certFile)
+    then pure (Left (CertFileNotFound certFile))
     else do
       result <- try $ readSignedObject certFile
       case result of
         Left (err :: SomeException) ->
-          return $ Left (InvalidCertificate certFile (show err))
+          pure (Left (InvalidCertificate certFile (show err)))
         Right certs ->
-          return $ Right certs
+          pure (Right certs)
 
--- | Strong cipher suites for production (TLS 1.2 + TLS 1.3)
 strongCipherSuites :: [TLS.Cipher]
 strongCipherSuites =
-  -- TLS 1.3 cipher suites (preferred)
+  [ Cipher.cipher13_AES_128_GCM_SHA256
-  [ Cipher.cipher_TLS13_AES128GCM_SHA256
+  , Cipher.cipher13_AES_256_GCM_SHA384
-  , Cipher.cipher_TLS13_AES256GCM_SHA384
+  , Cipher.cipher13_CHACHA20_POLY1305_SHA256
-  , Cipher.cipher_TLS13_CHACHA20POLY1305_SHA256
+  , Cipher.cipher_ECDHE_RSA_WITH_AES_128_GCM_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

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Tunnel.hs

@@ -1,27 +1,95 @@
+{-
+©AngelaMos | 2026
+Tunnel.hs
+-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Aenebris.Tunnel
-  ( tunnelWebSocket
+  ( ConnectError(..)
+  , connectToBackend
+  , parseHostPort
+  , parseUpgradeStatus
+  , tunnelWebSocket
   , streamResponse
   , bidirectionalCopy
   ) where
 
 import Control.Concurrent.Async (race_)
-import Control.Exception (SomeException, try, bracket)
+import Control.Exception
+  ( SomeException
+  , bracketOnError
+  , finally
+  , try
+  )
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
 import Data.CaseInsensitive (original)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Network.HTTP.Types (HeaderName)
 import Network.Socket (Socket)
 import qualified Network.Socket as Socket
 import qualified Network.Socket.ByteString as SocketBS
 import Network.Wai
+  ( Request
+  , rawPathInfo
+  , rawQueryString
+  , requestHeaders
+  , requestMethod
+  )
 import System.IO (hPutStrLn, stderr)
+import System.Timeout (timeout)
+
+defaultBackendPort :: Int
+defaultBackendPort = 80
+
+upgradeRecvChunkBytes :: Int
+upgradeRecvChunkBytes = 4_096
+
+maxUpgradeHeaderBytes :: Int
+maxUpgradeHeaderBytes = 16_384
+
+tunnelRecvChunkBytes :: Int
+tunnelRecvChunkBytes = 65_536
+
+connectTimeoutSeconds :: Int
+connectTimeoutSeconds = 5
+
+upgradeIdleSeconds :: Int
+upgradeIdleSeconds = 30
+
+microsPerSecond :: Int
+microsPerSecond = 1_000_000
+
+upgradeStatusSwitching :: Int
+upgradeStatusSwitching = 101
+
+badGatewayResponseLine :: ByteString
+badGatewayResponseLine = "HTTP/1.1 502 Bad Gateway\r\n\r\n"
+
+upgradeTerminator :: ByteString
+upgradeTerminator = "\r\n\r\n"
+
+httpHeaderLineEnd :: ByteString
+httpHeaderLineEnd = "\r\n"
+
+httpVersionAndCrlf :: ByteString
+httpVersionAndCrlf = " HTTP/1.1\r\n"
+
+httpFieldSeparator :: ByteString
+httpFieldSeparator = ": "
+
+requestPathSeparator :: ByteString
+requestPathSeparator = " "
+
+data ConnectError
+  = ResolutionFailed !String !Int
+  | ConnectTimeout !String !Int
+  | ConnectFailed !String !Int !String
+  deriving (Eq, Show)
 
 tunnelWebSocket
   :: Request
@@ -31,39 +99,62 @@ tunnelWebSocket
   -> IO ()
 tunnelWebSocket clientReq backendHost clientSend clientRecv = do
   hPutStrLn stderr $ "[WS] Initiating tunnel to " ++ T.unpack backendHost
-
+  let (host, port) = parseHostPort backendHost
-  result <- try $ do
+  outcome <- try $ do
-    let (host, port) = parseHostPort backendHost
+    eSock <- connectToBackend host port
-
+    case eSock of
-    bracket
+      Left err -> do
-      (connectToBackend host port)
+        hPutStrLn stderr $ "[WS] Connection failed: " ++ show err
-      Socket.close
+        clientSend badGatewayResponseLine
-      $ \backendSocket -> do
+      Right sock ->
-          sendUpgradeRequest backendSocket clientReq
+        runUpgrade clientReq clientSend clientRecv sock
-          upgradeResponse <- receiveUpgradeResponse backendSocket
+          `finally` Socket.close sock
-
+  case outcome of
-          case parseUpgradeStatus upgradeResponse of
-            Just 101 -> do
-              hPutStrLn stderr "[WS] Backend accepted upgrade (101)"
-              clientSend upgradeResponse
-              bidirectionalCopy clientRecv clientSend
-                (SocketBS.recv backendSocket 65536)
-                (SocketBS.sendAll backendSocket)
-
-            Just code -> do
-              hPutStrLn stderr $ "[WS] Backend rejected upgrade: " ++ show code
-              clientSend upgradeResponse
-
-            Nothing -> do
-              hPutStrLn stderr "[WS] Invalid upgrade response"
-              clientSend "HTTP/1.1 502 Bad Gateway\r\n\r\n"
-
-  case result of
     Left (e :: SomeException) ->
       hPutStrLn stderr $ "[WS] Tunnel error: " ++ show e
     Right () ->
       hPutStrLn stderr "[WS] Tunnel closed"
 
+runUpgrade
+  :: Request
+  -> (ByteString -> IO ())
+  -> IO ByteString
+  -> Socket
+  -> IO ()
+runUpgrade clientReq clientSend clientRecv sock = do
+  sendUpgradeRequest sock clientReq
+  mResponse <- timeout
+    (upgradeIdleSeconds * microsPerSecond)
+    (receiveUpgradeResponse sock)
+  case mResponse of
+    Nothing -> do
+      hPutStrLn stderr "[WS] Upgrade response timed out"
+      clientSend badGatewayResponseLine
+    Just upgradeResponse ->
+      dispatchUpgrade sock clientSend clientRecv upgradeResponse
+
+dispatchUpgrade
+  :: Socket
+  -> (ByteString -> IO ())
+  -> IO ByteString
+  -> ByteString
+  -> IO ()
+dispatchUpgrade sock clientSend clientRecv upgradeResponse =
+  case parseUpgradeStatus upgradeResponse of
+    Just code | code == upgradeStatusSwitching -> do
+      hPutStrLn stderr "[WS] Backend accepted upgrade (101)"
+      clientSend upgradeResponse
+      bidirectionalCopy
+        clientRecv clientSend
+        (SocketBS.recv sock tunnelRecvChunkBytes)
+        (SocketBS.sendAll sock)
+    Just code -> do
+      hPutStrLn stderr $ "[WS] Backend rejected upgrade: " ++ show code
+      clientSend upgradeResponse
+    Nothing -> do
+      hPutStrLn stderr "[WS] Invalid upgrade response"
+      clientSend badGatewayResponseLine
+
 bidirectionalCopy
   :: IO ByteString
   -> (ByteString -> IO ())
@@ -72,11 +163,9 @@ bidirectionalCopy
   -> IO ()
 bidirectionalCopy clientRecv clientSend backendRecv backendSend = do
   hPutStrLn stderr "[TUNNEL] Starting bidirectional copy"
-
   race_
     (copyLoop "client->backend" clientRecv backendSend)
     (copyLoop "backend->client" backendRecv clientSend)
-
   hPutStrLn stderr "[TUNNEL] Bidirectional copy ended"
 
 copyLoop :: String -> IO ByteString -> (ByteString -> IO ()) -> IO ()
@@ -112,56 +201,74 @@ parseHostPort hostPort =
     [host, portStr] ->
       case reads (T.unpack portStr) of
         [(port, "")] -> (T.unpack host, port)
-        _ -> (T.unpack host, 80)
+        _ -> (T.unpack host, defaultBackendPort)
-    [host] -> (T.unpack host, 80)
+    [host] -> (T.unpack host, defaultBackendPort)
-    _ -> (T.unpack hostPort, 80)
+    _ -> (T.unpack hostPort, defaultBackendPort)
 
-connectToBackend :: String -> Int -> IO Socket
+connectToBackend :: String -> Int -> IO (Either ConnectError Socket)
 connectToBackend host port = do
-  addrInfos <- Socket.getAddrInfo
+  resolution <- try $ Socket.getAddrInfo
     (Just Socket.defaultHints { Socket.addrSocketType = Socket.Stream })
     (Just host)
-    (Just $ show port)
+    (Just (show port))
+  case resolution of
+    Left (_ :: SomeException) -> pure (Left (ResolutionFailed host port))
+    Right [] -> pure (Left (ResolutionFailed host port))
+    Right (addr : _) -> attemptConnect host port addr
 
-  case addrInfos of
+attemptConnect
-    [] -> error $ "Cannot resolve: " ++ host ++ ":" ++ show port
+  :: String -> Int -> Socket.AddrInfo -> IO (Either ConnectError Socket)
-    (addr:_) -> do
+attemptConnect host port addr =
-      sock <- Socket.socket
+  bracketOnError
-        (Socket.addrFamily addr)
+    (Socket.socket
-        Socket.Stream
+      (Socket.addrFamily addr)
-        Socket.defaultProtocol
+      Socket.Stream
-      Socket.connect sock (Socket.addrAddress addr)
+      Socket.defaultProtocol)
-      return sock
+    Socket.close
+    $ \sock -> do
+        mConnect <- timeout
+          (connectTimeoutSeconds * microsPerSecond)
+          (try (Socket.connect sock (Socket.addrAddress addr)))
+        case mConnect of
+          Nothing -> do
+            Socket.close sock
+            pure (Left (ConnectTimeout host port))
+          Just (Left (e :: SomeException)) -> do
+            Socket.close sock
+            pure (Left (ConnectFailed host port (show e)))
+          Just (Right ()) ->
+            pure (Right sock)
 
 sendUpgradeRequest :: Socket -> Request -> IO ()
-sendUpgradeRequest sock req = do
+sendUpgradeRequest sock req =
-  let method = requestMethod req
+  let method      = requestMethod req
-      path = rawPathInfo req <> rawQueryString req
+      path        = rawPathInfo req <> rawQueryString req
-      headers = requestHeaders req
+      headers     = requestHeaders req
-
+      requestLine = method <> requestPathSeparator <> path <> httpVersionAndCrlf
-      requestLine = method <> " " <> path <> " HTTP/1.1\r\n"
       headerLines = BS.concat
-        [ original name <> ": " <> value <> "\r\n"
+        [ original name <> httpFieldSeparator <> value <> httpHeaderLineEnd
         | (name, value) <- headers
         ]
-      fullRequest = requestLine <> headerLines <> "\r\n"
+      fullRequest = requestLine <> headerLines <> httpHeaderLineEnd
-
+  in SocketBS.sendAll sock fullRequest
-  SocketBS.sendAll sock fullRequest
 
 receiveUpgradeResponse :: Socket -> IO ByteString
-receiveUpgradeResponse sock = do
+receiveUpgradeResponse sock = go BS.empty
-  chunk <- SocketBS.recv sock 4096
+  where
-  if "\r\n\r\n" `BS.isInfixOf` chunk
+    go !acc
-    then return chunk
+      | upgradeTerminator `BS.isInfixOf` acc = pure acc
-    else do
+      | BS.length acc >= maxUpgradeHeaderBytes = pure acc
-      rest <- receiveUpgradeResponse sock
+      | otherwise = do
-      return $ chunk <> rest
+          chunk <- SocketBS.recv sock upgradeRecvChunkBytes
+          if BS.null chunk
+            then pure acc
+            else go (acc <> chunk)
 
 parseUpgradeStatus :: ByteString -> Maybe Int
-parseUpgradeStatus response =
+parseUpgradeStatus response = case BS8.lines response of
-  case BS8.words (head $ BS8.lines response) of
+  [] -> Nothing
-    (_:codeBS:_) ->
+  (firstLine : _) -> case BS8.words firstLine of
-      case reads (BS8.unpack codeBS) of
+    (_ : codeBS : _) -> case reads (BS8.unpack codeBS) of
-        [(code, "")] -> Just code
+      [(code, "")] -> Just code
-        _ -> Nothing
+      _            -> Nothing
     _ -> Nothing

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs

@@ -39,7 +39,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.Char (toLower)
 import Data.Word (Word32)
-import Network.HTTP.Types (Status, mkStatus)
+import Network.HTTP.Types (status403)
 import Network.HTTP.Types.URI (urlDecode)
 import Network.Wai
   ( Middleware
@@ -159,9 +159,6 @@ decisionFromScore hasBlock score threshold matches
 wafResponseHeader :: CI ByteString
 wafResponseHeader = "x-aenebris-waf"
 
-status403 :: Status
-status403 = mkStatus 403 "Forbidden"
-
 wafMiddleware :: TVar RuleSet -> Middleware
 wafMiddleware rsVar app req respond = do
   rs <- readTVarIO rsVar
@@ -173,4 +170,4 @@ wafMiddleware rsVar app req respond = do
         [ ("Content-Type", "text/plain; charset=utf-8")
         , (wafResponseHeader, "blocked score=" <> BC.pack (show score))
         ]
-        "403 Forbidden — request blocked by Aenebris WAF"
+        "403 Forbidden - request blocked by Aenebris WAF"

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Rule.hs

@@ -72,13 +72,16 @@ data Target
   | TargetUserAgent
   deriving (Eq, Show)
 
-newtype CompiledRegex = CompiledRegex { unCompiledRegex :: Regex }
+data CompiledRegex = CompiledRegex
+  { unCompiledRegex      :: !Regex
+  , compiledRegexPattern :: !ByteString
+  }
 
 instance Show CompiledRegex where
-  show _ = "<CompiledRegex>"
+  show r = "<CompiledRegex " ++ show (compiledRegexPattern r) ++ ">"
 
 instance Eq CompiledRegex where
-  _ == _ = False
+  a == b = compiledRegexPattern a == compiledRegexPattern b
 
 data Operator
   = OpRegex !CompiledRegex
@@ -115,13 +118,13 @@ compileRegex :: ByteString -> Either String CompiledRegex
 compileRegex pat =
   case compile compOpts execOpts pat of
     Left err -> Left err
-    Right r -> Right (CompiledRegex r)
+    Right r -> Right (CompiledRegex r pat)
   where
     compOpts = TDFA.defaultCompOpt { TDFA.caseSensitive = False }
     execOpts = TDFA.defaultExecOpt
 
 runRegex :: CompiledRegex -> ByteString -> Bool
-runRegex (CompiledRegex r) input =
+runRegex cr input =
-  case execute r input of
+  case execute (unCompiledRegex cr) input of
     Right (Just _) -> True
     _ -> False

PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs

@@ -10,10 +10,13 @@ import Aenebris.Backend
   ( createRuntimeBackend
   , getConnectionCount
   , isHealthy
+  , rbActiveConnections
+  , rbConsecutiveFailures
   , rbServerId
   , rbWeight
   , recordFailure
   , recordSuccess
+  , trackConnection
   , transitionToHealthy
   , transitionToRecovering
   , transitionToUnhealthy
@@ -30,7 +33,8 @@ import Aenebris.Config
   , validateConfig
   )
 import Aenebris.DDoS.ConnLimit
-  ( defaultConnLimitConfig
+  ( currentCount
+  , defaultConnLimitConfig
   , defaultPerIPLimit
   , ipBytesFromSockAddr
   , newConnLimiter
@@ -227,6 +231,7 @@ import Aenebris.ML.Loader
   ( ParseError(..)
   , parseEnsemble
   )
+import Aenebris.Net.IP (sockAddrToIPBytes)
 import Aenebris.Middleware.Redirect (httpsRedirect, httpsRedirectWithPort)
 import Aenebris.Middleware.Security
   ( addSecurityHeaders
@@ -262,6 +267,7 @@ import Control.Concurrent.STM
   ( atomically
   , modifyTVar'
   , newTVarIO
+  , readTVar
   , readTVarIO
   )
 import qualified Data.ByteString as BS
@@ -375,6 +381,7 @@ main = hspec $ do
   wafSpec
   honeypotSpec
   geoSpec
+  netIpSpec
   mlFeaturesSpec
   mlModelSpec
   mlLoaderSpec
@@ -477,31 +484,46 @@ loadBalancerSpec = describe "LoadBalancer" $ do
     lb <- createLoadBalancer RoundRobin []
     selectBackend lb `shouldReturn` Nothing
 
-  it "selects from backend pool with round robin" $ do
+  it "round robin distributes evenly across the pool" $ do
     bks <- mapM (\(i, h) -> createRuntimeBackend i (Server h 1))
                 [(0, "host-a:80"), (1, "host-b:80"), (2, "host-c:80")]
     lb <- createLoadBalancer RoundRobin bks
-    let getName = fmap (fmap rbServerId) (selectBackend lb)
+    let totalRounds = 9 :: Int
-    a <- getName
+    selections <- mapM
-    b <- getName
+      (\_ -> fmap (fmap rbServerId) (selectBackend lb))
-    c <- getName
+      [1 .. totalRounds]
-    isJust a `shouldBe` True
+    let counts =
-    isJust b `shouldBe` True
+          [ length (filter (== Just sid) selections)
-    isJust c `shouldBe` True
+          | sid <- [0, 1, 2]
+          ]
+    counts `shouldBe` [3, 3, 3]
 
-  it "selects backend with weighted round robin" $ do
+  it "weighted round robin selects proportionally" $ do
     bks <- mapM (\(i, h, w) -> createRuntimeBackend i (Server h w))
                 [(0, "host-a:80", 1), (1, "host-b:80", 4)]
     lb <- createLoadBalancer WeightedRoundRobin bks
-    selected <- selectBackend lb
+    let totalRounds = 50 :: Int
-    isJust selected `shouldBe` True
+    selections <- mapM
+      (\_ -> fmap (fmap rbServerId) (selectBackend lb))
+      [1 .. totalRounds]
+    let countA = length (filter (== Just 0) selections)
+        countB = length (filter (== Just 1) selections)
+    countB `shouldSatisfy` (>= 35)
+    countA `shouldSatisfy` (<= 15)
 
-  it "selects least connections backend" $ do
+  it "least connections picks the backend with fewest active connections" $ do
     bks <- mapM (\(i, h) -> createRuntimeBackend i (Server h 1))
                 [(0, "host-a:80"), (1, "host-b:80")]
-    lb <- createLoadBalancer LeastConnections bks
+    case bks of
-    selected <- selectBackend lb
+      [a, _b] -> do
-    isJust selected `shouldBe` True
+        atomically $
+          modifyTVar'
+            (rbActiveConnections a)
+            (+ 5)
+        lb <- createLoadBalancer LeastConnections bks
+        selected <- selectBackend lb
+        fmap rbServerId selected `shouldBe` Just 1
+      _ -> expectationFailure "expected exactly two backends"
 
 backendSpec :: Spec
 backendSpec = describe "Backend" $ do
@@ -526,17 +548,21 @@ backendSpec = describe "Backend" $ do
     bk <- createRuntimeBackend 0 (Server "host:80" 1)
     atomically (getConnectionCount bk) `shouldReturn` 0
 
-  it "tolerates repeated failures" $ do
+  it "transitions to Unhealthy after maxFailures consecutive failures" $ do
     bk <- createRuntimeBackend 0 (Server "host:80" 10)
-    atomically $ recordFailure bk 3
+    atomically (recordFailure bk 3)
-    atomically $ recordFailure bk 3
+    atomically (isHealthy bk) `shouldReturn` True
-    atomically $ recordFailure bk 3
+    atomically (recordFailure bk 3)
-    rbWeight bk `shouldBe` 10
+    atomically (isHealthy bk) `shouldReturn` True
+    atomically (recordFailure bk 3)
+    atomically (isHealthy bk) `shouldReturn` False
 
-  it "records successes without crashing" $ do
+  it "recordSuccess on Healthy resets the failure counter" $ do
     bk <- createRuntimeBackend 0 (Server "host:80" 5)
-    atomically $ recordSuccess bk 5
+    atomically (recordFailure bk 5)
-    pure ()
+    atomically (readTVar (rbConsecutiveFailures bk)) `shouldReturn` 1
+    atomically (recordSuccess bk 5)
+    atomically (readTVar (rbConsecutiveFailures bk)) `shouldReturn` 0
 
 securitySpec :: Spec
 securitySpec = describe "Security headers" $ do
@@ -752,11 +778,12 @@ connLimitSpec = describe "ConnLimit" $ do
     res <- atomically (tryAcquire cl "9.9.9.9")
     res `shouldBe` False
 
-  it "release decrements counter" $ do
+  it "release decrements counter back to 0" $ do
     cl <- newConnLimiter defaultConnLimitConfig
     _ <- atomically (tryAcquire cl "1.2.3.4")
+    atomically (currentCount cl "1.2.3.4") `shouldReturn` 1
     atomically (release cl "1.2.3.4")
-    pure ()
+    atomically (currentCount cl "1.2.3.4") `shouldReturn` 0
 
 ja4hSpec :: Spec
 ja4hSpec = describe "JA4H fingerprint" $ do
@@ -817,6 +844,16 @@ wafSpec = describe "WAF" $ do
     severityScore SevWarning `shouldBe` 3
     severityScore SevNotice `shouldBe` 2
 
+  it "Eq CompiledRegex is reflexive (x == x)" $
+    case compileRegex "abc" of
+      Right r -> r `shouldBe` r
+      Left err -> expectationFailure err
+
+  it "Eq CompiledRegex distinguishes different patterns" $
+    case (compileRegex "abc", compileRegex "def") of
+      (Right r1, Right r2) -> (r1 == r2) `shouldBe` False
+      _ -> expectationFailure "expected both to compile"
+
   it "default ruleset includes rules" $
     length (rsRules defaultRuleSet) `shouldSatisfy` (> 0)
 
@@ -1848,6 +1885,27 @@ mlModelSpec = describe "ML.Model" $ do
     validateTree 20 bad `shouldSatisfy`
       (\r -> case r of { Left _ -> True; Right _ -> False })
 
+netIpSpec :: Spec
+netIpSpec = describe "Net.IP" $ do
+  it "renders ipv4 sockaddr in dotted decimal" $
+    sockAddrToIPBytes (ipv4Addr (10, 0, 0, 1) 1234) `shouldBe` "10.0.0.1"
+
+  it "renders ipv4 loopback" $
+    sockAddrToIPBytes (ipv4Addr (127, 0, 0, 1) 8080) `shouldBe` "127.0.0.1"
+
+  it "renders unix sockaddr with prefix" $
+    sockAddrToIPBytes (SockAddrUnix "/tmp/sock") `shouldBe` "unix:/tmp/sock"
+
+  it "renders ipv6 sockaddr separated by colons (eight 16-bit groups)" $ do
+    let addr = SockAddrInet6
+          0
+          0
+          (tupleToHostAddress6 (0x2001, 0xdb8, 0, 0, 0, 0, 0, 1))
+          0
+        result = sockAddrToIPBytes addr
+    BS.length result `shouldSatisfy` (> 0)
+    BC.count ':' result `shouldBe` 7
+
 mlLoaderModel :: T.Text
 mlLoaderModel = T.unlines
   [ "tree"
@@ -2074,6 +2132,16 @@ mlLoaderSpec = describe "ML.Loader" $ do
           (T.replace "leaf_value=0.5\n" "leaf_value=0.5\nbogus=1\n" mlLoaderModel))
         `shouldSatisfy` isLeft
 
+    it "rejects num_leaves above maxNumLeaves" $
+      parseEnsemble
+        (TE.encodeUtf8 (T.replace "num_leaves=1" "num_leaves=999999" mlLoaderModel))
+        `shouldSatisfy` parseFailsAt "num_leaves"
+
+    it "rejects num_leaves of 0" $
+      parseEnsemble
+        (TE.encodeUtf8 (T.replace "num_leaves=1" "num_leaves=0" mlLoaderModel))
+        `shouldSatisfy` parseFailsAt "num_leaves"
+
   describe "feature_names containing '='" $
     it "accepts feature_names with '=' in a name" $
       parseEnsemble